From c0c98ded6ca38f92f929552a70baea75d9216700 Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Sat, 18 Jan 1997 14:32:04 +0000 Subject: [PATCH] Werkowskis source kit 1.03.7 --- FEATURES | 1 + RCSconfig | 3 + README.1st | 184 ++ SHADOW | 1 + boot.lisp | 21 + clx/dependent.lisp | 247 ++- clx/manager.lisp | 4 +- code/alieneval.lisp | 12 +- code/bignum.lisp | 9 +- code/bit-bash.lisp | 3 +- code/bsd-os.lisp | 66 + code/byte-interp.lisp | 12 +- code/clx-ext.lisp | 10 +- code/debug-int.lisp | 476 ++++- code/defmacro.lisp | 34 +- code/error.lisp | 12 +- code/exports.lisp | 20 +- code/fd-stream.lisp | 25 +- code/filesys.lisp | 14 +- code/float-trap.lisp | 28 +- code/foreign.lisp | 46 +- code/format.lisp | 7 +- code/gc.lisp | 24 +- code/internet.lisp | 82 +- code/irrat.lisp | 763 +++++++- code/linux-os.lisp | 75 + code/lispinit.lisp | 68 +- code/load.lisp | 108 +- code/macros.lisp | 13 +- code/misc.lisp | 6 +- code/ntrace.lisp | 4 +- code/numbers.lisp | 32 +- code/pathname.lisp | 51 +- code/pred.lisp | 10 +- code/save.lisp | 7 +- code/seq.lisp | 17 +- code/signal.lisp | 51 +- code/unix.lisp | 507 ++++-- code/x86-vm.lisp | 388 +++++ compiler/aliencomp.lisp | 16 +- compiler/constraint.lisp | 74 +- compiler/float-tran.lisp | 713 +++++++- compiler/fndb.lisp | 8 +- compiler/generic/core.lisp | 12 +- compiler/generic/new-genesis.lisp | 116 +- compiler/generic/vm-ir2tran.lisp | 6 +- compiler/generic/vm-macs.lisp | 15 +- compiler/generic/vm-tran.lisp | 4 +- compiler/ir2tran.lisp | 14 +- compiler/loadcom.lisp | 4 +- compiler/main.lisp | 8 +- compiler/new-assem.lisp | 36 +- compiler/pack.lisp | 89 +- compiler/srctran.lisp | 598 ++++++- compiler/x86/alloc.lisp | 268 +++ compiler/x86/arith.lisp | 1047 +++++++++++ compiler/x86/array.lisp | 655 +++++++ compiler/x86/c-call.lisp | 214 +++ compiler/x86/call.lisp | 1593 +++++++++++++++++ compiler/x86/cell.lisp | 305 ++++ compiler/x86/char.lisp | 171 ++ compiler/x86/debug.lisp | 181 ++ compiler/x86/float.lisp | 2252 ++++++++++++++++++++++++ compiler/x86/insts.lisp | 2695 +++++++++++++++++++++++++++++ compiler/x86/macros.lisp | 305 ++++ compiler/x86/memory.lisp | 109 ++ compiler/x86/move.lisp | 472 +++++ compiler/x86/nlx.lisp | 412 +++++ compiler/x86/parms.lisp | 284 +++ compiler/x86/pred.lisp | 82 + compiler/x86/print.lisp | 33 + compiler/x86/sap.lisp | 456 +++++ compiler/x86/static-fn.lisp | 182 ++ compiler/x86/subprim.lisp | 93 + compiler/x86/system.lisp | 304 ++++ compiler/x86/type-vops.lisp | 599 +++++++ compiler/x86/values.lisp | 135 ++ compiler/x86/vm.lisp | 496 ++++++ hemlock/diredcoms.lisp | 7 +- hemlock/echo.lisp | 3 +- hemlock/echocoms.lisp | 9 +- hemlock/eval-server.lisp | 10 +- hemlock/input.lisp | 4 +- hemlock/lisp-lib.lisp | 25 +- hemlock/lispeval.lisp | 5 +- hemlock/rompsite.lisp | 21 +- motif/lisp/initial.lisp | 6 +- motif/lisp/interface-glue.lisp | 6 +- motif/server/Config | 4 + motif/server/GNUmakefile | 6 +- motif/server/main.c | 54 +- pcl/boot.lisp | 182 +- pcl/braid.lisp | 98 +- pcl/cmu-low.lisp | 502 ++---- pcl/defcombin.lisp | 31 +- pcl/dfun.lisp | 160 +- pcl/vector.lisp | 47 +- pcl/walk.lisp | 5 +- tools/comcom.lisp | 50 +- tools/worldbuild.lisp | 6 +- tools/worldcom.lisp | 6 +- tools/worldload.lisp | 4 +- 102 files changed, 18610 insertions(+), 1138 deletions(-) create mode 100644 FEATURES create mode 100644 RCSconfig create mode 100644 README.1st create mode 100644 SHADOW create mode 100644 boot.lisp create mode 100644 code/bsd-os.lisp create mode 100644 code/linux-os.lisp create mode 100644 code/x86-vm.lisp create mode 100644 compiler/x86/alloc.lisp create mode 100644 compiler/x86/arith.lisp create mode 100644 compiler/x86/array.lisp create mode 100644 compiler/x86/c-call.lisp create mode 100644 compiler/x86/call.lisp create mode 100644 compiler/x86/cell.lisp create mode 100644 compiler/x86/char.lisp create mode 100644 compiler/x86/debug.lisp create mode 100644 compiler/x86/float.lisp create mode 100644 compiler/x86/insts.lisp create mode 100644 compiler/x86/macros.lisp create mode 100644 compiler/x86/memory.lisp create mode 100644 compiler/x86/move.lisp create mode 100644 compiler/x86/nlx.lisp create mode 100644 compiler/x86/parms.lisp create mode 100644 compiler/x86/pred.lisp create mode 100644 compiler/x86/print.lisp create mode 100644 compiler/x86/sap.lisp create mode 100644 compiler/x86/static-fn.lisp create mode 100644 compiler/x86/subprim.lisp create mode 100644 compiler/x86/system.lisp create mode 100644 compiler/x86/type-vops.lisp create mode 100644 compiler/x86/values.lisp create mode 100644 compiler/x86/vm.lisp create mode 100644 motif/server/Config diff --git a/FEATURES b/FEATURES new file mode 100644 index 000000000..ea8e6f1d2 --- /dev/null +++ b/FEATURES @@ -0,0 +1 @@ +:propagate-float-type :cmu18 :cmu17 :small :cgc :x86-lra diff --git a/RCSconfig b/RCSconfig new file mode 100644 index 000000000..f8424d49e --- /dev/null +++ b/RCSconfig @@ -0,0 +1,3 @@ +new_compiler +cmu +<> diff --git a/README.1st b/README.1st new file mode 100644 index 000000000..e1771b03e --- /dev/null +++ b/README.1st @@ -0,0 +1,184 @@ +January 5, 1997 + +This is release 1.03.7 of the X86 port of CMUCL. + +The source kit should work on any port. The kit contains +port specific directories only for X86. The best way to +use the source kit is to shadow the original 17f tree +using the EXTENTIONS:SEARCH-LIST feature. + +Changes since the 1.03.6 kit (23 November 96) include: + +Generic CMUCL: + + 1. Ray Toy has provided support for logical-pathname + namestrings in more (all?) IO functions that take + logical-pathname arguments. Probe-file and load + with LP namestrings work. + + 2. A bug in TRANSLATE-PATHNAME which caused recursive + logical-pathname translations to fail is fixed. + + 3. A few bugs were flushed and fixed by Douglas Crosher + while working the CL-HTTP port. + + 4. Ray Toy's enhancements to floating-point type + propagation seem real stable and really useful. + Add :propagate-float-type to *features* before compiling + a world. + + 5. A bug in file-author which signalled an error on + a pathname argument was fixed. Hemlock's change-log + function now works. + + 6. A few random bugs in Hemlock were fixed. + +X86 specific changes: + + 0. Due to the following, there may be bootstrap problems + building this release. Please load p86/boot.lisp + prior to running worldcom/worldbuild/comcom. You + must build at least 3 generations of compiler before + all changes propagate into place. You will need the + boot.lisp file only for the first generation build. + + 1. Major improvements in debugger support thanks to + Douglas Crosher. Previous "unknown code location" + notes from debug with confusing debug data are now + replaced by useful and accurate information. + + 2. More math functions are open coded using Intel's + fancy instructions. Sin, Cos and Tan are fast + inlined if the argument range is known to be (mod 2^64). + Currently arguments outside this range return a zero + value. An efficiency note is printed if the compiler + can't optimize to fast code. + + 3. A problem where PCL CLOS sometimes left dangling + pointers in unscanned (by GC) memory has been fixed. + +Bugs: + +Compiler errors are sometimes generated from LABELS +forms which use optional arguments. A workaround is +to not use optional arguments or include all args at +the call site. This seems to be the major outstanding bug. + +There is one known bug in restart-case which does not +want to work unless compiled to native code. + +A mis-feature is that compiled code is allocated in static +memory. This restriction may go away in a future release. +The impact of static allocation of compiled code is that +any dead code is not reclaimed and contributes to VM bloat. +This is an operational problem only in intensive incremental +code development. + +Please send comments and bugs to +Paul Werkowski +pw@snoopy.mv.com + +or to cmucl-imp@cons.org + +----------------------------------------------------------------------- +Informal Release History: + +November 23, 1996. 1.03.6 + +Changes since release 1.03.1 include + + * The FreeBSD/X86 source code has been merged with + the current CMU tree which had a number of unpublished + fixes applied since version 17f. + + * Changes specific to the Linux port have been + merged as well. These changes don't effect FreeBSD users. + + * Major improvements to the floating-point code generators + thanks to Douglas Crosher. + + * The internal "static-space" has changed along with + some internal static variable names. You probably will + have to recompile everything. Sorry. + + * The source kit now contains improvements to floating + point type propagation, thanks to Ray Toy. These + changes are still experimental, and disabled by default + in the binary distribution. When enabled, Python is able + to optimize the results of intermediate floating point + types through most arithmetic operations. This is useful + when bounded float types are used, + eg (declare (type (double-float 0d0) x y), then + (* x y) is known to be non-negative. See file srctran.lisp + for hints on how to enable this feature. + + * Many internal changes and improvements too + numerous to remember. + + +Changes since release 1.03 include: + + * A nasty little bug was found in floating-point + register loading that caused erroneous data to + be created in some conditions. It is now fixed thanks + to Douglas Crosher. + +Changes since release 1.02 include: + + * Fixed some obscure bugs in the Object System. + Non-standard method-combination now works. These + changes are platform-independent. + + * Fixed a problem in the definition of the arithmetic-error + condition which caused bad behavior with divide-by-zero + and floating-point exceptions. + + * Changes made by Peter Van Eynde for the first Linux release + have been merged into the current source tree. + + * Improved version of some irrational functions are included + thanks to Raymond Toy. + + * A few random bug fixes here and there. + +Changes since release 1.01 include: + + * Compiled library files for the major subsystems, + while not in the basic lisp image, are provided + separately on the www.mv.com/users/pw/lisp/dl + page. You can download what you want and use + bin/config to build a custom system. + + * Fixed problem with handling interrupts occuring + during execution of forms enclosed by + (without-interrupts ..), for example, interrupting + a garbage collection and then continuing caused + a bus error or segment violation. + + * Some random optimizations. + + * Reorganized the way foreign symbols are handled. + If you get "Unknown foreign symbol" warnings you + will need to recompile some code. + +Changes since release 1.0 include: + + * Fix to floating-point code generator that + caused incorrect results from FADD or FMUL when + both operands were in same register. + + * Support for auto-gc-trigger now notifies + lisp to consider whether or not to initiate GC. + + * Fix to save-lisp C support code which lost + the restart function address in some cases. + + * Improvements to platform specific parts of + debug-internals allow better stack backtracking, + with less hackery. + + * Includes all known patches from CMU. The bug + which caused the Motif inspector grief is now gone, + and the inspector is actually usable and useful. + + diff --git a/SHADOW b/SHADOW new file mode 100644 index 000000000..9b95b9b2c --- /dev/null +++ b/SHADOW @@ -0,0 +1 @@ +/local/lisp/cmucl/17f diff --git a/boot.lisp b/boot.lisp new file mode 100644 index 000000000..25b055cb8 --- /dev/null +++ b/boot.lisp @@ -0,0 +1,21 @@ +(load "target:code/exports.lisp") +#+x86(proclaim '(notinline kernel:%tan kernel:%atan kernel:%atan2)) +(in-package :x86) +(eval-when (compile load eval) +(defconstant conditions + '((:o . 0) + (:no . 1) + (:b . 2) (:nae . 2) (:c . 2) + (:nb . 3) (:ae . 3) (:nc . 3) + (:eq . 4) (:e . 4) (:z . 4) + (:ne . 5) (:nz . 5) + (:be . 6) (:na . 6) + (:nbe . 7) (:a . 7) + (:s . 8) + (:ns . 9) + (:p . 10) (:pe . 10) + (:np . 11) (:po . 11) + (:l . 12) (:nge . 12) + (:nl . 13) (:ge . 13) + (:le . 14) (:ng . 14) + (:nle . 15) (:g . 15)))) diff --git a/clx/dependent.lisp b/clx/dependent.lisp index 2da3615b7..0f8f2b6be 100644 --- a/clx/dependent.lisp +++ b/clx/dependent.lisp @@ -1,4 +1,4 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- +;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*- ;; This file contains some of the system dependent code for CLX @@ -20,6 +20,12 @@ (in-package :xlib) +(proclaim '(declaration array-register)) + +#+cmu +(setf (getf ext:*herald-items* :xlib) + `(" CLX X Library " ,*version*)) + ;;; The size of the output buffer. Must be a multiple of 4. (defparameter *output-buffer-size* 8192) @@ -67,6 +73,9 @@ ;;; declaration is available, it would be a good idea to make it here when ;;; *buffer-speed* is 3 and *buffer-safety* is 0. (defun declare-buffun () + #+(and cmu clx-debugging) + '(declare (optimize (speed 1) (safety 1))) + #-(and cmu clx-debugging) `(declare (optimize (speed ,*buffer-speed*) (safety ,*buffer-safety*)))) ) @@ -677,6 +686,25 @@ #.(declare-buffun) (the short-float (* (the int16 value) #.(coerce (/ pi 180.0 64.0) 'short-float)))) + +#+cmu (progn + +;;; This overrides the (probably incorrect) definition in clx.lisp. Since PI +;;; is irrational, there can't be a precise rational representation. In +;;; particular, the different float approximations will always be /=. This +;;; causes problems with type checking, because people might compute an +;;; argument in any precision. What we do is discard all the excess precision +;;; in the value, and see if the protocal encoding falls in the desired range +;;; (64'ths of a degree.) +;;; +(deftype angle () '(satisfies anglep)) + +(defun anglep (x) + (and (typep x 'real) + (<= (* -360 64) (radians->int16 x) (* 360 64)))) + +) + ;;----------------------------------------------------------------------------- ;; Character transformation @@ -873,16 +901,18 @@ ;;; against re-entering request functions. This can happen if an interrupt ;;; occurs and the handler attempts to use X over the same display connection. ;;; This can happen if the GC hooks are used to notify the user over the same -;;; display connection. We lock out GC's just as a dummy check for our users. -;;; Locking out interrupts has the problem that CLX always waits for replies -;;; within this dynamic scope, so if the server cannot reply for some reason, -;;; we potentially dead-lock without interrupts. +;;; display connection. We inhibit GC notifications since display of them +;;; could cause recursive entry into CLX. ;;; #+CMU (defmacro holding-lock ((locator display &optional whostate &key timeout) &body body) - (declare (ignore locator display whostate timeout)) - `(lisp::without-gcing (system:without-interrupts (progn ,@body)))) + `(let ((ext:*gc-verbose* nil) + (ext:*gc-inhibit-hook* nil) + (ext:*before-gc-hooks* nil) + (ext:*after-gc-hooks* nil)) + ,locator ,display ,whostate ,timeout + (system:without-interrupts (progn ,@body)))) #+Genera (defmacro holding-lock ((locator display &optional whostate &key timeout) @@ -1335,7 +1365,12 @@ ;;; The file descriptor here just gets tossed into the stream slot of the ;;; display object instead of a stream. ;;; -#+CMU +#+cmu +(alien:def-alien-routine ("connect_to_server" xlib::connect-to-server) + c-call:int + (host c-call:c-string) + (port c-call:int)) +#+cmu (defun open-x-stream (host display protocol) (declare (ignore protocol)) (let ((server-fd (connect-to-server host display))) @@ -1344,15 +1379,6 @@ (system:make-fd-stream server-fd :input t :output t :element-type '(unsigned-byte 8)))) -;;; This loads the C foreign function used to make an IPC connection -;;; to the X11 server. It also defines the necessary types and things -;;; to actually make the foreign call. See the OPEN-X-STREAM function -;;; in the dependent.lisp file. -;;; -#+CMU -(ext:def-c-routine ("connect_to_server" connect-to-server) (ext:int) - (host system:null-terminated-string) - (port ext:int)) ;;; BUFFER-READ-DEFAULT - read data from the X stream @@ -1454,9 +1480,9 @@ (declare (type display display) (type buffer-bytes vector) (type array-index start end) - (type (or null (real 0 *)) timeout)) + (type (or null fixnum) timeout)) #.(declare-buffun) - (cond ((and (and timeout (= timeout 0)) + (cond ((and (eql timeout 0) (not (listen (display-input-stream display)))) :timeout) (t @@ -1464,6 +1490,7 @@ vector start (- end start)) nil))) + ;;; WARNING: ;;; CLX performance will suffer if your lisp uses read-byte for ;;; receiving all data from the X Window System server. @@ -1573,6 +1600,15 @@ (declare (type array-index index)) (write-byte (aref vector index) stream)))))) +#+CMU +(defun buffer-write-default (vector display start end) + (declare (type buffer-bytes vector) + (type display display) + (type array-index start end)) + #.(declare-buffun) + (system:output-raw-bytes (display-output-stream display) vector start end) + nil) + ;;; buffer-force-output-default - force output to the X stream #+excl @@ -1580,7 +1616,7 @@ ;; buffer-write-default does the actual writing. (declare (ignore display))) -#-excl +#-(or excl) (defun buffer-force-output-default (display) ;; The default buffer force-output function for use with common-lisp streams (declare (type display display)) @@ -1599,7 +1635,7 @@ #.(declare-buffun) (excl::filesys-checking-close (display-output-stream display))) -#-excl +#-(or excl) (defun buffer-close-default (display &key abort) ;; The default buffer close function for use with common-lisp streams (declare (type display display)) @@ -1647,12 +1683,12 @@ #+CMU (defun buffer-input-wait-default (display timeout) (declare (type display display) - (type (or null (real 0 *)) timeout)) + (type (or null number) timeout)) (let ((stream (display-input-stream display))) (declare (type (or null stream) stream)) (cond ((null stream)) ((listen stream) nil) - ((and timeout (= timeout 0)) :timeout) + ((eql timeout 0) :timeout) (t (if (system:wait-until-fd-usable (system:fd-stream-fd stream) :input timeout) @@ -1782,7 +1818,7 @@ ;;; buffer. This should never block, so it can be called from the scheduler. ;;; The default implementation is to just use listen. -#-excl +#-(or excl) (defun buffer-listen-default (display) (declare (type display display)) (let ((stream (display-input-stream display))) @@ -2114,21 +2150,13 @@ #+CMU (defun x-error (condition &rest keyargs) (let ((condx (apply #'make-condition condition keyargs))) - (typecase condx - ;; This condition no longer exists. - #|| - (server-disconnect - (let ((disp (server-disconnect-display condx))) - (warn "Disabled event handling on ~S." disp) - (ext::disable-clx-event-handling disp))) - ||# - (closed-display - (let ((disp (closed-display-display condx))) - (warn "Disabled event handling on ~S." disp) - (ext::disable-clx-event-handling disp)))) + (when (eq condition 'closed-display) + (let ((disp (closed-display-display condx))) + (warn "Disabled event handling on ~S." disp) + (ext::disable-clx-event-handling disp))) (error condx))) -#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU) +#-(or lispm ansi-common-lisp excl lcl3.0 CMU) (defun x-error (condition &rest keyargs) (error "X-Error: ~a" (princ-to-string (apply #'make-condition condition keyargs)))) @@ -2589,7 +2617,7 @@ ;; WITH-STANDARD-IO-SYNTAX equivalent, used in (SETF WM-COMMAND) ;;----------------------------------------------------------------------------- -#-(or clx-ansi-common-lisp Genera) +#-(or clx-ansi-common-lisp Genera CMU) (defun with-standard-io-syntax-function (function) (declare #+lispm (sys:downward-funarg function)) @@ -2611,7 +2639,7 @@ #+lucid (lucid::*print-structure* t)) (funcall function))) -#-(or clx-ansi-common-lisp Genera) +#-(or clx-ansi-common-lisp Genera CMU) (defmacro with-standard-io-syntax (&body body) `(flet ((.with-standard-io-syntax-body. () ,@body)) (with-standard-io-syntax-function #'.with-standard-io-syntax-body.))) @@ -2691,22 +2719,22 @@ #+(or Genera Minima) 'fixnum) (deftype pixarray-1 () - '(array pixarray-1-element-type (* *))) + '(#+cmu simple-array #-cmu array pixarray-1-element-type (* *))) (deftype pixarray-4 () - '(array pixarray-4-element-type (* *))) + '(#+cmu simple-array #-cmu array pixarray-4-element-type (* *))) (deftype pixarray-8 () - '(array pixarray-8-element-type (* *))) + '(#+cmu simple-array #-cmu array pixarray-8-element-type (* *))) (deftype pixarray-16 () - '(array pixarray-16-element-type (* *))) + '(#+cmu simple-array #-cmu array pixarray-16-element-type (* *))) (deftype pixarray-24 () - '(array pixarray-24-element-type (* *))) + '(#+cmu simple-array #-cmu array pixarray-24-element-type (* *))) (deftype pixarray-32 () - '(array pixarray-32-element-type (* *))) + '(#+cmu simple-array #-cmu array pixarray-32-element-type (* *))) (deftype pixarray () '(or pixarray-1 pixarray-4 pixarray-8 pixarray-16 pixarray-24 pixarray-32)) @@ -2747,6 +2775,19 @@ (declare (type (simple-array ,element-type (*)) ,variable)) ,@body)) +#+CMU +;;; We do *NOT* support viewing an array as having a different element type. +;;; Element-type is ignored. +;;; +(defmacro with-underlying-simple-vector + ((variable element-type pixarray) &body body) + (declare (ignore element-type)) + `(lisp::with-array-data ((,variable ,pixarray) + (start) + (end)) + (declare (ignore start end)) + ,@body)) + ;;; These are used to read and write pixels from and to CARD8s. ;;; READ-IMAGE-LOAD-BYTE is used to extract 1 and 4 bit pixels from CARD8s. @@ -2916,14 +2957,16 @@ (index-ceiling x 8)) (index+ start padded-bytes-per-line)) (y 0 (index1+ y)) - (left-bits (index-mod (index- x) 8)) + (left-bits (the array-index (mod (the fixnum (- x)) 8))) (right-bits (index-mod (index- width left-bits) 8)) - (middle-bits (index- width left-bits right-bits)) + (middle-bits (the fixnum (- (the fixnum (- width left-bits)) + right-bits))) (middle-bytes (index-floor middle-bits 8))) ((index>= y height)) (declare (type array-index start y - left-bits right-bits middle-bits middle-bytes)) - (cond ((index< middle-bits 0) + left-bits right-bits middle-bytes) + (fixnum middle-bits)) + (cond ((< middle-bits 0) (let ((byte (aref buffer-bbuf (index1- start))) (x (array-row-major-index array y left-bits))) (declare (type card8 byte) @@ -2988,7 +3031,7 @@ (unless (index-zerop right-bits) (let ((byte (aref buffer-bbuf end)) (x (array-row-major-index - array y (index+ left-bits middle-bits)))) + array y (index+ left-bits middle-bits)))) (declare (type card8 byte) (type array-index x)) (setf (aref vector (index+ x 0)) @@ -3032,7 +3075,7 @@ (setf (aref vector (index+ x 7)) (read-image-load-byte 1 7 byte)))) ))))) - t) + t) #+(or lcl3.0 excl) (defun fast-read-pixarray-4 (buffer-bbuf index array x y width height @@ -3051,7 +3094,8 @@ (index-ceiling x 2)) (index+ start padded-bytes-per-line)) (y 0 (index1+ y)) - (left-nibbles (index-mod (index- x) 2)) + (left-nibbles (the array-index (mod (the fixnum (- (the fixnum x))) + 2))) (right-nibbles (index-mod (index- width left-nibbles) 2)) (middle-nibbles (index- width left-nibbles right-nibbles)) (middle-bytes (index-floor middle-nibbles 2))) @@ -3079,7 +3123,7 @@ ))) t) -#+(or Genera lcl3.0 excl) +#+(or Genera lcl3.0 excl CMU) (defun fast-read-pixarray-24 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) @@ -3125,6 +3169,63 @@ (sys:bitblt boole-1 width height a x y pixarray 0 0)) t) +#+CMU +(defun pixarray-element-size (pixarray) + (let ((eltype (array-element-type pixarray))) + (cond ((eq eltype 'bit) 1) + ((and (consp eltype) (eq (first eltype) 'unsigned-byte)) + (second eltype)) + (t + (error "Invalid pixarray: ~S." pixarray))))) + +#+CMU +;;; COPY-BIT-RECT -- Internal +;;; +;;; This is the classic BITBLT operation, copying a rectangular subarray +;;; from one array to another (but source and destination must not overlap.) +;;; Widths are specified in bits. Neither array can have a non-zero +;;; displacement. We allow extra random bit-offset to be thrown into the X. +;;; +(defun copy-bit-rect (source source-width sx sy dest dest-width dx dy + height width) + (declare (type array-index source-width sx sy dest-width dx dy height width)) + #.(declare-buffun) + (lisp::with-array-data ((sdata source) + (sstart) + (send)) + (declare (ignore send)) + (lisp::with-array-data ((ddata dest) + (dstart) + (dend)) + (declare (ignore dend)) + (assert (and (zerop sstart) (zerop dstart))) + (do ((src-idx (index+ (* vm:vector-data-offset vm:word-bits) + sx (index* sy source-width)) + (index+ src-idx source-width)) + (dest-idx (index+ (* vm:vector-data-offset vm:word-bits) + dx (index* dy dest-width)) + (index+ dest-idx dest-width)) + (count height (1- count))) + ((zerop count)) + (declare (type array-index src-idx dest-idx count)) + (kernel:bit-bash-copy sdata src-idx ddata dest-idx width))))) + +#+CMU +(defun fast-read-pixarray-using-bitblt + (bbuf boffset pixarray x y width height padded-bytes-per-line + bits-per-pixel) + (declare (type (array * 2) pixarray)) + #.(declare-buffun) + (copy-bit-rect bbuf + (index* padded-bytes-per-line vm:byte-bits) + (index* boffset vm:byte-bits) 0 + pixarray + (index* (array-dimension pixarray 1) bits-per-pixel) + x y + height + (index* width bits-per-pixel)) + t) + #+(or Genera lcl3.0 excl) (defun fast-read-pixarray-with-swap (bbuf boffset pixarray x y width height padded-bytes-per-line @@ -3199,13 +3300,16 @@ bits-per-pixel) 32)) #'fast-read-pixarray-using-bitblt) + #+CMU + (and (index= (pixarray-element-size pixarray) bits-per-pixel) + #'fast-read-pixarray-using-bitblt) #+(or lcl3.0 excl) (and (index= bits-per-pixel 1) #'fast-read-pixarray-1) #+(or lcl3.0 excl) (and (index= bits-per-pixel 4) #'fast-read-pixarray-4) - #+(or Genera lcl3.0 excl) + #+(or Genera lcl3.0 excl CMU) (and (index= bits-per-pixel 24) #'fast-read-pixarray-24)))) (when function @@ -3321,7 +3425,7 @@ (aref vector (index+ x 1)))))))) t) -#+(or Genera lcl3.0 excl) +#+(or Genera lcl3.0 excl CMU) (defun fast-write-pixarray-24 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) @@ -3369,6 +3473,21 @@ (sys:bitblt boole-1 width height pixarray x y a 0 0)) t) +#+CMU +(defun fast-write-pixarray-using-bitblt + (bbuf boffset pixarray x y width height padded-bytes-per-line + bits-per-pixel) + #.(declare-buffun) + (copy-bit-rect pixarray + (index* (array-dimension pixarray 1) bits-per-pixel) + x y + bbuf + (index* padded-bytes-per-line vm:byte-bits) + (index* boffset vm:byte-bits) 0 + height + (index* width bits-per-pixel)) + t) + #+(or Genera lcl3.0 excl) (defun fast-write-pixarray-with-swap (bbuf boffset pixarray x y width height padded-bytes-per-line @@ -3440,13 +3559,16 @@ bits-per-pixel) 32)) #'fast-write-pixarray-using-bitblt) + #+CMU + (and (index= (pixarray-element-size pixarray) bits-per-pixel) + #'fast-write-pixarray-using-bitblt) #+(or lcl3.0 excl) (and (index= bits-per-pixel 1) #'fast-write-pixarray-1) #+(or lcl3.0 excl) (and (index= bits-per-pixel 4) #'fast-write-pixarray-4) - #+(or Genera lcl3.0 excl) + #+(or Genera lcl3.0 excl CMU) (and (index= bits-per-pixel 24) #'fast-write-pixarray-24)))) (when function @@ -3464,7 +3586,7 @@ (type (member 1 4 8 16 24 32) bits-per-pixel)) (progn pixarray copy x y width height bits-per-pixel nil) (or - #+lispm + #+(or lispm CMU) (let* ((pixarray-padded-pixels-per-line #+Genera (sys:array-row-span pixarray) #-Genera (array-dimension pixarray 1)) @@ -3475,11 +3597,22 @@ #-Genera (array-dimension copy 1)) (copy-padded-bits-per-line (* copy-padded-pixels-per-line bits-per-pixel))) + #-CMU (when (and (= (sys:array-element-size pixarray) bits-per-pixel) (zerop (index-mod pixarray-padded-bits-per-line 32)) (zerop (index-mod copy-padded-bits-per-line 32))) (sys:bitblt boole-1 width height pixarray x y copy 0 0) + t) + #+CMU + (when (index= (pixarray-element-size pixarray) + (pixarray-element-size copy) + bits-per-pixel) + (copy-bit-rect pixarray pixarray-padded-bits-per-line x y + copy copy-padded-bits-per-line 0 0 + height + (index* width bits-per-pixel)) t)) + #+(or lcl3.0 excl) (unless (index= bits-per-pixel 24) (let ((pixarray-padded-bits-per-line diff --git a/clx/manager.lisp b/clx/manager.lisp index 5366cd18e..151e8be3c 100644 --- a/clx/manager.lisp +++ b/clx/manager.lisp @@ -317,8 +317,8 @@ (decode-type (member-vector *win-gravity-vector*) (aref vector 17))))) ;; Obsolete fields (when (or (logbitp 0 flags) (logbitp 2 flags)) - (setf (wm-size-hints-x hints) (aref vector 1) - (wm-size-hints-y hints) (aref vector 2))) + (setf (wm-size-hints-x hints) (card32->int32 (aref vector 1)) + (wm-size-hints-y hints) (card32->int32 (aref vector 2)))) (when (or (logbitp 1 flags) (logbitp 3 flags)) (setf (wm-size-hints-width hints) (aref vector 3) (wm-size-hints-height hints) (aref vector 4))) diff --git a/code/alieneval.lisp b/code/alieneval.lisp index 7828e3668..6f37ae2d9 100644 --- a/code/alieneval.lisp +++ b/code/alieneval.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/alieneval.lisp,v 1.37 1996/07/12 20:51:51 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/alieneval.lisp,v 1.38 1997/01/18 14:30:58 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1391,13 +1391,21 @@ ,@(when initial-value `((setq ,symbol ,initval))) ,@body) - (dispose-local-alien ',info ,var)))))))))))) + ;; This is a (temporary?) hack to + ;; counter resetting the stack BEFORE + ;; recovering values at stack top. We just + ;; let normal stack resetting to occur. This + ;; might be bad in a loop of with-alien forms. + #-x86 + (dispose-local-alien ',info ,var) + ))))))))))) (verify-local-auxiliaries-okay) `(compiler-let (*auxiliary-type-definitions* ',(append *new-auxiliary-types* *auxiliary-type-definitions*)) ,@body))) + ;;;; Runtime C values that don't correspond directly to Lisp types. diff --git a/code/bignum.lisp b/code/bignum.lisp index 47819f91b..71addb49a 100644 --- a/code/bignum.lisp +++ b/code/bignum.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/bignum.lisp,v 1.21 1994/10/31 04:11:27 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/bignum.lisp,v 1.22 1997/01/18 14:30:50 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -2483,9 +2483,10 @@ IS LESS EFFICIENT BUT EASIER TO MAINTAIN. BILL SAYS THIS CODE CERTAINLY WORKS! (%bignum-ref result (- len 2))) (sign-digit (%bignum-ref result (1- len)) next-digit)) ((not (zerop (logxor sign-digit (%ashr next-digit (1- digit-size)))))) - (when (= (decf len) 1) - (return)) - (setf (%bignum-ref result len) 0))) + (decf len) + (setf (%bignum-ref result len) 0) + (when (= len 1) + (return)))) len) ;;; %NORMALIZE-BIGNUM -- Internal. diff --git a/code/bit-bash.lisp b/code/bit-bash.lisp index 290d5b2e4..de4f47283 100644 --- a/code/bit-bash.lisp +++ b/code/bit-bash.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/bit-bash.lisp,v 1.18 1994/10/31 04:11:27 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/bit-bash.lisp,v 1.19 1997/01/18 14:30:33 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -77,6 +77,7 @@ (:big-endian big-endian) (:little-endian little-endian)))) +(proclaim '(inline shift-towards-start shift-towards-end)) (defun shift-towards-start (number count) "Shift NUMBER by COUNT bits, adding zero bits at the ``end'' and removing bits from the ``start.'' On big-endian machines this is a left-shift and diff --git a/code/bsd-os.lisp b/code/bsd-os.lisp new file mode 100644 index 000000000..b1a673e52 --- /dev/null +++ b/code/bsd-os.lisp @@ -0,0 +1,66 @@ +;;; -*- Package: SYSTEM -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/bsd-os.lisp,v 1.1 1997/01/18 14:30:43 ram Exp $") +;;; +;;; ********************************************************************** +;;; +;;; OS interface functions for CMU CL under Mach. +;;; +;;; Written and maintained mostly by Skef Wholey and Rob MacLachlan. +;;; Scott Fahlman, Dan Aronson, and Steve Handerson did stuff here, too. +;;; +;;; Hacked into (Free)bsd-os.lisp /Werkowski + +(in-package "SYSTEM") +(use-package "EXTENSIONS") +(export '(get-system-info get-page-size os-init)) + +(pushnew :bsd *features*) +(pushnew :freebsd *features*) + +(setq *software-type* "FreeBSD/4.4Lite") + +(defun software-version () + "Returns a string describing version of the supporting software." + (string-trim '(#\newline) + (with-output-to-string (stream) + (run-program "/usr/bin/uname" '("-sr") :output stream)))) + + +;;; OS-Init initializes our operating-system interface. It sets the values +;;; of the global port variables to what they should be and calls the functions +;;; that set up the argument blocks for the server interfaces. + +(defun os-init () + nil) + + +;;; GET-SYSTEM-INFO -- Interface +;;; +;;; Return system time, user time and number of page faults. +;;; +(defun get-system-info () + (multiple-value-bind (err? utime stime maxrss ixrss idrss + isrss minflt majflt) + (unix:unix-getrusage unix:rusage_self) + (declare (ignore maxrss ixrss idrss isrss minflt)) + (unless err? + (error "Unix system call getrusage failed: ~A." + (unix:get-unix-error-msg utime))) + + (values utime stime majflt))) + + +;;; GET-PAGE-SIZE -- Interface +;;; +;;; Return the system page size. +;;; +(defun get-page-size () + ;; probably should call getpagesize() + 4096) + diff --git a/code/byte-interp.lisp b/code/byte-interp.lisp index 5d3ae9cbd..382b77585 100644 --- a/code/byte-interp.lisp +++ b/code/byte-interp.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/byte-interp.lisp,v 1.31 1994/10/31 04:11:27 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/byte-interp.lisp,v 1.32 1997/01/18 14:31:13 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -163,11 +163,13 @@ (when (hairy-byte-function-rest-arg-p x) (res '&rest 't)) (ecase (hairy-byte-function-keywords-p x) - ((t) (res '&key)) - (:allow-others (res '&key '&allow-other-keys)) + ((t :allow-others) + (res '&key) + (dolist (key (hairy-byte-function-keywords x)) + (res `(,(car key) t))) + (if (eql (hairy-byte-function-keywords-p x) :allow-others) + (res '&allow-other-keys))) ((nil))) - (dolist (key (hairy-byte-function-keywords x)) - (res `(,(car key) t))) `(function ,(res) *)))))) diff --git a/code/clx-ext.lisp b/code/clx-ext.lisp index 7aa8d3e09..5aba98c6b 100644 --- a/code/clx-ext.lisp +++ b/code/clx-ext.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/clx-ext.lisp,v 1.10 1994/10/31 04:11:27 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/clx-ext.lisp,v 1.11 1997/01/18 14:30:53 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -49,7 +49,13 @@ (when string (let* ((string (coerce string 'simple-string)) (length (length string)) - (host-name "unix") + ;;pw--unix seems to be a non-existent host on all the systems + ;; I have access to, and certainly not on linux. Unless unix + ;; is an alias in /etc/hosts this won't work. So, lets use + ;; gethostname instead. There are also some issues regarding + ;; DNS and full/part time internet connection to get in the + ;; way of this working but those are not solved here. + (host-name #+nil "unix" (unix:unix-gethostname)) (display-num nil) (screen-num nil)) (declare (simple-string string)) diff --git a/code/debug-int.lisp b/code/debug-int.lisp index 5131e495f..dd9188f5d 100644 --- a/code/debug-int.lisp +++ b/code/debug-int.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.68 1994/10/31 04:11:27 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.69 1997/01/18 14:31:08 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -836,17 +836,194 @@ (defun kernel:function-word-offset (fun) (kernel:function-word-offset fun)) ;;; (defsetf kernel:stack-ref kernel:%set-stack-ref) - + (proclaim '(inline cstack-pointer-valid-p)) +;;; This must come before any use (of course) else the cross compiler +;;; uses it's own version which is WRONG for x86!!! (defun cstack-pointer-valid-p (x) (declare (type system:system-area-pointer x)) + #-:x86 (and (system:sap< x (kernel:current-sp)) (system:sap<= #-gengc (alien:alien-sap (alien:extern-alien "control_stack" (* t))) #+gengc (kernel:mutator-control-stack-base) x) + (zerop (logand (system:sap-int x) #b11))) + #+:x86 ;; stack grows to low address values + (and (system:sap>= x (kernel:current-sp)) + (system:sap> (alien:alien-sap + (alien:extern-alien "control_stack_end" (* t))) + x) (zerop (logand (system:sap-int x) #b11)))) +;;;; X86 support. Don't have lra objects so will search back for code header. + +(eval-when (compile eval) + (defmacro c-var-frob (lisp-fun c-var-name) + `(progn + (declaim (inline ,lisp-fun)) + (defun ,lisp-fun () + (alien:extern-alien ,c-var-name (alien:unsigned 32)))))) + +(c-var-frob static-space-start "static_space") +(c-var-frob read-only-space-start "read_only_space") + +(defun compiled-function-from-pc (pc &optional (limit 50000)) + ;;; x86 hack around not having lra objects. + (declare (type system-area-pointer pc) + (fixnum limit)) + (let ((base (int-sap (kernel:32bit-logical-and + (sap-int pc) + (kernel:32bit-logical-not vm:lowtag-mask))))) + (declare (type system-area-pointer base)) + (do ((hdrp (- (sap-int base) vm:word-bytes) + (- hdrp vm:word-bytes)) + (times limit (1- times))) + ((or (zerop times) + (> (read-only-space-start) hdrp)) + nil) + (declare (type (unsigned-byte 32) hdrp) + (fixnum times)) + (let ((hdrval (sap-ref-32 (int-sap hdrp) 0))) + (declare (type (unsigned-byte 32) hdrval)) + #+nil (format t "~&~x ~x~%" hdrp hdrval) + (when (and (= (kernel:32bit-logical-and hdrval vm:type-mask) + vm:function-header-type) + (= (sap-ref-32 (int-sap hdrp) + (* vm:function-self-slot vm:word-bytes)) + (+ hdrp (* vm:function-code-offset vm:word-bytes)))) + (let ((maybe-fcn (kernel:make-lisp-obj + (+ hdrp vm:function-pointer-type)))) + (when (and (functionp maybe-fcn) (compiled-function-p maybe-fcn)) + (return maybe-fcn)))))))) + + + +(defun compute-lra-data-from-pc(pc) + ;; pc is offset from dualword aligned function header + (declare (type system-area-pointer pc)) + (let ((function (compiled-function-from-pc pc))) + (when function + (let* ((code (kernel:function-code-header function)) + (code-header-len (* (kernel:get-header-data code) + vm:word-bytes)) + (pc-offset + (- (sap-int pc) + (- (kernel:get-lisp-obj-address code) + vm:other-pointer-type) + code-header-len))) +; (format t "c-lra-fpc ~a ~a ~a~%" pc code pc-offset) + (values pc-offset code))))) + +;;; maybe these should be generalized in xxx-vm.lisp +;;;(proclaim '(inline old-frame-pointer lisp-return-pc)) +(defun old-frame-pointer(scp) + (declare (type (alien:alien (* unix:sigcontext)) scp)) + (let* #+x86 ((cfp (vm:sigcontext-register scp vm::ebp-offset)) + (ofp (kernel:stack-ref (int-sap cfp) vm::ocfp-save-offset))) + #-x86 ((ofp (vm:sigcontext-register scp vm::ocfp-offset))) + (declare (type (unsigned-byte 32) #+x86 cfp ofp)) + (int-sap ofp))) + + +#+x86 +(defun lisp-return-pc(scp) + ;;; return a value that can be used in computation + (declare (type (alien:alien (* unix:sigcontext)) scp)) + (let* ((cfp (vm:sigcontext-register scp vm::ebp-offset)) + (lra (kernel:stack-ref (int-sap cfp) vm::return-pc-save-offset))) + lra)) +#-x86 +(defun lisp-return-pc(scp) + (declare (type (alien:alien (* unix:sigcontext)) scp)) + (vm:sigcontext-register scp vm::lra-offset)) + +#+x86 +(defconstant vm::nargs-offset #.vm::ecx-offset) +#+x86 +(progn +(defun lisp-return-pc-valid-p(loc) + (declare (type system-area-pointer loc)) + (let ((code-beg (int-sap (static-space-start))) + (code-end (int-sap (* lisp::*static-space-free-pointer* + vm:word-bytes)))) + (and (sap< code-beg loc) + (sap< loc code-end)))) + +(declaim (inline make-fixnum)) +(defun make-fixnum (sap) + (kernel:make-lisp-obj (ash (sap-int sap) 2))) + +;; These return hopefully correct ofp ret values at a call site +(defun maybe-lisp-from-c(fp) + (declare (type system-area-pointer fp)) + (let ((s0 (kernel:stack-ref fp vm::old-fp-save-offset)) + (s1 (kernel:stack-ref fp vm::return-pc-save-offset))) + (when (and (kernel:make-lisp-obj s0)(kernel:make-lisp-obj s1)) + (let ((lisp-ofp (int-sap s0)) + (lisp-lra (int-sap s1))) + ;;(format t "~&cf? ~a ~a~%" lisp-ofp lisp-lra) + ;; Check this logic now that C calls with lra. + (when (sap= lisp-ofp lisp-lra) ; Can't happen via Lisp + (let ((cfp (sap-ref-sap fp (* 0 vm:word-bytes))) + (cra (sap-ref-sap fp (* 1 vm:word-bytes)))) + ;;(format t "~&cf! ~a ~a~%" cfp cra) + (list (make-fixnum cra) cfp))))))) + +(defun maybe-lisp-from-lisp(fp) + (declare (type system-area-pointer fp)) + (when (cstack-pointer-valid-p fp) + (let ((s0 (kernel:stack-ref fp vm::old-fp-save-offset)) + (s1 (kernel:stack-ref fp vm::return-pc-save-offset))) + (when (and (kernel:make-lisp-obj s0) + (kernel:make-lisp-obj s1)) + (let ((ofp (int-sap s0)) + (lra (int-sap s1))) + ;;(format t "~&mlf ~a ~a~%" ofp lra) + (and (cstack-pointer-valid-p ofp) + (lisp-return-pc-valid-p lra) + (list (kernel:make-lisp-obj s1) ofp))))))) + +(defun maybe-c-from-c(fp) + (declare (type system-area-pointer fp)) + (let ((cfp (sap-ref-sap fp (* 0 vm:word-bytes))) + (cra (sap-ref-sap fp (* 1 vm:word-bytes))) + (end (int-sap (* lisp::*static-space-free-pointer* vm:word-bytes)))) + ;;(format t "~&cfc? ~a ~a" cfp cra) + (when (cstack-pointer-valid-p cfp) + (cond ((sap< cra (int-sap (static-space-start))) + ;;(format t "~&cfc!~%") + (list (make-fixnum cra) cfp)) + ;; sigtrap handler from interrupt + ((sap> cra end) + ;;(format t "~&INT~%") + (list nil cfp)))))) + +;;; ^C a running program and get C call semantics with Lisp return address. +(defun maybe-c-from-lisp(fp) + (declare (type system-area-pointer fp)) + (let ((cfp (sap-ref-sap fp (* 0 vm:word-bytes))) + (cra (sap-ref-sap fp (* 1 vm:word-bytes))) + (end (int-sap (* lisp::*static-space-free-pointer* vm:word-bytes)))) + ;;(format t "~&cfl? ~a ~a" cfp cra) + (when (cstack-pointer-valid-p cfp) + (cond ((sap< cra end) + ;;(format t "~&cfl!~%") + (list (make-fixnum cra) cfp)))))) + +(defun x86-call-context(fp) + (declare (type system-area-pointer fp)) + (let ((pair (cond ((maybe-lisp-from-lisp fp)) + ((maybe-lisp-from-c fp)) + ((maybe-c-from-c fp)) + ((maybe-c-from-lisp fp))))) + (if pair + (apply #'values pair) + (error "Debug can't resolve frame ~a" fp)))) +) +;;; end of x86 hacks + + ;;; DESCRIPTOR-SAP -- internal ;;; ;;; Convert the descriptor into a SAP. The bits all stay the same, we just @@ -899,7 +1076,7 @@ debug-fun))) (possibly-an-interpreted-frame (compute-calling-frame - (descriptor-sap + ( #-x86 descriptor-sap #+x86 int-sap (get-context-value real vm::ocfp-save-offset (c::compiled-debug-function-old-fp c-d-f))) @@ -917,15 +1094,18 @@ (bogus-debug-function (let ((fp (frame-pointer real))) (when (cstack-pointer-valid-p fp) + #+x86 + (multiple-value-bind (ra ofp) (x86-call-context fp) + (compute-calling-frame ofp ra frame)) + #-x86 (compute-calling-frame #-alpha - (system:sap-ref-sap fp (* vm::ocfp-save-offset - vm:word-bytes)) + (system:sap-ref-sap + fp (* vm::ocfp-save-offset vm:word-bytes)) #+alpha (kernel::int-sap - (system:sap-ref-32 fp (* vm::ocfp-save-offset - vm:word-bytes))) - + (system:sap-ref-32 + fp (* vm::ocfp-save-offset vm:word-bytes))) #-gengc (kernel:stack-ref fp vm::lra-save-offset) #+gengc @@ -941,6 +1121,7 @@ ;;; location offset on the stack. Loc is the saved sc-offset describing the ;;; main location. ;;; +#-x86 (defun get-context-value (frame stack-slot loc) (declare (type compiled-frame frame) (type unsigned-byte stack-slot) (type c::sc-offset loc)) @@ -949,6 +1130,25 @@ (if escaped (sub-access-debug-var-slot pointer loc escaped) (kernel:stack-ref pointer stack-slot)))) +#+x86 +(defun get-context-value (frame stack-slot loc) + (declare (type compiled-frame frame) (type unsigned-byte stack-slot) + (type c::sc-offset loc)) + (let ((pointer (frame-pointer frame)) + (escaped (compiled-frame-escaped frame))) + (if escaped + (ecase stack-slot + (#.vm::ocfp-save-offset + (sub-access-debug-var-slot pointer loc escaped)) + (#.vm::lra-save-offset + (kernel:make-lisp-obj + (sub-access-debug-var-slot pointer loc escaped)))) + (ecase stack-slot + (#.vm::ocfp-save-offset + (kernel:stack-ref pointer stack-slot)) + (#.vm::lra-save-offset + (kernel:make-lisp-obj (kernel:stack-ref pointer stack-slot))))))) + ;;; (defun (setf get-context-value) (value frame stack-slot loc) (declare (type compiled-frame frame) (type unsigned-byte stack-slot) @@ -1023,23 +1223,36 @@ ;;; Note: Sometimes LRA is actually a fixnum. This happens when lisp calls ;;; into C. In this case, the code object is stored on the stack after the ;;; LRA, and the LRA is the word offset. -;;; +;;; +;;;; x86 note. The non-lra version has not been tested with the +;;;; recent changes. I'm probably going to move to just using lra +;;;; and remove the x86-lra feature at some point. #-gengc (defun compute-calling-frame (caller lra up-frame) (declare (type system:system-area-pointer caller)) + ;;(format t "ccf: ~x ~a ~a~%" (sap-int caller) lra up-frame) (when (cstack-pointer-valid-p caller) (multiple-value-bind (code pc-offset escaped) (if lra (multiple-value-bind - (word-offset code) + (word-offset code) (if (ext:fixnump lra) (let ((fp (frame-pointer up-frame))) - (values lra - (kernel:stack-ref fp (1+ vm::lra-save-offset)))) + #+x86 (declare (ignore fp)) + (values + lra + #-x86 ;; fake-foreign-fcn sticks CODE pointer here + (kernel:stack-ref fp (1+ vm::lra-save-offset)))) + #+(or x86-lra (not x86)) (values (kernel:get-header-data lra) - (kernel:lra-code-header lra))) + (kernel:lra-code-header lra)) + #+(and x86 (not x86-lra)) + (compute-lra-data-from-pc (int-sap lra))) + (if code + #+(and x86 (not x86-lra))(values code word-offset nil) + #+(or x86-lra (not x86)) (values code (* (1+ (- word-offset (kernel:get-header-data code))) vm:word-bytes) @@ -1070,7 +1283,7 @@ (if up-frame (1+ (frame-number up-frame)) 0) escaped)))))) -#-gengc +#-(or gengc x86) (defun find-escaped-frame (frame-pointer) (declare (type system:system-area-pointer frame-pointer)) (dotimes (index lisp::*free-interrupt-context-index* (values nil 0 nil)) @@ -1103,7 +1316,7 @@ ;; We were in an assembly routine. Therefore, use the LRA as ;; the pc. (setf pc-offset - (- (vm:sigcontext-register scp vm::lra-offset) + (- (lisp-return-pc scp) (kernel:get-lisp-obj-address code) code-header-len))) (return @@ -1114,6 +1327,29 @@ (kernel:get-header-data real-lra) nil)) (values code pc-offset scp))))))))))) +#+x86 +(defun find-escaped-frame (frame-pointer) + (declare (type system:system-area-pointer frame-pointer)) + (dotimes (index lisp::*free-interrupt-context-index* (values nil 0 nil)) + (alien:with-alien + ((lisp-interrupt-contexts (array (* unix:sigcontext) nil) :extern)) + (let ((scp (alien:deref lisp-interrupt-contexts index))) + (when (sap= frame-pointer + (int-sap (vm:sigcontext-register scp vm::cfp-offset))) + (system:without-gcing + (multiple-value-bind + (pc-offset code) + (compute-lra-data-from-pc (vm:sigcontext-program-counter scp)) + (when (symbolp code) + (return (values code 0 scp))) + (return + (if (eq (kernel:%code-debug-info code) :bogus-lra) + (let ((real-lra (kernel:code-header-ref + code real-lra-slot))) + (values (kernel:lra-code-header real-lra) + (kernel:get-header-data real-lra) + nil)) + (values code pc-offset scp)))))))))) ;;; CODE-OBJECT-FROM-BITS -- internal. ;;; @@ -1246,8 +1482,7 @@ ;; ### Need to do something real. (values (make-bogus-debug-function "Assembler routine.") 0 - (system:int-sap - (vm:sigcontext-register state vm::ocfp-offset)))) + (old-frame-pointer state))) (#.vm:trace-table-function-prologue (values (make-bogus-debug-function "Function-Prologue in an assembler routine?") @@ -1272,8 +1507,7 @@ (#.vm:trace-table-call-site (values (debug-function-from-pc component pc-offset) pc-offset - (system:int-sap - (vm:sigcontext-register state vm::ocfp-offset)))) + (old-frame-pointer state))) (#.vm:trace-table-function-prologue #+nil ;; ### Need to do something real. (let* ((ra (system:int-sap @@ -1363,6 +1597,8 @@ ;;; the component, for function constants, and the c::compiled-debug-function. ;;; (defun debug-function-from-pc (component pc) + #+x86 ;; until no more bugs at least. + (declare (optimize (safety 1)(debug .5))) (let ((info (kernel:%code-debug-info component))) (cond ((not info) @@ -2705,24 +2941,25 @@ (frame-pointer frame) (or (compiled-debug-variable-save-sc-offset debug-var) (compiled-debug-variable-sc-offset debug-var)))))) - + ;;; SUB-ACCESS-DEBUG-VAR-SLOT -- Internal. ;;; +#-x86 (defun sub-access-debug-var-slot (fp sc-offset &optional escaped) (macrolet ((with-escaped-value ((var) &body forms) `(if escaped - (let ((,var (vm:sigcontext-register - escaped - (c::sc-offset-offset sc-offset)))) - ,@forms) - :invalid-value-for-unescaped-register-storage)) + (let ((,var (vm:sigcontext-register + escaped + (c::sc-offset-offset sc-offset)))) + ,@forms) + :invalid-value-for-unescaped-register-storage)) (escaped-float-value (format) `(if escaped - (vm:sigcontext-float-register - escaped - (c::sc-offset-offset sc-offset) - ',format) - :invalid-value-for-unescaped-register-storage)) + (vm:sigcontext-float-register + escaped + (c::sc-offset-offset sc-offset) + ',format) + :invalid-value-for-unescaped-register-storage)) (with-nfp ((var) &body body) `(let ((,var (if escaped (system:int-sap @@ -2775,6 +3012,8 @@ vm:word-bytes)))) (#.vm:control-stack-sc-number (kernel:stack-ref fp (c::sc-offset-offset sc-offset))) + (#.vm:immediate-stack-sc-number + (kernel:stack-ref fp (c::sc-offset-offset sc-offset))) (#.vm:base-char-stack-sc-number (with-nfp (nfp) (code-char (system:sap-ref-32 nfp (* (c::sc-offset-offset sc-offset) @@ -2792,6 +3031,90 @@ (system:sap-ref-sap nfp (* (c::sc-offset-offset sc-offset) vm:word-bytes))))))) +#+x86 +(defun sub-access-debug-var-slot (fp sc-offset &optional escaped) + (declare (type system:system-area-pointer fp)) + (macrolet ((with-escaped-value ((var) &body forms) + `(if escaped + (let ((,var (vm:sigcontext-register + escaped + (c::sc-offset-offset sc-offset)))) + ,@forms) + :invalid-value-for-unescaped-register-storage)) + (escaped-float-value (format) + `(if escaped + (vm:sigcontext-float-register + escaped + (c::sc-offset-offset sc-offset) + ',format) + :invalid-value-for-unescaped-register-storage))) + (case (c::sc-offset-scn sc-offset) + ((#.vm:any-reg-sc-number + #.vm:descriptor-reg-sc-number) + (system:without-gcing + (with-escaped-value (val) + (kernel:make-lisp-obj val)))) + (#.vm:base-char-reg-sc-number + (with-escaped-value (val) + (code-char val))) + (#.vm:sap-reg-sc-number + (with-escaped-value (val) + (system:int-sap val))) + (#.vm:signed-reg-sc-number + (with-escaped-value (val) + (if (logbitp (1- vm:word-bits) val) + (logior val (ash -1 vm:word-bits)) + val))) + (#.vm:unsigned-reg-sc-number + (with-escaped-value (val) + val)) + (#.vm:non-descriptor-reg-sc-number + (error "Local non-descriptor register access?")) + (#.vm:interior-reg-sc-number + (error "Local interior register access?")) + (#.vm:single-reg-sc-number + (escaped-float-value single-float)) + (#.vm:double-reg-sc-number + (escaped-float-value double-float)) + (#.vm:single-stack-sc-number + (system:sap-ref-single + (system:int-sap (- (system:sap-int fp) + (* (1+ (c::sc-offset-offset sc-offset)) + vm:word-bytes))) 0)) + (#.vm:double-stack-sc-number + (system:sap-ref-double + (system:int-sap (- (system:sap-int fp) + (* (+ (c::sc-offset-offset sc-offset) 2) + vm:word-bytes))) 0)) + ((#.vm:control-stack-sc-number #.vm:immediate-stack-sc-number) + (kernel:make-lisp-obj + (kernel:stack-ref fp (c::sc-offset-offset sc-offset)))) + (#.vm:base-char-stack-sc-number + (code-char + (system:sap-ref-32 + (system:int-sap (- (system:sap-int fp) + (* (1+ (c::sc-offset-offset sc-offset)) + vm:word-bytes))) 0))) + (#.vm:unsigned-stack-sc-number + (system:sap-ref-32 + (system:int-sap (- (system:sap-int fp) + (* (1+ (c::sc-offset-offset sc-offset)) + vm:word-bytes))) 0)) + (#.vm:signed-stack-sc-number + (system:signed-sap-ref-32 + (system:int-sap (- (system:sap-int fp) + (* (1+ (c::sc-offset-offset sc-offset)) + vm:word-bytes))) 0)) + (#.vm:sap-stack-sc-number + (system:sap-ref-sap + (system:int-sap (- (system:sap-int fp) + (* (1+ (c::sc-offset-offset sc-offset)) + vm:word-bytes))) 0)) + ;; Not using ecase to avoid recursive processing. + ;; I would rather see some hint as to what is wrong + (t (format t "Sc-offset-scn ~a fell through CASE ~%" + (c::sc-offset-scn sc-offset)) nil)) + )) ;;; %SET-DEBUG-VARIABLE-VALUE -- Internal. ;;; @@ -2842,6 +3165,7 @@ ;;; SUB-SET-DEBUG-VAR-SLOT -- Internal. ;;; +#-x86 ;; preserve original (defun sub-set-debug-var-slot (fp sc-offset value &optional escaped) (macrolet ((set-escaped-value (val) `(if escaped @@ -2929,6 +3253,81 @@ vm:word-bytes)) (the system:system-area-pointer value))))))) +#+x86 +(defun sub-set-debug-var-slot (fp sc-offset value &optional escaped) + (macrolet ((set-escaped-value (val) + `(if escaped + (setf (vm:sigcontext-register + escaped + (c::sc-offset-offset sc-offset)) + ,val) + value))) + #+nil ;; debug + (format t "~&sdvs ~a ~a ~a <= ~a~%" + (sc-number-name (c::sc-offset-scn sc-offset)) + (disassem::get-sc-name sc-offset c:*native-backend*) + (not (null escaped)) + value) + (ecase (c::sc-offset-scn sc-offset) + ((#.vm:any-reg-sc-number + #.vm:descriptor-reg-sc-number + #+rt #.vm:word-pointer-reg-sc-number) + (system:without-gcing + (set-escaped-value + (kernel:get-lisp-obj-address value)))) + (#.vm:base-char-reg-sc-number + (set-escaped-value (char-code value))) + (#.vm:sap-reg-sc-number + (set-escaped-value (system:sap-int value))) + (#.vm:signed-reg-sc-number + (set-escaped-value (logand value (1- (ash 1 vm:word-bits))))) + (#.vm:unsigned-reg-sc-number + (set-escaped-value value)) + (#.vm:non-descriptor-reg-sc-number + (error "Local non-descriptor register access?")) + (#.vm:interior-reg-sc-number + (error "Local interior register access?")) + (#.vm:single-reg-sc-number + #+nil ;; don't have escaped floats. + (set-escaped-float-value single-float value)) + (#.vm:double-reg-sc-number + #+nil ;; don't have escaped floats -- still in npx? + (set-escaped-float-value double-float value)) + (#.vm:single-stack-sc-number + (setf (system:sap-ref-single + (system:sap+ fp (* (1+ (c::sc-offset-offset sc-offset)) + (- vm:word-bytes))) 0) + (the single-float value))) + (#.vm:double-stack-sc-number + (setf (system:sap-ref-double + (system:sap+ fp (* (+ (c::sc-offset-offset sc-offset) 2) + (- vm:word-bytes))) 0) + (the double-float value))) + ((#.vm:control-stack-sc-number #.vm:immediate-stack-sc-number) + (setf (kernel:stack-ref fp (c::sc-offset-offset sc-offset)) value)) + (#.vm:base-char-stack-sc-number + (setf (system:sap-ref-32 + (system:sap+ fp (* (1+ (c::sc-offset-offset sc-offset)) + (- vm:word-bytes))) 0) + (char-code (the character value)))) + (#.vm:unsigned-stack-sc-number + (setf (system:sap-ref-32 + (system:sap+ fp (* (1+ (c::sc-offset-offset sc-offset)) + (- vm:word-bytes))) 0) + (the (unsigned-byte 32) value))) + (#.vm:signed-stack-sc-number + (setf (system:signed-sap-ref-32 + (system:sap+ fp (* (1+ (c::sc-offset-offset sc-offset)) + (- vm:word-bytes))) 0) + (the (signed-byte 32) value))) + (#.vm:sap-stack-sc-number + (setf (system:sap-ref-sap + (system:sap+ fp (* (1+ (c::sc-offset-offset sc-offset)) + (- vm:word-bytes))) 0) + (the system:system-area-pointer value)))))) + + + (defsetf debug-variable-value %set-debug-variable-value) @@ -2973,6 +3372,8 @@ ;;; This is the method for DEBUG-VARIABLE-VALIDITY for compiled-debug-variables. ;;; For safety, make sure basic-code-loc is what we think. ;;; +;;#+x86-compile-botch ;; tn conflict S1 + (defun compiled-debug-variable-validity (debug-var basic-code-loc) (check-type basic-code-loc compiled-code-location) (cond ((debug-variable-alive-p debug-var) @@ -3025,6 +3426,7 @@ ;;; Temporary buffer used to build form-number => source-path translation in ;;; FORM-NUMBER-TRANSLATIONS. ;;; + (defvar *form-number-temp* (make-array 10 :fill-pointer 0 :adjustable t)) ;;; Table used to detect CAR circularities in FORM-NUMBER-TRANSLATIONS. @@ -3609,6 +4011,18 @@ ;;; handle breaks for internal errors. ;;; (defun handle-breakpoint (offset component signal-context) +#+x86 + (multiple-value-bind (byte-offset code) + (let* ((pc (vm:sigcontext-program-counter + (alien:sap-alien signal-context (* unix:sigcontext)))) + (fn (compiled-function-from-pc pc))) + (values (- (sap-int pc) + (- (kernel:get-lisp-obj-address fn) + vm:function-pointer-type)) + (kernel:function-code-header fn))) + (setq offset byte-offset + component code)) + (let ((data (breakpoint-data component offset nil))) (unless data (error "Unknown breakpoint in ~S at offset ~S." @@ -3712,7 +4126,7 @@ cookie)))) (defun get-function-end-breakpoint-values (scp) - (let ((ocfp (system:int-sap (vm:sigcontext-register scp vm::ocfp-offset))) + (let ((ocfp (old-frame-pointer scp)) (nargs (kernel:make-lisp-obj (vm:sigcontext-register scp vm::nargs-offset))) (reg-arg-offsets '#.vm::register-arg-offsets) diff --git a/code/defmacro.lisp b/code/defmacro.lisp index 4de374023..a72f03011 100644 --- a/code/defmacro.lisp +++ b/code/defmacro.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defmacro.lisp,v 1.19 1996/05/08 13:24:59 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defmacro.lisp,v 1.20 1997/01/18 14:31:00 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -228,26 +228,30 @@ (push-let-binding var nil nil)))) (t (error "Non-symbol in lambda-list - ~S." var))))) - (push `(unless (<= ,minimum - (length (the list ,(if top-level - `(cdr ,arg-list-name) - arg-list-name))) - ,@(unless restp - (list maximum))) - ,(let ((arg (if top-level - `(cdr ,arg-list-name) - arg-list-name))) - (if (eq error-fun 'error) - `(do-arg-count-error ',error-kind ',name ,arg ',lambda-list - ,minimum ,(unless restp maximum)) - `(,error-fun 'defmacro-ll-arg-count-error + ;; Generate code to check the number of arguments, unless dotted + ;; in which case length will not work. + (unless restp + (push `(unless (<= ,minimum + (length (the list ,(if top-level + `(cdr ,arg-list-name) + arg-list-name))) + ,@(unless restp + (list maximum))) + ,(let ((arg (if top-level + `(cdr ,arg-list-name) + arg-list-name))) + (if (eq error-fun 'error) + `(do-arg-count-error ',error-kind ',name ,arg + ',lambda-list ,minimum + ,(unless restp maximum)) + `(,error-fun 'defmacro-ll-arg-count-error :kind ',error-kind ,@(when name `(:name ',name)) :argument ,arg :lambda-list ',lambda-list :minimum ,minimum ,@(unless restp `(:maximum ,maximum)))))) - *arg-tests*) + *arg-tests*)) (if keys (let ((problem (gensym "KEY-PROBLEM-")) (info (gensym "INFO-"))) diff --git a/code/error.lisp b/code/error.lisp index 814442b4a..2f7ac1b41 100644 --- a/code/error.lisp +++ b/code/error.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.44 1994/10/31 04:11:27 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.45 1997/01/18 14:30:53 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -681,7 +681,7 @@ If a string, the string is printed. Condition types are classes, but (as allowed by ANSI and not as described in - CLtL2) and neither STANDARD-OBJECTs nor STRUCTURE-OBJECTs. WITH-SLOTS and + CLtL2) are neither STANDARD-OBJECTs nor STRUCTURE-OBJECTs. WITH-SLOTS and SLOT-VALUE may not be used on condition objects." (let* ((parent-types (or parent-types '(condition))) (layout (find-condition-layout name parent-types)) @@ -807,7 +807,10 @@ (cons (list ,@(mapcar #'(lambda (x) `(cons ',(car x) ,(cadr x))) bindings)) *handler-clusters*))) - ,@forms)) + (multiple-value-prog1 + ,@forms + ;; Wait for any float exceptions + #+x86 (float-wait)))) ;;;; Condition definitions. @@ -916,7 +919,8 @@ (cell-error-name condition))))) (define-condition arithmetic-error (error) - ((operation :reader arithmetic-error-operation :initarg :operation) + ((operation :reader arithmetic-error-operation :initarg :operation + :initform nil) (operands :reader arithmetic-error-operands :initarg :operands)) (:report (lambda (condition stream) (format stream "Arithmetic error ~S signalled." diff --git a/code/exports.lisp b/code/exports.lisp index 77fab2a15..5a9397ce9 100644 --- a/code/exports.lisp +++ b/code/exports.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.107 1996/07/25 15:01:00 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.108 1997/01/18 14:30:55 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -248,7 +248,8 @@ "UNIX-TCGETATTR" "C-LFLAG" "VDSUSP" "C-OFLAG" "VSTOP" "C-CFLAG" "TTY-OCRNL" "VMIN" "VEOF" "TCSAFLUSH" "TTY-IXON" "C-CC" "SIOCSPGRP" "TERMIOS" "VQUIT" - "UNIX-TCSETATTR" "VINTR" "VSTART" "TIOCSIGSEND")) + "UNIX-TCSETATTR" "VINTR" "VSTART" "TIOCSIGSEND" + #+(or svr4 freebsd linux) "O_NDELAY")) (defpackage "FORMAT") (defpackage "COMMON-LISP" @@ -1036,7 +1037,8 @@ "ENTRY-NODE-INFO-NLX-TAG" "ENTRY-NODE-INFO-ST-TOP" "ENVIRONMENT-DEBUG-LIVE-TN" "ENVIRONMENT-LIVE-TN" "FASL-FILE-IMPLEMENTATIONS" "FAST-SAFE-COERCE-TO-FUNCTION" - "FAST-SYMBOL-FUNCTION" "FAST-SYMBOL-VALUE" "FLUSHABLE" "FOLDABLE" + "FAST-SYMBOL-FUNCTION" "FAST-SYMBOL-VALUE" + "FLUSHABLE" "FOLDABLE" "FORCE-TN-TO-STACK" "FOREIGN-SYMBOL-ADDRESS" "GET-VECTOR-SUBTYPE" "HALT" "IF-EQ" "INSTANCE-REF" "INSTANCE-SET" "IR2-COMPONENT-CONSTANTS" "IR2-CONVERT" @@ -1126,7 +1128,7 @@ "%SET-FUNCTION-SELF" "IR2-COMPONENT-DYNCOUNT-INFO" "DYNCOUNT-INFO" "DYNCOUNT-INFO-P") -)) +) (defpackage "WIRE" (:export "*CURRENT-WIRE*" "CONNECT-TO-REMOTE-SERVER" "CREATE-REQUEST-SERVER" "DESTROY-REQUEST-SERVER" @@ -1332,17 +1334,19 @@ "%ARRAY-DISPLACEMENT" "%ARRAY-FILL-POINTER" "%ARRAY-FILL-POINTER-P" "%ASIN" "%ASINH" "%ATAN" "%ATAN2" "%ATANH" "%CALLER-FRAME-AND-PC" "%CHECK-BOUND" "%CLOSURE-FUNCTION" - "%CLOSURE-INDEX-REF" "%COS" "%COSH" "%DEPOSIT-FIELD" + "%CLOSURE-INDEX-REF" "%COS" #+x86 "%COS-QUICK" "%COSH" "%DEPOSIT-FIELD" "%DOUBLE-FLOAT" "%DPB" "%EXP" "%FUNCTION-HEADER-ARGLIST" "%FUNCTION-HEADER-NAME" "%FUNCTION-HEADER-TYPE" "%HYPOT" "%LDB" - "%LOG" "%LOG10" "%MAKE-COMPLEX" + "%LOG" "%LOGB" "%LOG10" "%LOG1P" "%LOG1P-LIMITED" "%MAKE-COMPLEX" "%MAKE-FUNCALLABLE-INSTANCE" "%MAKE-RATIO" "%MASK-FIELD" "%NEGATE" - "%POW" "%RAW-BITS" "%SET-FUNCALLABLE-INSTANCE-FUNCTION" + "%POW" "%RAW-BITS" "%SCALB" "%SCALBN" "%SET-FUNCALLABLE-INSTANCE-FUNCTION" "%SET-FUNCALLABLE-INSTANCE-INFO" "%SET-RAW-BITS" "%SET-SAP-REF-16" "%SET-SAP-REF-32" "%SET-SAP-REF-8" "%SET-SAP-REF-DOUBLE" "%SET-SAP-REF-SAP" "%SET-SAP-REF-SINGLE" "%SET-STACK-REF" "%SIN" + #+x86 "%SIN-QUICK" "%SINGLE-FLOAT" "%SINH" "%SP-SET-DEFINITION" "%SP-SET-PLIST" "%SQRT" "%SXHASH-SIMPLE-STRING" "%SXHASH-SIMPLE-SUBSTRING" "%TAN" + #+x86 "%TAN-QUICK" "%TANH" "%UNARY-ROUND" "%UNARY-TRUNCATE" "%WITH-ARRAY-DATA" "*CURRENT-LEVEL*" "*EMPTY-TYPE*" "*EVAL-STACK-TOP*" "*NULL-TYPE*" "*PRETTY-PRINTER*" "*UNIVERSAL-TYPE*" @@ -1374,7 +1378,7 @@ "DATA-VECTOR-REF" "DATA-VECTOR-SET" "DECODE-DOUBLE-FLOAT" "DECODE-SINGLE-FLOAT" "DESCEND-INTO" "DIVISION-BY-ZERO-ERROR" "DOUBLE-FLOAT-EXPONENT" "DOUBLE-FLOAT-HIGH-BITS" - "DOUBLE-FLOAT-LOW-BITS" "DOUBLE-FLOAT-P" + "DOUBLE-FLOAT-LOW-BITS" "DOUBLE-FLOAT-P" "FLOAT-WAIT" "DYNAMIC-SPACE-FREE-POINTER" "ERROR-NUMBER-OR-LOSE" "FILENAME" "FLOAT-DIGITS" "FLOAT-EXPONENT" "FLOAT-FORMAT-DIGITS" "FLOAT-FORMAT-MAX" "FLOAT-RADIX" "FORM" "FUNCALLABLE-INSTANCE-P" diff --git a/code/fd-stream.lisp b/code/fd-stream.lisp index d0a48b5de..28138196d 100644 --- a/code/fd-stream.lisp +++ b/code/fd-stream.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fd-stream.lisp,v 1.37 1996/05/07 20:47:10 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fd-stream.lisp,v 1.38 1997/01/18 14:31:02 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -980,17 +980,18 @@ non-server method is also significantly more efficient for large reads. (setf (fd-stream-unread stream) nil) (setf (fd-stream-ibuf-head stream) 0) (setf (fd-stream-ibuf-tail stream) 0) - (loop - (let ((count (unix:unix-select (1+ (fd-stream-fd stream)) - (the (unsigned-byte 32) - (ash 1 (fd-stream-fd stream))) - 0 0 0))) - (cond ((eql count 1) - (do-input stream) - (setf (fd-stream-ibuf-head stream) 0) - (setf (fd-stream-ibuf-tail stream) 0)) - (t - (return)))))) + (catch 'eof-input-catcher + (loop + (let ((count (unix:unix-select (1+ (fd-stream-fd stream)) + (the (unsigned-byte 32) + (ash 1 (fd-stream-fd stream))) + 0 0 0))) + (cond ((eql count 1) + (do-input stream) + (setf (fd-stream-ibuf-head stream) 0) + (setf (fd-stream-ibuf-tail stream) 0)) + (t + (return t))))))) (:force-output (flush-output-buffer stream)) (:finish-output diff --git a/code/filesys.lisp b/code/filesys.lisp index 6e121ee89..032e336d2 100644 --- a/code/filesys.lisp +++ b/code/filesys.lisp @@ -6,7 +6,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/filesys.lisp,v 1.40 1996/07/12 19:21:58 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/filesys.lisp,v 1.41 1997/01/18 14:30:48 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -632,8 +632,14 @@ (defun unix-namestring (pathname &optional (for-input t) executable-only) "Convert PATHNAME into a string that can be used with UNIX system calls. Search-lists and wild-cards are expanded." + ;; toy@rtp.ericsson.se: Let unix-namestring also handle logical + ;; pathnames too. + (let ((path (let ((lpn (pathname pathname))) + (if (logical-pathname-p lpn) + (namestring (translate-logical-pathname lpn)) + pathname)))) (enumerate-search-list - (pathname pathname) + (pathname path) (collect ((names)) (enumerate-matches (name pathname nil :verify-existance for-input) (when (or (not executable-only) @@ -644,7 +650,7 @@ (when names (when (cdr names) (error "~S is ambiguous:~{~% ~A~}" pathname names)) - (return (car names))))))) + (return (car names)))))))) ;;;; TRUENAME and PROBE-FILE. @@ -753,7 +759,7 @@ (unless name (error "~S doesn't exist." file)) (multiple-value-bind (winp dev ino mode nlink uid) - (unix:unix-stat file) + (unix:unix-stat name) (declare (ignore dev ino mode nlink)) (if winp (lookup-login-name uid))))) diff --git a/code/float-trap.lisp b/code/float-trap.lisp index a33bd3ff2..ce6ea5bda 100644 --- a/code/float-trap.lisp +++ b/code/float-trap.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float-trap.lisp,v 1.8 1994/10/31 04:11:27 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float-trap.lisp,v 1.9 1997/01/18 14:30:52 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -152,8 +152,25 @@ ;;; ;;; Signal the appropriate condition when we get a floating-point error. ;;; + +#+FreeBSD +(define-condition floating-point-exception (arithmetic-error) + ((flags :initarg :traps + :reader floating-point-exception-traps)) + (:report (lambda (condition stream) + (format stream "Arithmetic error ~S signalled.~%" + (type-of condition)) + (let ((traps (floating-point-exception-traps condition))) + (if traps + (format stream + "Trapping conditions are: ~%~{ ~s~^~}~%" + traps) + (write-line + "No traps are enabled? How can this be?" + stream)))))) + (defun sigfpe-handler (signal code scp) - (declare (ignore signal code) + (declare (ignore signal code #+FreeBSD scp) (type system-area-pointer scp)) (let* ((modes (sigcontext-floating-point-modes (alien:sap-alien scp (* unix:sigcontext)))) @@ -169,5 +186,12 @@ (error 'floating-point-underflow)) ((not (zerop (logand float-inexact-trap-bit traps))) (error 'ext:floating-point-inexact)) + #+FreeBSD + ((zerop (ldb float-exceptions-byte modes)) + ;; I can't tell what caused the exception!! + (error 'floating-point-exception + :traps (getf (get-floating-point-modes) :traps))) (t (error "SIGFPE with no exceptions currently enabled?"))))) + + diff --git a/code/foreign.lisp b/code/foreign.lisp index 5c552f29e..ddc08ed72 100644 --- a/code/foreign.lisp +++ b/code/foreign.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/foreign.lisp,v 1.20 1995/02/16 22:41:02 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/foreign.lisp,v 1.21 1997/01/18 14:30:46 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -25,7 +25,13 @@ #+hppa (defconstant foreign-segment-start #x10C00000) #+hppa (defconstant foreign-segment-size #x00400000) +#+(and (not linux) x86) + (defconstant foreign-segment-start #x7000000) ; just an unused space +#+(and (not linux) x86) + (defconstant foreign-segment-size #x00400000) + (defvar *previous-linked-object-file* nil) +#-linux (defvar *foreign-segment-free-pointer* foreign-segment-start) (defun pick-temporary-file-name (&optional (base "/tmp/tmp~D~C")) @@ -51,7 +57,7 @@ (t (incf code)))))))) -#+(and sparc (not svr4)) +#+(or FreeBSD (and sparc (not svr4))) (alien:def-alien-type exec (alien:struct nil (magic c-call:unsigned-long) @@ -63,7 +69,7 @@ (trsize c-call:unsigned-long) (drsize c-call:unsigned-long))) -#-svr4 +#-(or linux svr4) (defun allocate-space-in-foreign-segment (bytes) (let* ((pagesize-1 (1- (get-page-size))) (memory-needed (logandc2 (+ bytes pagesize-1) pagesize-1)) @@ -75,7 +81,10 @@ (allocate-system-memory-at addr memory-needed) addr)) -#+(and sparc (not svr4)) +;;; pw-- This seems to work for FreeBSD. The MAGIC field is not tested +;;; for correct file format so it may croak if ld fails to produce the +;;; expected results. It is probably good enough for now. +#+(or FreeBSD (and sparc (not svr4))) (defun load-object-file (name) (format t ";;; Loading object file...~%") (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0) @@ -275,7 +284,7 @@ )) (unix:unix-close fd)))) -#-solaris +#-(or linux solaris) (defun parse-symbol-table (name) (format t ";;; Parsing symbol table...~%") (let ((symbol-table (make-hash-table :test #'equal))) @@ -286,14 +295,16 @@ (return)) (let* ((symbol (subseq line 11)) (address (parse-integer line :end 8 :radix 16)) + #+FreeBSD (kind (aref line 9)) ; filter out .o file names (old-address (gethash symbol lisp::*foreign-symbols*))) - (unless (or (null old-address) (= address old-address)) + (unless (or (null old-address) (= address old-address) + #+FreeBSD (char= kind #\F)) (warn "~S moved from #x~8,'0X to #x~8,'0X.~%" symbol old-address address)) (setf (gethash symbol symbol-table) address))))) (setf lisp::*foreign-symbols* symbol-table))) -#-solaris +#-(or linux solaris) (defun load-foreign (files &key (libraries '("-lc")) (base-file @@ -364,10 +375,13 @@ (export '(alternate-get-global-address)) -#-solaris -(defun alternate-get-global-address (symbol) 0) +#-(or freebsd solaris linux) +(defun alternate-get-global-address (symbol) + (declare (type simple-string symbol) + (ignore symbol)) + 0) -#+solaris +#+(or linux solaris) (progn (defconstant rtld-lazy 1) @@ -428,10 +442,12 @@ (concatenate 'string "/tmp/~D~S" (string (gensym))))) (error-output (make-string-output-stream))) - (format t ";;; Running /usr/ccs/bin/ld...~%") + #-linux (format t ";;; Running /usr/ccs/bin/ld...~%") + #+linux (format t ";;; Running /usr/bin/ld...~%") (force-output) (let ((proc (ext:run-program - "/usr/ccs/bin/ld" + #-linux "/usr/ccs/bin/ld" + #+linux "/usr/bin/ld" (list* "-G" "-o" @@ -447,10 +463,12 @@ :output error-output :error :output))) (unless proc - (error "Could not run /usr/ccs/bin/ld")) + (error #+linux "Could not run /usr/bin/ld" + #-linux "Could not run /usr/ccs/bin/ld")) (unless (zerop (ext:process-exit-code proc)) (system:serve-all-events 0) - (error "/usr/ccs/bin/ld failed:~%~A" + (error #-linux "/usr/ccs/bin/ld failed:~%~A" + #+linux "/usr/bin/ld failed:~%~A" (get-output-stream-string error-output))) (load-object-file output-file) (unix:unix-unlink output-file) diff --git a/code/format.lisp b/code/format.lisp index c7cdee2b6..385a5814a 100644 --- a/code/format.lisp +++ b/code/format.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/format.lisp,v 1.31 1996/05/08 14:44:25 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/format.lisp,v 1.32 1997/01/18 14:31:03 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -136,7 +136,10 @@ (incf posn) (push (cons posn (get-char)) params)) ((char= char #\,) - (push (cons (1- posn) nil) params)) + (push (cons (1- posn) nil) params) + (incf posn) + (if (not (char= (get-char) #\,)) + (decf posn))) ((char= char #\:) (if colonp (error 'format-error diff --git a/code/gc.lisp b/code/gc.lisp index cfb019e05..5eb81c72e 100644 --- a/code/gc.lisp +++ b/code/gc.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/gc.lisp,v 1.19 1994/10/31 04:11:27 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/gc.lisp,v 1.20 1997/01/18 14:30:34 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -42,16 +42,20 @@ (c-var-frob dynamic-0-space-start "dynamic_0_space") (c-var-frob dynamic-1-space-start "dynamic_1_space") (c-var-frob control-stack-start "control_stack") +#+x86 (c-var-frob control-stack-end "control_stack_end") (c-var-frob binding-stack-start "binding_stack") (c-var-frob current-dynamic-space-start "current_dynamic_space") - (declaim (inline dynamic-usage)) +#-cgc (defun dynamic-usage () (the (unsigned-byte 32) (- (system:sap-int (c::dynamic-space-free-pointer)) (current-dynamic-space-start)))) +#+cgc +(c-var-frob dynamic-usage "cgc_bytes_allocated") + (defun static-space-usage () (- (* lisp::*static-space-free-pointer* vm:word-bytes) (static-space-start))) @@ -61,7 +65,8 @@ (read-only-space-start))) (defun control-stack-usage () - (- (system:sap-int (c::control-stack-pointer-sap)) (control-stack-start))) +#-x86 (- (system:sap-int (c::control-stack-pointer-sap)) (control-stack)) +#+x86 (- (control-stack-end) (system:sap-int (c::control-stack-pointer-sap))) ) (defun binding-stack-usage () (- (system:sap-int (c::binding-stack-pointer-sap)) (binding-stack-start))) @@ -93,7 +98,7 @@ (room-minimal-info) (vm:memory-usage :count-spaces '(:dynamic) :print-spaces t - :cutoff 0.05 + :cutoff 0.05s0 :print-summary nil)) (defun room-maximal-info () @@ -189,9 +194,11 @@ ;;; On the RT, we store the GC trigger in a ``static'' symbol instead of ;;; letting magic C code handle it. It gets initialized by the startup -;;; code. -#+ibmrt -(defvar rt::*internal-gc-trigger*) +;;; code. The X86 port defines this here because it uses the `ibmrt' +;;; feature in the C code for allocation and binding stack access and +;;; a lot of stuff wants this INTERNAL_GC_TRIGGER available as well. +#+(or ibmrt x86) +(defvar vm::*internal-gc-trigger*) ;;; ;;; The following specials are used to control when garbage collection @@ -392,7 +399,8 @@ (when verbose-p (carefully-funcall *gc-notify-after* post-gc-dyn-usage bytes-freed - *gc-trigger*)))))) + *gc-trigger*)))) + (scrub-control-stack))) (incf *gc-run-time* (- (get-internal-run-time) start-time)))) nil) diff --git a/code/internet.lisp b/code/internet.lisp index ed6c57085..cbc89f861 100644 --- a/code/internet.lisp +++ b/code/internet.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/internet.lisp,v 1.17 1994/10/31 04:11:27 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/internet.lisp,v 1.18 1997/01/18 14:30:52 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -40,13 +40,32 @@ (defconstant sock-raw 3) #+svr4 (defconstant sock-raw 4) +#+linux +(defconstant sock-rdm 4) +#+linux +(defconstant sock-seqpacket 5) +#+linux +(defconstant sock-packet 10) (defconstant af-unix 1) (defconstant af-inet 2) - +#+linux +(progn + (defconstant af-ax25 3) + (defconstant af-ipx 4) + (defconstant af-appletalk 5) + (defconstant af-netrom 6) + (defconstant af-bridge 7) + (defconstant af-aal5 9) + (defconstant af-x25 9) + (defconstant af-inet6 10) + (defconstant af-max 12)) + (defconstant msg-oob 1) (defconstant msg-peek 2) (defconstant msg-dontroute 4) +#+linux +(defconstant msg-proxy 16) (defvar *internet-protocols* (list (list :stream 6 sock-stream) @@ -96,11 +115,51 @@ (declare (type host-entry host)) (car (host-entry-addr-list host))) +#-FreeBSD (def-alien-type unix-sockaddr (struct nil - (family #-alpha short #+alpha unsigned-short) + (family #-(or linux alpha) short #+(or linux alpha) unsigned-short) (path (array char 108)))) - +#| +struct sockaddr_un { + u_char sun_len; /* sockaddr len including null */ + u_char sun_family; /* AF_UNIX */ + char sun_path[104]; /* path name (gag) */ +}; +|# + +#+FreeBSD +(def-alien-type unix-sockaddr + (struct nil + (sun-len unsigned-char) + (family unsigned-char) + (path (array char 104)))) +#| +/* + * Socket address, internet style. + */ +struct sockaddr_in { + u_char sin_len; + u_char sin_family; + u_short sin_port; + struct in_addr sin_addr; + char sin_zero[8]; +}; +struct in_addr { + u_long s_addr; +}; + +|# +#+FreeBSD +(def-alien-type inet-sockaddr + (struct nil + (sin-len unsigned-char) + (family unsigned-char) + (port unsigned-short) + (addr unsigned-long) + (zero (array char 8)))) + +#-FreeBSD (def-alien-type inet-sockaddr (struct nil (family #-alpha short #+alpha unsigned-short) @@ -108,6 +167,7 @@ (addr #-alpha unsigned-long #+alpha unsigned-int) (zero (array char 8)))) + (def-alien-type hostent (struct nil (name c-string) @@ -158,8 +218,11 @@ index)) (results)) (t - (results (deref (deref (slot hostent 'addr-list) index))) - (repeat (1+ index))))))))))) + (results +#-linux (deref (deref (slot hostent 'addr-list) index)) +#+linux (ntohl (deref (deref (slot hostent 'addr-list) index))) + ) + (repeat (1+ index))))))))))) (defun create-unix-socket (&optional (kind :stream)) (multiple-value-bind (proto type) @@ -203,7 +266,9 @@ (with-alien ((sockaddr inet-sockaddr)) (setf (slot sockaddr 'family) af-inet) (setf (slot sockaddr 'port) (htons port)) - (setf (slot sockaddr 'addr) (host-entry-addr hostent)) + (setf (slot sockaddr 'addr) + #-linux (host-entry-addr hostent) + #+linux (htonl (host-entry-addr hostent))) (when (minusp (unix:unix-connect socket (alien-sap sockaddr) (alien-size inet-sockaddr :bytes))) @@ -241,7 +306,8 @@ (alien-size inet-sockaddr :bytes)))) (when (minusp connected) (error "Error accepting a connection: ~A" (unix:get-unix-error-msg))) - (values connected (slot sockaddr 'addr))))) + (values connected #-linux (slot sockaddr 'addr) + #+linux (ntohl (slot sockaddr 'addr)))))) (defun close-socket (socket) (multiple-value-bind (ok err) diff --git a/code/irrat.lisp b/code/irrat.lisp index 7679b3b95..4dbada9bf 100644 --- a/code/irrat.lisp +++ b/code/irrat.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/irrat.lisp,v 1.16 1996/07/08 19:17:28 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/irrat.lisp,v 1.17 1997/01/18 14:30:40 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -56,13 +56,13 @@ ;;; Please refer to the Unix man pages for details about these routines. ;;; Trigonometric. -(def-math-rtn "sin" 1) -(def-math-rtn "cos" 1) -(def-math-rtn "tan" 1) +#-x86 (def-math-rtn "sin" 1) +#-x86 (def-math-rtn "cos" 1) +#-x86 (def-math-rtn "tan" 1) (def-math-rtn "asin" 1) (def-math-rtn "acos" 1) -(def-math-rtn "atan" 1) -(def-math-rtn "atan2" 2) +#-x86 (def-math-rtn "atan" 1) +#-x86 (def-math-rtn "atan2" 2) (def-math-rtn "sinh" 1) (def-math-rtn "cosh" 1) (def-math-rtn "tanh" 1) @@ -71,12 +71,85 @@ #-hpux (def-math-rtn "atanh" 1) ;;; Exponential and Logarithmic. -(def-math-rtn "exp" 1) -(def-math-rtn "log" 1) -(def-math-rtn "log10" 1) +#-x86(def-math-rtn "exp" 1) +#-x86(def-math-rtn "log" 1) +#-x86(def-math-rtn "log10" 1) (def-math-rtn "pow" 2) -(def-math-rtn "sqrt" 1) +#-x86 (def-math-rtn "sqrt" 1) (def-math-rtn "hypot" 2) +(def-math-rtn "log1p" 1) + +#+x86 ;; These are needed for use by byte-compiled files. +(progn + (defun %sin (x) + (declare (type double-float x) + (values double-float)) + (%sin x)) + (defun %sin-quick (x) + (declare (double-float x) + (values double-float)) + (%sin-quick x)) + (defun %cos (x) + (declare (type double-float x) + (values double-float)) + (%cos x)) + (defun %cos-quick (x) + (declare (double-float x) + (values double-float)) + (%cos-quick x)) + (defun %tan (x) + (declare (double-float x) + (values double-float)) + (%tan x)) + (defun %tan-quick (x) + (declare (double-float x) + (values double-float)) + (%tan-quick x)) + (defun %atan (x) + (declare (double-float x) + (values double-float)) + (%atan x)) + (defun %atan2 (x y) + (declare (double-float x y) + (values double-float)) + (%atan2 x y)) + (defun %exp (x) + (declare (type double-float x) + (values double-float)) + (%exp x)) + (defun %log (x) + (declare (type double-float x) + (values double-float)) + (%log x)) + (defun %log10 (x) + (declare (type double-float x) + (values double-float)) + (%log10 x)) + + #+nil ;; notyet + (defun %pow (x y) + (declare (type (double-float 0d0) x) + (type double-float y) + (values (double-float 0d0))) + (%pow x y)) + (defun %sqrt (x) + (declare (type double-float x) + (values double-float)) + (%sqrt x)) + (defun %scalbn (f ex) + (declare (type double-float f) + (type (signed-byte 32) ex) + (values double-float)) + (%scalbn f ex)) + (defun %scalb (f ex) + (declare (double-float f ex) + (values double-float)) + (%scalb f ex)) + (defun %logb (x) + (declare (double-float x) + (values double-float)) + (%logb x)) + ) ; progn ;;;; Power functions. @@ -161,10 +234,8 @@ (cis (* power (phase base))))) (((foreach fixnum (or bignum ratio) single-float double-float) complex) - (if (minusp base) - (/ (exp (* power (truly-the float (log (- base)))))) - (exp (* power (truly-the float (log base)))))) - (((foreach (complex float) (complex rational)) complex) + (exp (* power (log base)))) + (((foreach (complex float) (complex rational)) number) (exp (* power (log base)))))))) (defun log (number &optional (base nil base-p)) @@ -172,28 +243,45 @@ (if base-p (/ (log number) (log base)) (number-dispatch ((number number)) - (((foreach fixnum bignum ratio single-float)) + (((foreach fixnum bignum ratio)) (if (minusp number) (complex (log (- number)) (coerce pi 'single-float)) (coerce (%log (coerce number 'double-float)) 'single-float))) - ((double-float) - (if (minusp number) - (complex (log (- number)) (coerce pi 'double-float)) - (%log number))) - ((complex) (complex (log (abs number)) (phase number)))))) + (((foreach single-float double-float)) + ;; Is (log -0) -infinity (libm.a) or -infinity + i*pi (Kahan)? + ;; Since this doesn't seem to be an implementation issue + ;; I (pw) take the Kahan result. + (if (< (float-sign number) + (coerce 0 '(dispatch-type number))) + (complex (log (- number)) (coerce pi '(dispatch-type number))) + (coerce (%log (coerce number 'double-float)) + '(dispatch-type number)))) + ((complex) + (complex-log number))))) (defun sqrt (number) "Return the square root of NUMBER." (number-dispatch ((number number)) - (((foreach fixnum bignum ratio single-float)) + (((foreach fixnum bignum ratio)) (if (minusp number) - (exp (/ (log number) 2)) + (complex-sqrt number) (coerce (%sqrt (coerce number 'double-float)) 'single-float))) - ((double-float) - (if (minusp number) - (exp (/ (log number) 2)) - (%sqrt number))) - ((complex) (exp (/ (log number) 2))))) + (((foreach single-float double-float)) + ;; NOTE there is a problem with (at least x86 NPX) of what result + ;; should be returned for (sqrt -0.0). The x86 hardware FSQRT + ;; instruction returns -0d0. The result is that Python will perhaps + ;; note the following test in generic sqrt, non-negatively constrained + ;; float types will be passed to FSQRT (or libm on other boxes). + ;; So, in the interest of consistency of compiled and interpreted + ;; codes, the following test is disabled for now. Maybe the float-sign + ;; test could be moved to the optimization codes. + (if (< (#+nil float-sign #-nil identity number) + (coerce 0 '(dispatch-type number))) + (complex-sqrt number) + (coerce (%sqrt (coerce number 'double-float)) + '(dispatch-type number)))) + ((complex) + (complex-sqrt number)))) ;;;; Trigonometic and Related Functions @@ -222,12 +310,16 @@ For non-complex positive numbers, this is 0. For non-complex negative numbers this is PI." (etypecase number - ((or rational single-float) + (rational (if (minusp number) (coerce pi 'single-float) 0.0f0)) + (single-float + (if (minusp (float-sign number)) + (coerce pi 'single-float) + 0.0f0)) (double-float - (if (minusp number) + (if (minusp (float-sign number)) (coerce pi 'double-float) 0.0d0)) (complex @@ -241,7 +333,8 @@ ((complex) (let ((x (realpart number)) (y (imagpart number))) - (complex (* (sin x) (cosh y)) (* (cos x) (sinh y))))))) + (complex (* (sin x) (cosh y)) + (* (cos x) (sinh y))))))) (defun cos (number) "Return the cosine of NUMBER." @@ -250,17 +343,15 @@ ((complex) (let ((x (realpart number)) (y (imagpart number))) - (complex (* (cos x) (cosh y)) (- (* (sin x) (sinh y)))))))) + (complex (* (cos x) (cosh y)) + (- (* (sin x) (sinh y)))))))) (defun tan (number) "Return the tangent of NUMBER." (number-dispatch ((number number)) (handle-reals %tan number) ((complex) - (let* ((num (sin number)) - (denom (cos number))) - (if (zerop denom) (error "~S undefined tangent." number) - (/ num denom)))))) + (complex-tan number)))) (defun cis (theta) "Return cos(Theta) + i sin(Theta), AKA exp(i Theta)." @@ -268,14 +359,6 @@ (error "Argument to CIS is complex: ~S" theta) (complex (cos theta) (sin theta)))) -(proclaim '(inline mult-by-i)) -(defun mult-by-i (number) - (complex (imagpart number) - (- (realpart number)))) - -(defun complex-asin (number) - (- (mult-by-i (log (+ (mult-by-i number) (sqrt (- 1 (* number number)))))))) - (defun asin (number) "Return the arc sine of NUMBER." (number-dispatch ((number number)) @@ -292,9 +375,6 @@ ((complex) (complex-asin number)))) -(defun complex-acos (number) - (- (mult-by-i (log (+ number (mult-by-i (sqrt (- (* number number))))))))) - (defun acos (number) "Return the arc cosine of NUMBER." (number-dispatch ((number number)) @@ -339,61 +419,616 @@ (number-dispatch ((y number)) (handle-reals %atan y) ((complex) - (let ((im (imagpart y)) - (re (realpart y))) - (/ (- (log (complex (- 1 im) re)) - (log (complex (+ 1 im) (- re)))) - (complex 0 2))))))) + (complex-atan y))))) +;; It seems that everyone has a C version of sinh, cosh, and +;; tanh. Let's use these for reals because the original +;; implementations based on the definitions lose big in round-off +;; error. These bad definitions also mean that sin and cos for +;; complex numbers can also lose big. +#+nil (defun sinh (number) "Return the hyperbolic sine of NUMBER." (/ (- (exp number) (exp (- number))) 2)) +(defun sinh (number) + "Return the hyperbolic sine of NUMBER." + (number-dispatch ((number number)) + (handle-reals %sinh number) + ((complex) + (let ((x (realpart number)) + (y (imagpart number))) + (complex (* (sinh x) (cos y)) + (* (cosh x) (sin y))))))) + +#+nil (defun cosh (number) "Return the hyperbolic cosine of NUMBER." (/ (+ (exp number) (exp (- number))) 2)) +(defun cosh (number) + "Return the hyperbolic cosine of NUMBER." + (number-dispatch ((number number)) + (handle-reals %cosh number) + ((complex) + (let ((x (realpart number)) + (y (imagpart number))) + (complex (* (cosh x) (cos y)) + (* (sinh x) (sin y))))))) + (defun tanh (number) "Return the hyperbolic tangent of NUMBER." - (/ (- (exp number) (exp (- number))) - (+ (exp number) (exp (- number))))) - + (number-dispatch ((number number)) + (handle-reals %tanh number) + ((complex) + (complex-tanh number)))) (defun asinh (number) "Return the hyperbolic arc sine of NUMBER." - (log (+ number (sqrt (1+ (* number number)))))) + (number-dispatch ((number number)) + (handle-reals %asinh number) + ((complex) + (complex-asinh number)))) (defun acosh (number) "Return the hyperbolic arc cosine of NUMBER." - (* 2 (log (+ (sqrt (/ (1+ number) 2)) (sqrt (/ (1- number) 2)))))) + (number-dispatch ((number number)) + ((rational) + ;; acosh is complex if number < 1 + (if (< number 1) + (complex-acosh number) + (coerce (%acosh (coerce number 'double-float)) 'single-float))) + (((foreach single-float double-float)) + (if (< number (coerce 1 '(dispatch-type number))) + (complex-acosh number) + (coerce (%acosh (coerce number 'double-float)) + '(dispatch-type number)))) + ((complex) + (complex-acosh number)))) (defun atanh (number) "Return the hyperbolic arc tangent of NUMBER." - (/ (- (log (1+ number)) (log (- 1 number))) 2)) - + (number-dispatch ((number number)) + ((rational) + ;; atanh is complex if |number| > 1 + (if (or (> number 1) (< number -1)) + (complex-atanh number) + (coerce (%atanh (coerce number 'double-float)) 'single-float))) + (((foreach single-float double-float)) + (if (or (> number (coerce 1 '(dispatch-type number))) + (< number (coerce -1 '(dispatch-type number)))) + (complex-atanh number) + (coerce (%atanh (coerce number 'double-float)) + '(dispatch-type number)))) + ((complex) + (complex-atanh number)))) ;;; HP-UX does not supply C versions of asinh, acosh, and atanh, so just -;;; use the same equations as above, but force double-float arith. +;;; use the definitions. #+hpux (defun %asinh (number) (declare (type double-float number) (values double-float) (optimize (speed 3) (safety 0) (inhibit-warnings 3))) - (log (+ number (the double-float (sqrt (1+ (* number number))))))) + (log (+ number (sqrt (+ 1.0d0 (* number number)))))) #+hpux (defun %acosh (number) - (declare (type double-float number) + (declare (type (double-float 1.0d0) number) (values double-float) (optimize (speed 3) (safety 0) (inhibit-warnings 3))) - (* 2 (log (+ (the double-float (sqrt (/ (1+ number) 2))) - (the double-float (sqrt (/ (1- number) 2))))))) + (log (+ number (* (sqrt (- number 1.0d0)) + (sqrt (+ number 1.0d0)))))) #+hpux (defun %atanh (number) - (declare (type double-float number) + (declare (type (double-float -1.0d0 1.0d0) number) (values double-float) (optimize (speed 3) (safety 0) (inhibit-warnings 3))) + (* 0.5d0 (- (log (+ 1.0d0 number)) + (log (- 1.0d0 number))))) + + + +#+old-elfun +(progn +;;; Here are the old definitions of the special functions, for +;;; complex-valued arguments. Some of these functions suffer from +;;; severe round-off error or unnecessary overflow. + +(proclaim '(inline mult-by-i)) +(defun mult-by-i (number) + (complex (- (imagpart number)) + (realpart number))) + +(defun complex-sqrt (x) + (exp (/ (log x) 2))) + +(defun complex-log (x) + (complex (log (abs x)) + (phase x))) + +(defun complex-atanh (number) (/ (- (log (1+ number)) (log (- 1 number))) 2)) + +(defun complex-tanh (number) + (/ (- (exp number) (exp (- number))) + (+ (exp number) (exp (- number))))) + +(defun complex-acos (number) + (* -2 (mult-by-i (log (+ (sqrt (/ (1+ number) 2)) + (mult-by-i (sqrt (/ (- 1 number) 2)))))))) + +(defun complex-acosh (number) + (* 2 (log (+ (sqrt (/ (1+ number) 2)) (sqrt (/ (1- number) 2)))))) + +(defun complex-asin (number) + (- (mult-by-i (log (+ (mult-by-i number) (sqrt (- 1 (* number number)))))))) + +(defun complex-asinh (number) + (log (+ number (sqrt (1+ (* number number)))))) + +(defun complex-atan (y) + (let ((im (imagpart y)) + (re (realpart y))) + (/ (- (log (complex (- 1 im) re)) + (log (complex (+ 1 im) (- re)))) + (complex 0 2)))) + +(defun complex-tan (number) + (let* ((num (sin number)) + (denom (cos number))) + (if (zerop denom) (error "~S undefined tangent." number) + (/ num denom)))) +) + +#-old-specfun +(progn +;;;; +;;;; This is a set of routines that implement many elementary +;;;; transcendental functions as specified by ANSI Common Lisp. The +;;;; implementation is based on Kahan's paper. +;;;; +;;;; I believe I have accurately implemented the routines and are +;;;; correct, but you may want to check for your self. +;;;; +;;;; These functions are written for CMU Lisp and take advantage of +;;;; some of the features available there. It may be possible, +;;;; however, to port this to other Lisps. +;;;; +;;;; Some functions are significantly more accurate than the original +;;;; definitions in CMU Lisp. In fact, some functions in CMU Lisp +;;;; give the wrong answer like (acos #c(-2.0 0.0)), where the true +;;;; answer is pi + i*log(2-sqrt(3)). +;;;; +;;;; All of the implemented functions will take any number for an +;;;; input, but the result will always be a either a complex +;;;; single-float or a complex double-float. +;;;; +;;;; General functions +;;;; complex-sqrt +;;;; complex-log +;;;; complex-atanh +;;;; complex-tanh +;;;; complex-acos +;;;; complex-acosh +;;;; complex-asin +;;;; complex-asinh +;;;; complex-atan +;;;; complex-tan +;;;; +;;;; Utility functions: +;;;; scalb logb +;;;; +;;;; Internal functions: +;;;; square coerce-to-complex-type cssqs complex-log-scaled +;;;; suppress-divide-by-zero +;;;; +;;;; +;;;; Please send any bug reports, comments, or improvements to Raymond +;;;; Toy at toy@rtp.ericsson.se. +;;;; +;;;; References +;;;; +;;;; Kahan, W. "Branch Cuts for Complex Elementary Functions, or Much +;;;; Ado About Nothing's Sign Bit" in Iserles and Powell (eds.) "The +;;;; State of the Art in Numerical Analysis", pp. 165-211, Clarendon +;;;; Press, 1987 +;;;; +(declaim (inline square)) +(declaim (ftype (function (double-float) (double-float 0d0)) square)) +(defun square (x) + (declare (double-float x) + (values (double-float 0d0))) + (* x x)) + +;; If you have these functions in libm, perhaps they should be used +;; instead of these Lisp versions. These versions are probably good +;; enough, especially since they are portable. + +(defun scalb (x n) + "Compute 2^N * X without compute 2^N first (use properties of the +underlying floating-point format" + (declare (type double-float x) + (integer n)) + (scale-float x n)) + +(defun logb (x) + "Compute an integer N such that 1 <= |2^N * x| < 2. +For the special cases, the following values are used: + + x logb + NaN NaN + +/- infinity +infinity + 0 -infinity +" + (declare (type double-float x)) + (cond ((float-trapping-nan-p x) + x) + ((float-infinity-p x) + #.ext:double-float-positive-infinity) + ((zerop x) + ;; The answer is negative infinity, but we are supposed to + ;; signal divide-by-zero. + ;; (error 'division-by-zero :operation 'logb :operands (list x)) + (/ -1.0d0 x) + ) + (t + (multiple-value-bind (signif expon sign) + (decode-float x) + (declare (ignore signif sign)) + ;; decode-float is almost right, except that the exponent + ;; is off by one + (1- expon))))) + +;; This function is used to create a complex number of the appropriate +;; type. + +(declaim (inline coerce-to-complex-type)) +(defun coerce-to-complex-type (x y z) + "Create complex number with real part X and imaginary part Y such that +it has the same type as Z. If Z has type (complex rational), the X +and Y are coerced to single-float." + (declare (double-float x y) + (number z)) + (if (subtypep (type-of (realpart z)) 'double-float) + (complex x y) + ;; Convert anything that's not a double-float to a single-float. + (complex (float x 1.0) + (float y 1.0)))) + +(defun cssqs (z) + ;; Compute |x+i*y|^2/2^k carefully. The result is r + i*k, where k + ;; is an integer. + + ;; Save all FP flags + (let* ((fp-modes (get-floating-point-modes)) + (x (float (realpart z) 1d0)) + (y (float (imagpart z) 1d0)) + (k 0) + (rho 0d0) + ) + (declare (double-float x y) + (type (double-float 0d0) rho) + (fixnum k)) + (unwind-protect + (progn + ;; Would this be better handled using an exception handler + ;; to catch the overflow or underflow signal? For now, we + ;; turn all traps off and look at the accrued exceptions to + ;; see if any signal would have been raised. + + (set-floating-point-modes :traps nil :accrued-exceptions nil) + + (setf rho (+ (square x) (square y))) + (cond ((and (or (float-trapping-nan-p rho) + (float-infinity-p rho)) + (or (float-infinity-p (abs x)) + (float-infinity-p (abs y)))) + (setf rho #.ext:double-float-positive-infinity)) + ((let* ((exceptions (getf (get-floating-point-modes) + :accrued-exceptions)) + (threshold #.(/ least-positive-double-float + double-float-epsilon))) + ;; overflow raised or (underflow raised and rho < + ;; lambda/eps) + (or (member :overflow exceptions) + (and (member :underflow exceptions) + (< rho threshold)))) + (setf k (logb (max (abs x) (abs y)))) + (setf rho (+ (square (scalb x (- k))) + (square (scalb y (- k))))))) + (values rho k)) + ;; restore over/underflow flags + (apply #'set-floating-point-modes fp-modes)))) + +(defun complex-sqrt (z) + "Principle square root of Z + +Z may be any number, but the result is always a complex." + (declare (number z)) + (multiple-value-bind (rho k) + (cssqs z) + (declare (type (double-float 0d0) rho) + (fixnum k)) + (let ((x (float (realpart z) 1.0d0)) + (y (float (imagpart z) 1.0d0)) + (eta 0d0) + (nu 0d0)) + (declare (double-float x y eta nu)) + + (if (not (float-trapping-nan-p x)) + (setf rho (+ (scalb (abs x) (- k)) (sqrt rho)))) + + (cond ((oddp k) + (setf k (ash k -1))) + (t + (setf k (1- (ash k -1))) + (setf rho (+ rho rho)))) + + (setf rho (scalb (sqrt rho) k)) + + (setf eta rho) + (setf nu y) + + (when (/= rho 0d0) + (when (not (float-infinity-p (abs nu))) + (setf nu (/ (/ nu rho) 2d0))) + (when (< x 0d0) + (setf eta (abs nu)) + (setf nu (float-sign y rho)))) + (coerce-to-complex-type eta nu z)))) + +(defun complex-log-scaled (z j) + "Compute log(2^j*z). + +This is for use with J /= 0 only when |z| is huge." + (declare (number z) + (fixnum j)) + ;; The constants t0, t1, t2 should be evaluated to machine + ;; precision. In addition, Kahan says the accuracy of log1p + ;; influences the choices of these constants but doesn't say how to + ;; choose them. We'll just assume his choices matches our + ;; implementation of log1p. + (let ((t0 #.(/ 1 (sqrt 2.0d0))) + (t1 1.2d0) + (t2 3d0) + (ln2 #.(log 2d0)) + (x (float (realpart z) 1.0d0)) + (y (float (imagpart z) 1.0d0))) + (multiple-value-bind (rho k) + (cssqs z) + (declare (type (double-float 0d0) rho) + (fixnum k)) + (let ((beta (max (abs x) (abs y))) + (theta (min (abs x) (abs y)))) + (declare (type (double-float 0d0) beta theta)) + (if (and (zerop k) + (< t0 beta) + (or (<= beta t1) + (< rho t2))) + (setf rho (/ (%log1p (+ (* (- beta 1.0d0) + (+ beta 1.0d0)) + (* theta theta))) + 2d0)) + (setf rho (+ (/ (log rho) 2d0) + (* (+ k j) ln2)))) + (setf theta (atan y x)) + (coerce-to-complex-type rho theta z))))) + +(defun complex-log (z) + "Log of Z = log |Z| + i * arg Z + +Z may be any number, but the result is always a complex." + (declare (number z)) + (complex-log-scaled z 0)) + +;; Let us note the following "strange" behavior. atanh 1.0d0 is +;; +infinity, but the following code returns approx 176 + i*pi/4. The +;; reason for the imaginary part is caused by the fact that arg i*y is +;; never 0 since we have positive and negative zeroes. + +(defun complex-atanh (z) + "Compute atanh z = (log(1+z) - log(1-z))/2" + (declare (number z)) + (let* (;; Constants + (theta #.(/ (sqrt most-positive-double-float) 4.0d0)) + (rho #.(/ 4.0d0 (sqrt most-positive-double-float))) + (half-pi #.(/ pi 2.0d0)) + (rp (float (realpart z) 1.0d0)) + (beta (float-sign rp 1.0d0)) + (x (* beta rp)) + (y (* beta (- (float (imagpart z) 1.0d0)))) + (eta 0.0d0) + (nu 0.0d0)) + (declare (double-float theta rho half-pi rp beta y eta nu) + (type (double-float 0d0) x)) + (cond ((or (> x theta) + (> (abs y) theta)) + ;; To avoid overflow... + (setf eta (float-sign y half-pi)) + ;; nu is real part of 1/(x + iy). This is x/(x^2+y^2), + ;; which can cause overflow. Arrange this computation so + ;; that it won't overflow. + (setf nu (let* ((x-bigger (> x (abs y))) + (r (if x-bigger (/ y x) (/ x y))) + (d (+ 1.0d0 (* r r)))) + (declare (double-float r d)) + (if x-bigger + (/ (/ x) d) + (/ (/ r y) d))))) + ((= x 1.0d0) + ;; Should this be changed so that if y is zero, eta is set + ;; to +infinity instead of approx 176? In any case + ;; tanh(176) is 1.0d0 within working precision. + (let ((t1 (+ 4d0 (square y))) + (t2 (+ (abs y) rho))) + (declare (type (double-float 0d0) t1 t2)) + #+nil + (setf eta (log (/ (sqrt (sqrt t1))) + (sqrt t2))) + (setf eta (* 0.5d0 (log (the (double-float 0.0d0) + (/ (sqrt t1) t2))))) + (setf nu (* 0.5d0 + (float-sign y + (+ half-pi (atan (* 0.5d0 t2)))))))) + (t + (let ((t1 (+ (abs y) rho))) + (declare (double-float t1)) + ;; Normal case using log1p(x) = log(1 + x) + (setf eta (* 0.25d0 + (%log1p (/ (* 4.0d0 x) + (+ (square (- 1.0d0 x)) + (square t1)))))) + (setf nu (* 0.5d0 + (atan (* 2.0d0 y) + (- (* (- 1.0d0 x) + (+ 1.0d0 x)) + (square t1)))))))) + (coerce-to-complex-type (* beta eta) + (- (* beta nu)) + z))) + +(defun complex-tanh (z) + "Compute tanh z = sinh z / cosh z" + (declare (number z)) + (let ((x (float (realpart z) 1.0d0)) + (y (float (imagpart z) 1.0d0))) + (declare (double-float x y)) + (cond ((> (abs x) + #-linux #.(/ (%asinh most-positive-double-float) 4d0) + ;; This is more accurate under linux. + #+linux #.(/ (+ (%log 2.0d0) + (%log most-positive-double-float)) 4d0)) + (complex (float-sign x) + (float-sign y 0.0d0))) + (t + (let* ((tv (tan y)) + (beta (+ 1.0d0 (* tv tv))) + (s (sinh x)) + (rho (sqrt (+ 1.0d0 (* s s))))) + (declare (double-float tv s) + (type (double-float 0.0d0) beta rho)) + (if (float-infinity-p (abs tv)) + (coerce-to-complex-type (/ rho s) + (/ tv) + z) + (let ((den (+ 1.0d0 (* beta s s)))) + (coerce-to-complex-type (/ (* beta rho s) + den) + (/ tv den) + z)))))))) + +;; Kahan says we should only compute the parts needed. Thus, the +;; realpart's below should only compute the real part, not the whole +;; complex expression. Doing this can be important because we may get +;; spurious signals that occur in the part that we are not using. +;; +;; However, we take a pragmatic approach and just use the whole +;; expression. + +;; This macro suppresses any divide-by-zero errors in the body. After +;; execution of the body, the floating point modes are returned as +;; they were before entry. + +(defmacro suppress-divide-by-zero (&body body) + (let ((fp-modes (gensym))) + `(let ((,fp-modes (get-floating-point-modes))) + (unwind-protect + (progn + ;; Remove the divide-by-zero trap but leave everything + ;; else undisturbed. + (set-floating-point-modes + :traps (remove :divide-by-zero (getf ,fp-modes :traps))) + ,@body) + (apply #'set-floating-point-modes ,fp-modes))))) + +;; NOTE: The formula given by Kahan is somewhat ambiguous in whether +;; it's the conjugate of the square root or the square root of the +;; conjugate. This needs to be checked. + +;; I checked. It doesn't matter because (conjugate (sqrt z)) is the +;; same as (sqrt (conjugate z)) for all z. This follows because +;; +;; (conjugate (sqrt z)) = exp(0.5*log |z|)*exp(-0.5*j*arg z). +;; +;; (sqrt (conjugate z)) = exp(0.5*log|z|)*exp(0.5*j*arg conj z) +;; +;;.and these two expressions are equal if and only if arg conj z = +;;-arg z, which is clearly true for all z. + +(defun complex-acos (z) + "Compute acos z = pi/2 - asin z + +Z may be any number, but the result is always a complex." + (declare (number z)) + (let ((sqrt-1+z (complex-sqrt (+ 1 z))) + (sqrt-1-z (complex-sqrt (- 1 z)))) + (suppress-divide-by-zero + (complex (* 2 (atan (/ (realpart sqrt-1-z) + (realpart sqrt-1+z)))) + (asinh (imagpart (* (conjugate sqrt-1+z) + sqrt-1-z))))))) + +(defun complex-acosh (z) + "Compute acosh z = 2 * log(sqrt((z+1)/2) + sqrt((z-1)/2)) + +Z may be any number, but the result is always a complex." + (declare (number z)) + (let ((sqrt-z-1 (complex-sqrt (- z 1))) + (sqrt-z+1 (complex-sqrt (+ z 1)))) + (suppress-divide-by-zero + (complex (asinh (realpart (* (conjugate sqrt-z-1) + sqrt-z+1))) + (* 2 (atan (/ (imagpart sqrt-z-1) + (realpart sqrt-z+1)))))))) + + +(defun complex-asin (z) + "Compute asin z = asinh(i*z)/i + +Z may be any number, but the result is always a complex." + (declare (number z)) + (let ((sqrt-1-z (complex-sqrt (- 1 z))) + (sqrt-1+z (complex-sqrt (+ 1 z)))) + (suppress-divide-by-zero + (complex (atan (/ (realpart z) + (realpart (* sqrt-1-z sqrt-1+z)))) + (asinh (imagpart (* (conjugate sqrt-1-z) + sqrt-1+z))))))) + +(defun complex-asinh (z) + "Compute asinh z = log(z + sqrt(1 + z*z)) + +Z may be any number, but the result is always a complex." + (declare (number z)) + ;; asinh z = -i * asin (i*z) + (let* ((iz (complex (- (imagpart z)) (realpart z))) + (result (complex-asin iz))) + (complex (imagpart result) + (- (realpart result))))) + +(defun complex-atan (z) + "Compute atan z = atanh (i*z) / i + +Z may be any number, but the result is always a complex." + (declare (number z)) + ;; atan z = -i * atanh (i*z) + (let* ((iz (complex (- (imagpart z)) (realpart z))) + (result (complex-atanh iz))) + (complex (imagpart result) + (- (realpart result))))) + +(defun complex-tan (z) + "Compute tan z = -i * tanh(i * z) + +Z may be any number, but the result is always a complex." + (declare (number z)) + ;; tan z = -i * tanh(i*z) + (let* ((iz (complex (- (imagpart z)) (realpart z))) + (result (complex-tanh iz))) + (complex (imagpart result) + (- (realpart result))))) +) diff --git a/code/linux-os.lisp b/code/linux-os.lisp new file mode 100644 index 000000000..ffa7ec6e6 --- /dev/null +++ b/code/linux-os.lisp @@ -0,0 +1,75 @@ +;;; -*- Package: SYSTEM -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/linux-os.lisp,v 1.1 1997/01/18 14:30:35 ram Exp $") +;;; +;;; ********************************************************************** +;;; +;;; OS interface functions for CMU CL under Mach. +;;; +;;; Written and maintained mostly by Skef Wholey and Rob MacLachlan. +;;; Scott Fahlman, Dan Aronson, and Steve Handerson did stuff here, too. +;;; +;;; Hacked into Linux-os.lisp /Werkowski + +(in-package "SYSTEM") +(use-package "EXTENSIONS") +(export '(get-system-info get-page-size os-init)) +#+nil +(export '(*task-self* *task-data* *task-notify*)) + +(pushnew :linux *features*) + +(setq *software-type* "Linux") + +(defun software-version () + "Returns a string describing version of the supporting software." + #+nil + (string-trim '(#\newline) + (with-output-to-string (stream) + (run-program "/usr/cs/etc/version" ; Site dependent??? + nil :output stream))) + "n/a") + + +;;; OS-Init initializes our operating-system interface. It sets the values +;;; of the global port variables to what they should be and calls the functions +;;; that set up the argument blocks for the server interfaces. + +(defvar *task-self*) + +(defun os-init () ; don't know what to do here + #+nil + (setf *task-self* (mach:mach-task_self)) + #+sparc ;; Can't use #x20000000 thru #xDFFFFFFF, but mach tries to let us. + (system:allocate-system-memory-at (system:int-sap #x20000000) #xc0000000)) + + +;;; GET-SYSTEM-INFO -- Interface +;;; +;;; Return system time, user time and number of page faults. +;;; +(defun get-system-info () + (multiple-value-bind (err? utime stime maxrss ixrss idrss + isrss minflt majflt) + (unix:unix-getrusage unix:rusage_self) + (declare (ignore maxrss ixrss idrss isrss minflt)) + (unless err? + (error "Unix system call getrusage failed: ~A." + (unix:get-unix-error-msg utime))) + + (values utime stime majflt))) + + +;;; GET-PAGE-SIZE -- Interface +;;; +;;; Return the system page size. +;;; +(defun get-page-size () + ;; probably should call getpagesize() + 4096) + diff --git a/code/lispinit.lisp b/code/lispinit.lisp index 5c63d19cc..c5280576e 100644 --- a/code/lispinit.lisp +++ b/code/lispinit.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/lispinit.lisp,v 1.48 1996/05/07 20:19:07 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/lispinit.lisp,v 1.49 1997/01/18 14:30:42 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -263,6 +263,20 @@ `(progn (%primitive print ,(symbol-name name)) (,name)))) +#+nil +(defun hexstr(thing) + (let ((addr (kernel:get-lisp-obj-address thing)) + (str (make-string 10))) + (setf (char str 0) #\0 + (char str 1) #\x) + (dotimes (i 8) + (let* ((nib (ldb (byte 4 0) addr)) + (chr (char "0123456789abcdef" nib))) + (declare (type (unsigned-byte 4) nib) + (base-char chr)) + (setf (char str (- 9 i)) chr + addr (ash addr -4)))) + str)) (defun %initial-function () "Gives the world a shove and hopes it spins." @@ -292,7 +306,7 @@ (let ((funs (nreverse *lisp-initialization-functions*))) (%primitive print "Calling top-level forms.") - (dolist (fun funs) + (dolist (fun funs) #+nil (%primitive print (hexstr fun)) (typecase fun (function (funcall fun)) @@ -335,7 +349,8 @@ (print-and-call package-init) (print-and-call kernel::signal-init) (setf (alien:extern-alien "internal_errors_enabled" alien:boolean) t) - (set-floating-point-modes :traps '(:overflow :underflow :invalid + + (set-floating-point-modes :traps '(:overflow #-x86 :underflow :invalid :divide-by-zero)) ;; This is necessary because some of the initial top level forms might ;; have changed the compliation policy in strange ways. @@ -388,6 +403,11 @@ ;;;; Initialization functions: +;;; Print seems to not like x86 NPX denormal floats like +;;; least-negative-single-float, so the :underflow exceptions +;;; is disabled by default. Joe User can explicitly enable them +;;; if desired. + (defun reinit () (without-interrupts (without-gcing @@ -397,7 +417,7 @@ (gc-init) (setf (alien:extern-alien "internal_errors_enabled" alien:boolean) t) (set-floating-point-modes :traps - '(:overflow :underflow :invalid + '(:overflow #-x86 :underflow :invalid :divide-by-zero))))) @@ -436,6 +456,7 @@ (defconstant bytes-per-scrub-unit 2048) +#-x86 (defun scrub-control-stack () "Zero the unused portion of the control stack so that old objects are not kept alive because of uninitialized stack variables." @@ -469,6 +490,45 @@ (scrub (int-sap (- csp initial-offset)) (* (floor initial-offset vm:word-bytes) vm:word-bytes) 0)))) + +#+x86 ;; Stack grows downwards +(defun scrub-control-stack () + "Zero the unused portion of the control stack so that old objects are not + kept alive because of uninitialized stack variables." + (declare (optimize (speed 3) (safety 0)) + (values (unsigned-byte 20))) + (labels + ((scrub (ptr offset count) + (declare (type system-area-pointer ptr) + (type (unsigned-byte 16) offset) + (type (unsigned-byte 20) count) + (values (unsigned-byte 20))) + (let ((loc (int-sap (- (sap-int ptr) (+ offset vm:word-bytes))))) + (cond ((= offset bytes-per-scrub-unit) + (look (int-sap (- (sap-int ptr) bytes-per-scrub-unit)) + 0 count)) + (t ;; need to fix bug in %set-stack-ref + (setf (sap-ref-32 loc 0) 0) + (scrub ptr (+ offset vm:word-bytes) count))))) + (look (ptr offset count) + (declare (type system-area-pointer ptr) + (type (unsigned-byte 16) offset) + (type (unsigned-byte 20) count) + (values (unsigned-byte 20))) + (let ((loc (int-sap (- (sap-int ptr) offset)))) + (cond ((= offset bytes-per-scrub-unit) + count) + ((zerop (stack-ref loc 0)) + (look ptr (+ offset vm:word-bytes) count)) + (t + (scrub ptr offset (+ count vm:word-bytes))))))) + (let* ((csp (sap-int (c::control-stack-pointer-sap))) + (initial-offset (logand csp (1- bytes-per-scrub-unit)))) + (declare (type (unsigned-byte 32) csp)) + (scrub (int-sap (+ csp initial-offset)) + (* (floor initial-offset vm:word-bytes) vm:word-bytes) + 0)))) + diff --git a/code/load.lisp b/code/load.lisp index c2c3e7395..080687012 100644 --- a/code/load.lisp +++ b/code/load.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/load.lisp,v 1.58 1994/11/04 06:02:31 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/load.lisp,v 1.59 1997/01/18 14:30:39 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -594,11 +594,17 @@ ;;; (defun try-default-types (pathname types) (dolist (type types (values nil nil)) - (let* ((pn (make-pathname :type type :defaults pathname)) + ;; toy@rtp.ericsson.se: add diddle-case so that this can handle + ;; both unix-namestrings and logical pathname namestrings. The + ;; case handling seems to be the opposite between these two + ;; styles. + (let* ((pn (make-pathname + :type (maybe-diddle-case + type (logical-pathname-p (pathname pathname))) + :defaults pathname)) (tn (probe-file pn))) (when tn (return (values pn tn)))))) - ;;; INTERNAL-LOAD-DEFAULT-TYPE -- Internal ;;; ;;; Handle the case of INTERNAL-LOAD where the file does not exist. @@ -1009,6 +1015,7 @@ ;;; Load-Code loads a code object. NItems objects are popped off the stack for ;;; the boxed storage section, then Size bytes of code are read in. ;;; +#-x86 (defun load-code (box-num code-length) (declare (fixnum box-num code-length)) (with-fop-stack t @@ -1027,6 +1034,101 @@ #+gengc (* code-length vm:word-bytes))) code))) + +;;; Moving native code during a GC or purify is not trivial on the x86 +;;; port, so there are a few options for code placement. +;;; +;;; Byte-compiled code objects can always be moved so can be place in +;;; the dynamics heap. This is enabled with +;;; *load-byte-compiled-code-to-dynamic-space*. +;;; +;;; Native code top level forms only have a short life so can be +;;; safely loaded into the dynamic heap (without fixups) so long as +;;; the GC is not active. This could be handy during a world load to +;;; save core space without the need to enable the support for moving +;;; x86 native code. Enable with *load-x86-tlf-to-dynamic-space*. +;;; +;;; One strategy for allowing the loading of x86 native code into the +;;; dynamic heap requires that the addresses of fixups be saved for +;;; all these code objects. After a purify these fixups can be +;;; dropped. This is enabled with *enable-dynamic-space-code*. +;;; +;;; A little analysis of the header information is used to determine +;;; if a code object is byte compiled, or native code. +;;; +#+x86 +(eval-when (compile) + (let ((ht (c::backend-template-names c:*backend*))) + (unless (gethash 'c::allocate-dynamic-code-object ht) + (setf (gethash 'c::allocate-dynamic-code-object ht) + (gethash 'vm::allocate-dynamic-code-object ht))))) + +(defvar *load-byte-compiled-code-to-dynamic-space* t) +(defvar *load-x86-tlf-to-dynamic-space* nil) ; potentially dangerous. +(defvar *load-code-verbose* nil) +(defvar *enable-dynamic-space-code* nil) ; experimental + +#+x86 +(defun load-code (box-num code-length) + (declare (fixnum box-num code-length)) + (with-fop-stack t + (let ((stuff (list (pop-stack)))) + (dotimes (i box-num) + (declare (fixnum i)) + (push (pop-stack) stuff)) + (let* ((dbi (car (last stuff))) ; debug-info + (tto (first stuff)) ; trace-table-offset + (load-to-dynamic-space + (or *enable-dynamic-space-code* + ;; Definitely Byte compiled code? + (and *load-byte-compiled-code-to-dynamic-space* + (c::debug-info-p dbi) + (not (c::compiled-debug-info-p dbi))) + ;; Or a x86 top level form. + (and *load-x86-tlf-to-dynamic-space* + (c::compiled-debug-info-p dbi) + (string= (c::compiled-debug-info-name dbi) + "Top-Level Form")))) ) + + (setq stuff (nreverse stuff)) + + ;; Check that tto is always a list for byte-compiled + ;; code. Could be used an alternate check. + (when (and (typep tto 'list) + (not (and (c::debug-info-p dbi) + (not (c::compiled-debug-info-p dbi))))) + (format t "* tto list on non-bc code: ~s~% ~s ~s~%" + stuff dbi tto)) + + (when *load-code-verbose* + (format t "stuff: ~s~%" stuff) + (format t " : ~s ~s ~s ~s~%" + (c::compiled-debug-info-p dbi) + (c::debug-info-p dbi) + (c::compiled-debug-info-name dbi) + tto) + (if load-to-dynamic-space + (format t " Loading to the dynamic space~%") + (format t " Loading to the static space~%"))) + + (let ((code + (if load-to-dynamic-space + (%primitive + allocate-dynamic-code-object box-num code-length) + (%primitive allocate-code-object box-num code-length))) + (index (+ vm:code-trace-table-offset-slot box-num))) + (declare (type index index)) + (when *load-code-verbose* + (format t " obj addr=~x~%" + (kernel::get-lisp-obj-address code))) + (setf (%code-debug-info code) (pop stuff)) + (dotimes (i box-num) + (declare (fixnum i)) + (setf (code-header-ref code (decf index)) (pop stuff))) + (system:without-gcing + (read-n-bytes *fasl-file* (code-instructions code) 0 code-length)) + code))))) + (define-fop (fop-code 58 :nope) (load-code (read-arg 4) (read-arg 4))) diff --git a/code/macros.lisp b/code/macros.lisp index a7a915453..12365359f 100644 --- a/code/macros.lisp +++ b/code/macros.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.45 1994/10/31 04:11:27 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.46 1997/01/18 14:31:12 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1405,9 +1405,14 @@ "Binds the Var to an input stream that returns characters from String and executes the body. See manual for details." `(let ((,var - ,(if end - `(make-string-input-stream ,string ,(or start 0) ,end) - `(make-string-input-stream ,string ,(or start 0))))) + ,(cond ((null end) + `(make-string-input-stream ,string ,(or start 0))) + ((symbolp end) + `(if ,end + (make-string-input-stream ,string ,(or start 0) ,end) + (make-string-input-stream ,string ,(or start 0)))) + (t + `(make-string-input-stream ,string ,(or start 0) ,end))))) ,@decls (unwind-protect (progn ,@forms) diff --git a/code/misc.lisp b/code/misc.lisp index a718e78e9..7330c763b 100644 --- a/code/misc.lisp +++ b/code/misc.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/misc.lisp,v 1.22 1994/10/31 04:11:27 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/misc.lisp,v 1.23 1997/01/18 14:31:13 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -38,7 +38,7 @@ (variable (info variable documentation name)) (function (info function documentation name)) (structure - (when (eq (info type kind name) :structure) + (when (eq (info type kind name) :instance) (info type documentation name))) (type (info type documentation name)) @@ -51,7 +51,7 @@ (variable (setf (info variable documentation name) string)) (function (setf (info function documentation name) string)) (structure - (unless (eq (info type kind name) :structure) + (unless (eq (info type kind name) :instance) (error "~S is not the name of a structure type." name)) (setf (info type documentation name) string)) (type (setf (info type documentation name) string)) diff --git a/code/ntrace.lisp b/code/ntrace.lisp index dc41b88c4..815611aae 100644 --- a/code/ntrace.lisp +++ b/code/ntrace.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/ntrace.lisp,v 1.12 1994/10/31 04:11:27 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/ntrace.lisp,v 1.13 1997/01/18 14:30:50 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -31,7 +31,7 @@ "If the trace indentation exceeds this value, then indentation restarts at 0.") -(defvar *trace-encapsulate-default* :default +(defvar *trace-encapsulate-default* #-x86 :default #+x86 t "The default value for the :ENCAPSULATE option to trace.") diff --git a/code/numbers.lisp b/code/numbers.lisp index 09b496e94..a00f47177 100644 --- a/code/numbers.lisp +++ b/code/numbers.lisp @@ -5,11 +5,11 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/numbers.lisp,v 1.26 1995/02/17 18:04:08 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/numbers.lisp,v 1.27 1997/01/18 14:30:37 ram Exp $") ;;; ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/numbers.lisp,v 1.26 1995/02/17 18:04:08 ram Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/numbers.lisp,v 1.27 1997/01/18 14:30:37 ram Exp $ ;;; ;;; This file contains the definitions of most number functions. ;;; @@ -475,16 +475,28 @@ (let* ((rx (realpart x)) (ix (imagpart x)) (ry (realpart y)) - (iy (imagpart y)) - (dn (+ (* ry ry) (* iy iy)))) - (canonical-complex (/ (+ (* rx ry) (* ix iy)) dn) - (/ (- (* ix ry) (* rx iy)) dn)))) + (iy (imagpart y))) + (if (> (abs ry) (abs iy)) + (let* ((r (/ iy ry)) + (dn (* ry (+ 1 (* r r))))) + (canonical-complex (/ (+ rx (* ix r)) dn) + (/ (- ix (* rx r)) dn))) + (let* ((r (/ ry iy)) + (dn (* iy (+ 1 (* r r))))) + (canonical-complex (/ (+ (* rx r) ix) dn) + (/ (- (* ix r) rx) dn)))))) (((foreach integer ratio single-float double-float) complex) (let* ((ry (realpart y)) - (iy (imagpart y)) - (dn (+ (* ry ry) (* iy iy)))) - (canonical-complex (/ (* x ry) dn) - (/ (- (* x iy)) dn)))) + (iy (imagpart y))) + (if (> (abs ry) (abs iy)) + (let* ((r (/ iy ry)) + (dn (* ry (+ 1 (* r r))))) + (canonical-complex (/ x dn) + (/ (- (* x r)) dn))) + (let* ((r (/ ry iy)) + (dn (* iy (+ 1 (* r r))))) + (canonical-complex (/ (* x r) dn) + (/ (- x) dn)))))) ((complex (or rational float)) (canonical-complex (/ (realpart x) y) (/ (imagpart x) y))) diff --git a/code/pathname.lisp b/code/pathname.lisp index be71d4578..fa0f21db5 100644 --- a/code/pathname.lisp +++ b/code/pathname.lisp @@ -4,7 +4,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pathname.lisp,v 1.26 1996/05/07 13:14:51 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pathname.lisp,v 1.27 1997/01/18 14:30:44 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -532,19 +532,24 @@ (and default-host pathname-host (not (eq (host-customary-case default-host) (host-customary-case pathname-host)))))) - (%make-pathname (or pathname-host default-host) - (or (%pathname-device pathname) + (make-pathname :host (or pathname-host default-host) + :device + (or (%pathname-device pathname) (maybe-diddle-case (%pathname-device defaults) diddle-case)) + :directory (merge-directories (%pathname-directory pathname) (%pathname-directory defaults) diddle-case) + :name (or (%pathname-name pathname) (maybe-diddle-case (%pathname-name defaults) diddle-case)) + :type (or (%pathname-type pathname) (maybe-diddle-case (%pathname-type defaults) diddle-case)) + :version (or (%pathname-version pathname) default-version)))))) @@ -593,9 +598,9 @@ (version nil versionp) defaults (case :local)) - "Makes a new pathname from the component arguments. Note that host is a host- - structure." - (declare (type (or host component-tokens) host) + "Makes a new pathname from the component arguments. Note that host is +a host-structure or string." + (declare (type (or string host component-tokens) host) (type component-tokens device) (type (or list string pattern component-tokens) directory) (type (or string pattern component-tokens) name type) @@ -607,7 +612,10 @@ (default-host (if defaults (%pathname-host defaults) (pathname-host *default-pathname-defaults*))) - (host (or host default-host)) + ;; toy@rtp.ericsson.se: CLHS says make-pathname can take a + ;; string (as a logical-host) for the host part. We map that + ;; string into the corresponding logical host structure. + (host (or (gethash host *logical-hosts*) host default-host)) (diddle-args (and (eq (host-customary-case host) :lower) (eq case :common))) (diddle-defaults @@ -821,10 +829,11 @@ (%parse-namestring (coerce thing 'simple-string) host defaults start end junk-allowed)) (pathname - (let ((host (if host host (%pathname-host defaults)))) - (unless (eq host (%pathname-host thing)) + (let* ((host (if host host (%pathname-host defaults))) + (hosts-name (funcall (host-unparse-host host) host))) + (unless (eq hosts-name (%pathname-host thing)) (error "Hosts do not match: ~S and ~S." - host (%pathname-host thing)))) + hosts-name (%pathname-host thing)))) (values thing start)) (stream (let ((name (file-name thing))) @@ -1181,12 +1190,25 @@ (if (eq result :error) (error "~S doesn't match ~S" source from) result)))) + #+nil ;; pw- 1/3/97 This doesn't work. (%make-pathname (or to-host source-host) (frob %pathname-device) (frob %pathname-directory translate-directories) (frob %pathname-name) (frob %pathname-type) - (frob %pathname-version)))))))) + (frob %pathname-version)) + + (let ((host (or to-host source-host)) + (device (frob %pathname-device)) + (directory (frob %pathname-directory translate-directories)) + (name (frob %pathname-name)) + (type (frob %pathname-type)) + (version (frob %pathname-version))) + (if (logical-host-p host) + (%make-logical-pathname + host :unspecific directory name type version) + (%make-pathname + host device directory name type version))))))))) ;;;; Search lists. @@ -1750,9 +1772,10 @@ (with-open-file (in-str (make-pathname :defaults "library:" :name host :type "translations")) - (format *error-output* - ";; Loading pathname translations from ~A~%" - (namestring (truename in-str))) + (if *load-verbose* + (format *error-output* + ";; Loading pathname translations from ~A~%" + (namestring (truename in-str)))) (setf (logical-pathname-translations host) (read in-str))) t)) diff --git a/code/pred.lisp b/code/pred.lisp index dfc0446c6..d4f086f41 100644 --- a/code/pred.lisp +++ b/code/pred.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pred.lisp,v 1.34 1994/10/31 04:11:27 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pred.lisp,v 1.35 1997/01/18 14:30:34 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -193,10 +193,10 @@ (rational (rationalp num)) (float (ecase (numeric-type-format type) - (short-float (typep object 'short-float)) - (single-float (typep object 'single-float)) - (double-float (typep object 'double-float)) - (long-float (typep object 'long-float)) + (short-float (typep num 'short-float)) + (single-float (typep num 'single-float)) + (double-float (typep num 'double-float)) + (long-float (typep num 'long-float)) ((nil) (floatp num)))) ((nil) t))) (flet ((bound-test (val) diff --git a/code/save.lisp b/code/save.lisp index 8c5c2f5e7..778f22b0d 100644 --- a/code/save.lisp +++ b/code/save.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/save.lisp,v 1.28 1996/05/08 02:02:37 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/save.lisp,v 1.29 1997/01/18 14:30:54 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -91,8 +91,9 @@ (setf (search-list "library:") (or (parse-unix-search-list :cmucllib) - '(#+mach "/usr/misc/.cmucl/lib/" - #-mach "/usr/local/lib/cmucl/lib/")))) + '(#+mach "/usr/misc/.cmucl/lib/" + #+linux "/usr/lib/cmucl/" + #-(or mach linux) "/usr/local/lib/cmucl/lib/")))) diff --git a/code/seq.lisp b/code/seq.lisp index 613b24eaf..57aca78ef 100644 --- a/code/seq.lisp +++ b/code/seq.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/seq.lisp,v 1.21 1996/07/12 18:05:35 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/seq.lisp,v 1.22 1997/01/18 14:30:36 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -115,7 +115,7 @@ (list (do ((count index (1- count)) (seq sequence)) - ((= count 0) (rplaca seq newval) sequence) + ((= count 0) (rplaca seq newval) newval) (declare (fixnum count)) (if (atom (cdr seq)) (error "~S: index too large." index) @@ -811,12 +811,23 @@ (%double-float object)) ((csubtypep type (specifier-type 'float)) (%single-float object)) + ((csubtypep type (specifier-type '(complex single-float))) + (complex (%single-float (realpart object)) + (%single-float (imagpart object)))) + ((csubtypep type (specifier-type '(complex double-float))) + (complex (%double-float (realpart object)) + (%double-float (imagpart object)))) ((csubtypep type (specifier-type 'complex)) (complex object)) (t (error "~S can't be converted to type ~S." object output-type-spec))))) - (unless (typep res output-type-spec) + ;; If RES has the wrong type, that means that rule of + ;; canonical representation for complex rationals was invoked. + ;; According to the Hyperspec, (coerce 7/2 'complex) returns + ;; 7/2. Thus, if the object was a rational, there is no error + ;; here. + (unless (or (typep res output-type-spec) (rationalp object)) (error "~S can't be converted to type ~S." object output-type-spec)) res)) diff --git a/code/signal.lisp b/code/signal.lisp index c4b25d29d..5afbd40d0 100644 --- a/code/signal.lisp +++ b/code/signal.lisp @@ -5,11 +5,11 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/signal.lisp,v 1.24 1994/10/31 04:11:27 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/signal.lisp,v 1.25 1997/01/18 14:30:33 ram Exp $") ;;; ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/signal.lisp,v 1.24 1994/10/31 04:11:27 ram Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/signal.lisp,v 1.25 1997/01/18 14:30:33 ram Exp $ ;;; ;;; Code for handling UNIX signals. ;;; @@ -51,7 +51,9 @@ (defvar *unix-signals* nil "A list of unix signal structures.") + (eval-when (compile eval) +;(setf *unix-signals* nil) ; pve: sigh or else... (defmacro def-unix-signal (name number description) (let ((symbol (intern (symbol-name name)))) `(progn @@ -92,34 +94,42 @@ ;;; Known signals ;;; (def-unix-signal :CHECK 0 "Check") + (def-unix-signal :SIGHUP 1 "Hangup") (def-unix-signal :SIGINT 2 "Interrupt") (def-unix-signal :SIGQUIT 3 "Quit") (def-unix-signal :SIGILL 4 "Illegal instruction") (def-unix-signal :SIGTRAP 5 "Trace trap") (def-unix-signal :SIGIOT 6 "Iot instruction") +#-linux (def-unix-signal :SIGEMT 7 "Emt instruction") (def-unix-signal :SIGFPE 8 "Floating point exception") (def-unix-signal :SIGKILL 9 "Kill") -(def-unix-signal :SIGBUS 10 "Bus error") +(def-unix-signal :SIGBUS #-linux 10 #+linux 7 "Bus error") (def-unix-signal :SIGSEGV 11 "Segmentation violation") +#-linux (def-unix-signal :SIGSYS 12 "Bad argument to system call") (def-unix-signal :SIGPIPE 13 "Write on a pipe with no one to read it") (def-unix-signal :SIGALRM 14 "Alarm clock") (def-unix-signal :SIGTERM 15 "Software termination signal") -(def-unix-signal :SIGURG #+svr4 21 #-(or hpux svr4) 16 #+hpux 29 - "Urgent condition present on socket") -(def-unix-signal :SIGSTOP #-(or hpux svr4) 17 #+hpux 24 #+svr4 23 "Stop") -(def-unix-signal :SIGTSTP #-(or hpux svr4) 18 #+hpux 25 #+svr4 24 - "Stop signal generated from keyboard") -(def-unix-signal :SIGCONT #-(or hpux svr4) 19 #+hpux 26 #+svr4 25 - "Continue after stop") -(def-unix-signal :SIGCHLD #-hpux 20 #+hpux 18 "Child status has changed") +#+linux +(def-unix-signal :SIGSTKFLT 16 "Stack fault on coprocessor") +(def-unix-signal :SIGURG #+svr4 21 #-(or hpux svr4 linux) 16 #+hpux 29 + #+linux 23 "Urgent condition present on socket") +(def-unix-signal :SIGSTOP #-(or hpux svr4 linux) 17 #+hpux 24 #+svr4 23 + #+linux 19 "Stop") +(def-unix-signal :SIGTSTP #-(or hpux svr4 linux) 18 #+hpux 25 #+svr4 24 + #+linux 20 "Stop signal generated from keyboard") +(def-unix-signal :SIGCONT #-(or hpux svr4 linux) 19 #+hpux 26 #+svr4 25 + #+linux 18 "Continue after stop") +(def-unix-signal :SIGCHLD #-(or linux hpux) 20 + #+hpux 18 #+linux 17 "Child status has changed") (def-unix-signal :SIGTTIN #-(or hpux svr4) 21 #+hpux 27 #+svr4 26 "Background read attempted from control terminal") (def-unix-signal :SIGTTOU #-(or hpux svr4) 22 #+hpux 28 #+svr4 27 "Background write attempted to control terminal") -(def-unix-signal :SIGIO #-(or hpux irix) 23 #+(or hpux irix) 22 +(def-unix-signal :SIGIO #-(or hpux irix linux) 23 #+(or hpux irix) 22 + #+linux 29 "I/O is possible on a descriptor") #-hpux (def-unix-signal :SIGXCPU #-svr4 24 #+svr4 30 "Cpu time limit exceeded") @@ -127,14 +137,14 @@ (def-unix-signal :SIGXFSZ #-svr4 25 #+svr4 31 "File size limit exceeded") (def-unix-signal :SIGVTALRM #-(or hpux svr4) 26 #+hpux 20 #+svr4 28 "Virtual time alarm") -(def-unix-signal :SIGPROF #-(or hpux svr4) 27 #+hpux 21 #+svr4 29 - "Profiling timer alarm") +(def-unix-signal :SIGPROF #-(or hpux svr4 linux) 27 #+hpux 21 #+svr4 29 + #+linux 30 "Profiling timer alarm") (def-unix-signal :SIGWINCH #-(or hpux svr4) 28 #+hpux 23 #+svr4 20 "Window size change") -(def-unix-signal :SIGUSR1 #-(or hpux svr4) 30 #+(or hpux svr4) 16 - "User defined signal 1") -(def-unix-signal :SIGUSR2 #-(or hpux svr4) 31 #+(or hpux svr4) 17 - "User defined signal 2") +(def-unix-signal :SIGUSR1 #-(or hpux svr4 linux) 30 #+(or hpux svr4) 16 + #+linux 10 "User defined signal 1") +(def-unix-signal :SIGUSR2 #-(or hpux svr4 linux) 31 #+(or hpux svr4) 17 + #+linux 12 "User defined signal 2") ;;; ;;; These are Mach Specific #+mach @@ -146,6 +156,7 @@ #+svr4 (def-unix-signal :SIGWAITING 32 "Process's lwps are blocked") + ;;; SIGMASK -- Public ;;; (defmacro sigmask (&rest signals) @@ -256,9 +267,11 @@ (define-signal-handler sigill-handler "Illegal Instruction") (define-signal-handler sigtrap-handler "Breakpoint/Trap") (define-signal-handler sigiot-handler "SIGIOT") +#-linux (define-signal-handler sigemt-handler "SIGEMT") (define-signal-handler sigbus-handler "Bus Error") (define-signal-handler sigsegv-handler "Segmentation Violation") +#-linux (define-signal-handler sigsys-handler "Bad Argument to a System Call") (define-signal-handler sigpipe-handler "SIGPIPE") (define-signal-handler sigalrm-handler "SIGALRM") @@ -275,10 +288,12 @@ (enable-interrupt :sigill #'sigill-handler) (enable-interrupt :sigtrap #'sigtrap-handler) (enable-interrupt :sigiot #'sigiot-handler) + #-linux (enable-interrupt :sigemt #'sigemt-handler) (enable-interrupt :sigfpe #'vm:sigfpe-handler) (enable-interrupt :sigbus #'sigbus-handler) (enable-interrupt :sigsegv #'sigsegv-handler) + #-linux (enable-interrupt :sigsys #'sigsys-handler) (enable-interrupt :sigpipe #'sigpipe-handler) (enable-interrupt :sigalrm #'sigalrm-handler) diff --git a/code/unix.lisp b/code/unix.lisp index cf44aef12..270515215 100644 --- a/code/unix.lisp +++ b/code/unix.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/unix.lisp,v 1.42 1996/07/25 20:46:19 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/unix.lisp,v 1.43 1997/01/18 14:30:40 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -24,7 +24,7 @@ t-stopc t-eofc t-brkc ltchars t-suspc t-dsuspc t-rprntc t-flushc t-werasc t-lnextc sgttyb sg-ispeed sg-ospeed sg-erase sg-kill sg-flags winsize ws-row ws-col ws-xpixel ws-ypixel - direct d-off d-ino d-reclen #-svr4 d-namlen d-name + direct d-off d-ino d-reclen #-(or linux svr4) d-namlen d-name stat st-dev st-mode st-nlink st-uid st-gid st-rdev st-size st-atime st-mtime st-ctime st-blksize st-blocks s-ifmt s-ifdir s-ifchr s-ifblk s-ifreg s-iflnk s-ifsock @@ -45,32 +45,32 @@ unix-fcntl f-dupfd f-getfd f-setfd f-getfl f-setfl f-getown f-setown fndelay fappend fasync fcreat ftrunc fexcl unix-link unix-lseek l_set l_incr l_xtnd unix-mkdir unix-open o_rdonly o_wronly o_rdwr - #+svr4 o_ndelay + #+(or svr4 freebsd linux) o_ndelay o_append o_creat o_trunc o_excl unix-pipe unix-read unix-readlink unix-rename unix-rmdir unix-fast-select fd-setsize fd-set fd-clr fd-isset fd-zero unix-select unix-sync unix-fsync unix-truncate unix-ftruncate unix-symlink unix-unlink unix-write unix-ioctl tcsetpgrp tcgetpgrp tty-process-group terminal-speeds tty-raw tty-crmod tty-echo tty-lcase - #-(or hpux svr4) tty-cbreak #-(or hpux svr4) tty-tandem - #+(or hpux svr4) termios #+(or hpux svr4) c-lflag - #+(or hpux svr4) c-iflag #+(or hpux svr4) c-oflag - #+(or hpux svr4) tty-icrnl #+(or hpux svr4) tty-ocrnl - #+(or hpux svr4) vdsusp #+(or hpux svr4) veof - #+(or hpux svr4) vintr #+(or hpux svr4) vquit #+(or hpux svr4) vstart - #+(or hpux svr4) vstop #+(or hpux svr4) vsusp - #+(or hpux svr4) c-cflag - #+(or hpux svr4) c-cc #+(or hpux svr4) tty-icanon - #+(or hpux svr4) vmin #+(or hpux svr4) vtime - #+(or hpux svr4) tty-ixon - #+(or hpux svr4) tcsaflush #+(or hpux svr4) - unix-tcgetattr #+(or hpux svr4) unix-tcsetattr + #-(or hpux svr4 freebsd) tty-cbreak #-(or hpux svr4) tty-tandem + #+(or hpux svr4 linux freebsd) termios #+(or hpux svr4 freebsd) c-lflag + #+(or hpux svr4 freebsd) c-iflag #+(or hpux svr4 freebsd) c-oflag + #+(or hpux svr4 freebsd) tty-icrnl #+(or hpux svr4 freebsd) tty-ocrnl + #+(or hpux svr4 freebsd) vdsusp #+(or hpux svr4 freebsd) veof + #+(or hpux svr4 freebsd) vintr #+(or hpux svr4 freebsd) vquit #+(or hpux svr4 freebsd) vstart + #+(or hpux svr4 freebsd) vstop #+(or hpux svr4 freebsd) vsusp + #+(or hpux svr4 freebsd) c-cflag + #+(or hpux svr4 freebsd) c-cc #+(or hpux svr4 freebsd) tty-icanon + #+(or hpux svr4 freebsd) vmin #+(or hpux svr4 freebsd) vtime + #+(or hpux svr4 freebsd) tty-ixon + #+(or hpux svr4 freebsd) tcsaflush #+(or hpux svr4 linux freebsd) + unix-tcgetattr #+(or hpux svr4 linux freebsd) unix-tcsetattr TIOCGETP TIOCSETP TIOCFLUSH TIOCSETC TIOCGETC TIOCSLTC TIOCGLTC TIOCNOTTY TIOCSPGRP TIOCGPGRP TIOCGWINSZ TIOCSWINSZ TIOCSIGSEND KBDCGET KBDCSET KBDCRESET KBDCRST KBDCSSTD KBDSGET KBDGCLICK - KBDSCLICK FIONREAD #+hpux siocspgrp + KBDSCLICK FIONREAD #+(or hpux freebsd) siocspgrp unix-exit unix-stat unix-lstat unix-fstat unix-getrusage unix-fast-getrusage rusage_self rusage_children unix-gettimeofday @@ -88,30 +88,48 @@ ;;;; Common machine independent structures. +#+bsd +(def-alien-type quad-t (array unsigned-long 2)) + ;;; From sys/types.h -(def-alien-type daddr-t #-alpha long #+alpha int) +(def-alien-type daddr-t #-(or linux alpha) long #+(or linux alpha) int) (def-alien-type caddr-t (* char)) (def-alien-type ino-t #-alpha unsigned-long #+alpha unsigned-int) (def-alien-type swblk-t long) -(def-alien-type size-t #-alpha long #+alpha unsigned-long) -(def-alien-type time-t #-alpha unsigned-long #+alpha unsigned-int) -(def-alien-type dev-t #-(or alpha svr4) short #+alpha int #+svr4 unsigned-long) +(def-alien-type size-t #-(or linux alpha) long #+linux unsigned-int + #+alpha unsigned-long) +(def-alien-type time-t #-(or linux alpha) unsigned-long #+linux long + #+alpha unsigned-int) + +(def-alien-type dev-t #-(or alpha svr4 bsd linux) short #+linux unsigned-short + #+alpha int #+(and (not linux) (or bsd svr4)) unsigned-long) +#-FreeBSD (def-alien-type off-t #-alpha long #+alpha unsigned-long) +#+FreeBSD +(def-alien-type off-t quad-t) +#-FreeBSD (def-alien-type uid-t #-(or alpha svr4) unsigned-short #+alpha unsigned-int #+svr4 long) +#+FreeBSD +(def-alien-type uid-t unsigned-long) +#-FreeBSD (def-alien-type gid-t #-(or alpha svr4) unsigned-short #+alpha unsigned-int #+svr4 long) +#+FreeBSD +(def-alien-type gid-t unsigned-long) (def-alien-type mode-t #-(or alpha svr4) unsigned-short #+alpha unsigned-int #+svr4 unsigned-long) (def-alien-type nlink-t #-svr4 unsigned-short #+svr4 unsigned-long) -(defconstant FD-SETSIZE #-(or hpux alpha) 256 #+hpux 2048 #+alpha 4096) +(defconstant FD-SETSIZE #-(or hpux alpha linux) 256 #+hpux 2048 #+alpha 4096 #+linux 1024) +;; not checked for linux... (def-alien-type nil (struct fd-set (fds-bits (array #-alpha unsigned-long #+alpha int #.(/ fd-setsize 32))))) +;; not checked for linux... (defmacro fd-set (offset fd-set) (let ((word (gensym)) (bit (gensym))) @@ -120,6 +138,7 @@ (logior (truly-the (unsigned-byte 32) (ash 1 ,bit)) (deref (slot ,fd-set 'fds-bits) ,word)))))) +;; not checked for linux... (defmacro fd-clr (offset fd-set) (let ((word (gensym)) (bit (gensym))) @@ -129,12 +148,14 @@ (32bit-logical-not (truly-the (unsigned-byte 32) (ash 1 ,bit)))))))) +;; not checked for linux... (defmacro fd-isset (offset fd-set) (let ((word (gensym)) (bit (gensym))) `(multiple-value-bind (,word ,bit) (floor ,offset 32) (logbitp ,bit (deref (slot ,fd-set 'fds-bits) ,word))))) +;; not checked for linux... (defmacro fd-zero (fd-set) `(progn ,@(loop for index upfrom 0 below (/ fd-setsize 32) @@ -144,54 +165,80 @@ (def-alien-type nil (struct timeval - (tv-sec time-t) ; seconds - (tv-usec time-t))) ; and microseconds + (tv-sec #-linux time-t #+linux int) ; seconds + (tv-usec #-linux time-t #+linux int))) ; and microseconds (def-alien-type nil (struct timezone (tz-minuteswest int) ; minutes west of Greenwich (tz-dsttime ; type of dst correction - (enum nil :none :usa :aust :wet :met :eet :can)))) + #-linux (enum nil :none :usa :aust :wet :met :eet :can) + #+linux int))) (def-alien-type nil (struct itimerval (it-interval (struct timeval)) ; timer interval (it-value (struct timeval)))) ; current value -#+svr4 +#+(or linux svr4) ; High-res time. Actually posix definition under svr4 name. (def-alien-type nil (struct timestruc-t (tv-sec time-t) (tv-nsec long))) -;;; From ioctl.h +#+(or linux FreeBSD) +(def-alien-type nil + (struct timespec-t + (ts-sec long) + (ts-nsec long))) +;;; From ioctl.h (def-alien-type nil (struct tchars (t-intrc char) ; interrupt (t-quitc char) ; quit + #+linux (t-eofc char) (t-startc char) ; start output (t-stopc char) ; stop output - (t-eofc char) ; end-of-file + #-linux (t-eofc char) ; end-of-file (t-brkc char))) ; input delimiter (like nl) +;; not found (semi) linux (def-alien-type nil (struct ltchars + #+linux (t-werasc char) ; word erase (t-suspc char) ; stop process signal (t-dsuspc char) ; delayed stop process signal (t-rprntc char) ; reprint line (t-flushc char) ; flush output (toggles) - (t-werasc char) ; word erase + #-linux (t-werasc char) ; word erase (t-lnextc char))) ; literal next character + + +#+(or svr4 hpux linux) +(def-alien-type nil + (struct termios + (c-iflag unsigned-int) + (c-oflag unsigned-int) + (c-cflag unsigned-int) + (c-lflag unsigned-int) + #+(or linux hpux) + (c-reserved #-linux unsigned-int #+linux unsigned-char) + (c-cc (array unsigned-char #+hpux 16 #+(or linux solaris) 19 #+irix 23)))) + (def-alien-type nil (struct sgttyb + #+linux (sg-flags #+mach short #-mach int) ; mode flags (sg-ispeed char) ; input speed. (sg-ospeed char) ; output speed (sg-erase char) ; erase character - (sg-kill char) ; kill character - (sg-flags #+mach short #-mach int))) ; mode flags + #-linux (sg-kill char) ; kill character + #-linux (sg-flags #+mach short #-mach int) ; mode flags + #+linux (sg-kill char) + #+linux (t (struct termios)) + #+linux (check int))) (def-alien-type nil (struct winsize @@ -203,32 +250,44 @@ ;;; From sys/termio.h -#+(or svr4 hpux) +#+(or svr4 hpux freebsd linux) (def-alien-type nil (struct termios (c-iflag unsigned-int) (c-oflag unsigned-int) (c-cflag unsigned-int) (c-lflag unsigned-int) - #+hpux - (c-reserved unsigned-int) - (c-cc (array unsigned-char #+hpux 16 #+solaris 19 #+irix 23)))) + #+(or linux hpux) + (c-reserved #-linux unsigned-int #+linux unsigned-char) + (c-cc (array unsigned-char #+hpux 16 #+(or linux solaris) 19 #+irix 23 #+freebsd 20)) + ;; FreeBSD also has c-ispeed and c-ospeed? + )) ;;; From sys/dir.h - +#-bsd (def-alien-type nil (struct direct #+(and sunos (not svr4)) (d-off long) ; offset of next disk directory entry (d-ino ino-t); inode number of entry - #+svr4 (d-off long) + #+(or linux svr4) (d-off long) (d-reclen unsigned-short) ; length of this record - #-svr4 + #-(or linux svr4) (d-namlen unsigned-short) ; length of string in d-name (d-name (array char 256)))) ; name must be no longer than this +#+bsd +(def-alien-type nil + (struct direct + (d-fileno unsigned-long) + (d-reclen unsigned-short) + (d-type unsigned-char) + (d-namlen unsigned-char) ; length of string in d-name + (d-name (array char 256)))) ; name must be no longer than this + ;;; From sys/stat.h +;; oh boy, in linux-> 2 stat(s)!! -#-svr4 +#-(or svr4 freebsd linux) (def-alien-type nil (struct stat (st-dev dev-t) @@ -249,34 +308,68 @@ (st-blocks #-alpha long #+alpha int) (st-spare4 (array long 2)))) -#+svr4 +#+FreeBSD (def-alien-type nil (struct stat (st-dev dev-t) - (st-pad1 (array long 3)) (st-ino ino-t) - (st-mode unsigned-long) - (st-nlink short) + (st-mode mode-t) + (st-nlink nlink-t) (st-uid uid-t) (st-gid gid-t) (st-rdev dev-t) - (st-pad2 (array long 2)) + (st-atime (struct timespec-t)) + (st-mtime (struct timespec-t)) + (st-ctime (struct timespec-t)) + (st-size unsigned-long) ; really quad + (st-sizeh unsigned-long) ; + (st-blocks unsigned-long) ; really quad + (st-blocksh unsigned-long) + (st-blksize unsigned-long) + (st-flags unsigned-long) + (st-gen unsigned-long) + (st-lspare long) + (st-qspare (array long 4)))) ; 2 quads + +#+(or linux svr4) +(def-alien-type nil + (struct stat + (st-dev dev-t) + (st-pad1 #-linux (array long 3) #+linux unsigned-short) + (st-ino ino-t) + (st-mode #-linux unsigned-long #+linux unsigned-short) + (st-nlink #-linux short #+linux unsigned-short) + (st-uid #-linux uid-t #+linux unsigned-short) + (st-gid #-linux gid-t #+linux unsigned-short) + (st-rdev dev-t) + (st-pad2 #-linux (array long 2) #+linux unsigned-short) (st-size off-t) - (st-pad3 long) - (st-atime (struct timestruc-t)) - (st-mtime (struct timestruc-t)) - (st-ctime (struct timestruc-t)) - (st-blksize long) - (st-blocks long) - (st-fstype (array char 16)) - (st-pad4 (array long 8)))) - -(defconstant s-ifmt #o0170000) -(defconstant s-ifdir #o0040000) -(defconstant s-ifchr #o0020000) -(defconstant s-ifblk #o0060000) -(defconstant s-ifreg #o0100000) -(defconstant s-iflnk #o0120000) + #-linux (st-pad3 long) + #+linux (st-blksize unsigned-long) + #+linux (st-blocks unsigned-long) + #-linux (st-atime (struct timestruc-t)) + #+linux (st-atime unsigned-long) + #+linux (unused-1 unsigned-long) + #-linux (st-mtime (struct timestruc-t)) + #+linux (st-mtime unsigned-long) + #+linux (unused-2 unsigned-long) + #-linux (st-ctime (struct timestruc-t)) + #+linux (st-ctime unsigned-long) + #+linux (unused-3 unsigned-long) + #+linux (unused-4 unsigned-long) + #+linux (unused-5 unsigned-long) + #-linux(st-blksize long) + #-linux (st-blocks long) + #-linux (st-fstype (array char 16)) + #-linux (st-pad4 (array long 8)))) + +(defconstant s-ifmt #o0170000) +(defconstant s-ifdir #o0040000) +(defconstant s-ifchr #o0020000) +#+linux (defconstant s-ififo #x0010000) +(defconstant s-ifblk #o0060000) +(defconstant s-ifreg #o0100000) +(defconstant s-iflnk #o0120000) (defconstant s-ifsock #o0140000) (defconstant s-isuid #o0004000) (defconstant s-isgid #o0002000) @@ -308,8 +401,8 @@ (def-alien-type nil (struct rlimit - (rlim-cur #-alpha int #+alpha unsigned-int) ; current (soft) limit - (rlim-max #-alpha int #+alpha unsigned-int))); maximum value for rlim-cur + (rlim-cur #-(or linux alpha) int #+linux long #+alpha unsigned-int) ; current (soft) limit + (rlim-max #-(or linux alpha) int #+linux long #+alpha unsigned-int))); maximum value for rlim-cur @@ -341,7 +434,7 @@ ;;; From <errno.h> ;;; (def-unix-error ESUCCESS 0 "Successful") -(def-unix-error EPERM 1 "Not owner") +(def-unix-error EPERM 1 #-linux "Not owner" #+linux "Operation not permitted") (def-unix-error ENOENT 2 "No such file or directory") (def-unix-error ESRCH 3 "No such process") (def-unix-error EINTR 4 "Interrupted system call") @@ -351,12 +444,12 @@ (def-unix-error ENOEXEC 8 "Exec format error") (def-unix-error EBADF 9 "Bad file number") (def-unix-error ECHILD 10 "No children") -(def-unix-error EAGAIN 11 "No more processes") -(def-unix-error ENOMEM 12 "Not enough core") +(def-unix-error EAGAIN 11 #-linux "No more processes" #+linux "Try again") +(def-unix-error ENOMEM 12 #-linux "Not enough core" #+linux "Out of memory") (def-unix-error EACCES 13 "Permission denied") (def-unix-error EFAULT 14 "Bad address") (def-unix-error ENOTBLK 15 "Block device required") -(def-unix-error EBUSY 16 "Mount device busy") +(def-unix-error EBUSY 16 #-linux "Mount device busy" #+linux "Device or resource busy") (def-unix-error EEXIST 17 "File exists") (def-unix-error EXDEV 18 "Cross-device link") (def-unix-error ENODEV 19 "No such device") @@ -375,10 +468,10 @@ (def-unix-error EPIPE 32 "Broken pipe") ;;; ;;; Math -(def-unix-error EDOM 33 "Argument too large") -(def-unix-error ERANGE 34 "Result too large") +(def-unix-error EDOM 33 #-linux "Argument too large" #+linux "Math argument out of domain") +(def-unix-error ERANGE 34 #-linux "Result too large" #+linux "Math result not representable") ;;; -#-svr4 +#-(or linux svr4) (progn ;;; non-blocking and interrupt i/o (def-unix-error EWOULDBLOCK 35 "Operation would block") @@ -523,6 +616,98 @@ (def-unix-error EINPROGRESS 150 "Operation now in progress") (def-unix-error ESTALE 151 "Stale NFS file handle") ) +#+linux +(progn +(def-unix-error EDEADLK 35 "Resource deadlock would occur") +(def-unix-error ENAMETOOLONG 36 "File name too long") +(def-unix-error ENOLCK 37 "No record locks available") +(def-unix-error ENOSYS 38 "Function not implemented") +(def-unix-error ENOTEMPTY 39 "Directory not empty") +(def-unix-error ELOOP 40 "Too many symbolic links encountered") +(def-unix-error EWOULDBLOCK 11 "Operation would block") +(def-unix-error ENOMSG 42 "No message of desired type") +(def-unix-error EIDRM 43 "Identifier removed") +(def-unix-error ECHRNG 44 "Channel number out of range") +(def-unix-error EL2NSYNC 45 "Level 2 not synchronized") +(def-unix-error EL3HLT 46 "Level 3 halted") +(def-unix-error EL3RST 47 "Level 3 reset") +(def-unix-error ELNRNG 48 "Link number out of range") +(def-unix-error EUNATCH 49 "Protocol driver not attached") +(def-unix-error ENOCSI 50 "No CSI structure available") +(def-unix-error EL2HLT 51 "Level 2 halted") +(def-unix-error EBADE 52 "Invalid exchange") +(def-unix-error EBADR 53 "Invalid request descriptor") +(def-unix-error EXFULL 54 "Exchange full") +(def-unix-error ENOANO 55 "No anode") +(def-unix-error EBADRQC 56 "Invalid request code") +(def-unix-error EBADSLT 57 "Invalid slot") +(def-unix-error EDEADLOCK EDEADLK "File locking deadlock error") +(def-unix-error EBFONT 59 "Bad font file format") +(def-unix-error ENOSTR 60 "Device not a stream") +(def-unix-error ENODATA 61 "No data available") +(def-unix-error ETIME 62 "Timer expired") +(def-unix-error ENOSR 63 "Out of streams resources") +(def-unix-error ENONET 64 "Machine is not on the network") +(def-unix-error ENOPKG 65 "Package not installed") +(def-unix-error EREMOTE 66 "Object is remote") +(def-unix-error ENOLINK 67 "Link has been severed") +(def-unix-error EADV 68 "Advertise error") +(def-unix-error ESRMNT 69 "Srmount error") +(def-unix-error ECOMM 70 "Communication error on send") +(def-unix-error EPROTO 71 "Protocol error") +(def-unix-error EMULTIHOP 72 "Multihop attempted") +(def-unix-error EDOTDOT 73 "RFS specific error") +(def-unix-error EBADMSG 74 "Not a data message") +(def-unix-error EOVERFLOW 75 "Value too large for defined data type") +(def-unix-error ENOTUNIQ 76 "Name not unique on network") +(def-unix-error EBADFD 77 "File descriptor in bad state") +(def-unix-error EREMCHG 78 "Remote address changed") +(def-unix-error ELIBACC 79 "Can not access a needed shared library") +(def-unix-error ELIBBAD 80 "Accessing a corrupted shared library") +(def-unix-error ELIBSCN 81 ".lib section in a.out corrupted") +(def-unix-error ELIBMAX 82 "Attempting to link in too many shared libraries") +(def-unix-error ELIBEXEC 83 "Cannot exec a shared library directly") +(def-unix-error EILSEQ 84 "Illegal byte sequence") +(def-unix-error ERESTART 85 "Interrupted system call should be restarted ") +(def-unix-error ESTRPIPE 86 "Streams pipe error") +(def-unix-error EUSERS 87 "Too many users") +(def-unix-error ENOTSOCK 88 "Socket operation on non-socket") +(def-unix-error EDESTADDRREQ 89 "Destination address required") +(def-unix-error EMSGSIZE 90 "Message too long") +(def-unix-error EPROTOTYPE 91 "Protocol wrong type for socket") +(def-unix-error ENOPROTOOPT 92 "Protocol not available") +(def-unix-error EPROTONOSUPPORT 93 "Protocol not supported") +(def-unix-error ESOCKTNOSUPPORT 94 "Socket type not supported") +(def-unix-error EOPNOTSUPP 95 "Operation not supported on transport endpoint") +(def-unix-error EPFNOSUPPORT 96 "Protocol family not supported") +(def-unix-error EAFNOSUPPORT 97 "Address family not supported by protocol") +(def-unix-error EADDRINUSE 98 "Address already in use") +(def-unix-error EADDRNOTAVAIL 99 "Cannot assign requested address") +(def-unix-error ENETDOWN 100 "Network is down") +(def-unix-error ENETUNREACH 101 "Network is unreachable") +(def-unix-error ENETRESET 102 "Network dropped connection because of reset") +(def-unix-error ECONNABORTED 103 "Software caused connection abort") +(def-unix-error ECONNRESET 104 "Connection reset by peer") +(def-unix-error ENOBUFS 105 "No buffer space available") +(def-unix-error EISCONN 106 "Transport endpoint is already connected") +(def-unix-error ENOTCONN 107 "Transport endpoint is not connected") +(def-unix-error ESHUTDOWN 108 "Cannot send after transport endpoint shutdown") +(def-unix-error ETOOMANYREFS 109 "Too many references: cannot splice") +(def-unix-error ETIMEDOUT 110 "Connection timed out") +(def-unix-error ECONNREFUSED 111 "Connection refused") +(def-unix-error EHOSTDOWN 112 "Host is down") +(def-unix-error EHOSTUNREACH 113 "No route to host") +(def-unix-error EALREADY 114 "Operation already in progress") +(def-unix-error EINPROGRESS 115 "Operation now in progress") +(def-unix-error ESTALE 116 "Stale NFS file handle") +(def-unix-error EUCLEAN 117 "Structure needs cleaning") +(def-unix-error ENOTNAM 118 "Not a XENIX named type file") +(def-unix-error ENAVAIL 119 "No XENIX semaphores available") +(def-unix-error EISNAM 120 "Is a named type file") +(def-unix-error EREMOTEIO 121 "Remote I/O error") +(def-unix-error EDQUOT 122 "Quota exceeded") +) + ;;; ;;; And now for something completely different ... (emit-unix-errors) @@ -763,27 +948,35 @@ (defconstant F-SETFD 2 "Set file desc. flags") (defconstant F-GETFL 3 "Get file flags") (defconstant F-SETFL 4 "Set file flags") -#-svr4 +#-(or linux svr4) (defconstant F-GETOWN 5 "Get owner") #+svr4 (defconstant F-GETOWN 23 "Get owner") -#-svr4 +#+linux +(defconstant F-GETLK 5 "Get lock") +#-(or linux svr4) (defconstant F-SETOWN 6 "Set owner") #+svr4 (defconstant F-SETOWN 24 "Set owner") - +#+linux +(defconstant F-SETLK 6 "Set lock") +#+linux +(defconstant F-SETLKW 7 "Set lock, wait for release") +#+linux +(defconstant F-SETOWN 8 "Set owner") ;;; File flags for F-GETFL and F-SETFL: (defconstant FNDELAY #-osf1 #o0004 #+osf1 #o100000 "Non-blocking reads") -(defconstant FAPPEND #o0010 "Append on each write") -(defconstant FASYNC #-svr4 #o0100 #+svr4 #o10000 +(defconstant FAPPEND #-linux #o0010 #+linux #o2000 "Append on each write") +(defconstant FASYNC #-(or linux svr4) #o0100 #+svr4 #o10000 #+linux #o20000 "Signal pgrp when data ready") -(defconstant FCREAT #-(or hpux svr4) #o1000 #+(or hpux svr4) #o0400 - "Create if nonexistant") -(defconstant FTRUNC #-(or hpux svr4) #o2000 #+(or hpux svr4) #o1000 +;; doesn't exist in Linux ;-( +#-linux (defconstant FCREAT #-(or hpux svr4) #o1000 #+(or hpux svr4) #o0400 + "Create if nonexistant") +#-linux (defconstant FTRUNC #-(or hpux svr4) #o2000 #+(or hpux svr4) #o1000 "Truncate to zero length") -(defconstant FEXCL #-(or hpux svr4) #o4000 #+(or hpux svr4) #o2000 +#-linux (defconstant FEXCL #-(or hpux svr4) #o4000 #+(or hpux svr4) #o2000 "Error if already created") (defun unix-fcntl (fd cmd arg) @@ -837,7 +1030,11 @@ (declare (type unix-fd fd) (type (unsigned-byte 32) offset) (type (integer 0 2) whence)) - (int-syscall ("lseek" int off-t int) fd offset whence)) + #-(and x86 freebsd) (int-syscall ("lseek" int off-t int) fd offset whence) + ;; Need a 64-bit return value type for this. TBD. For now, + ;; don't use this with any 2G+ partitions. + #+(and freebsd x86) (int-syscall ("lseek" int unsigned-long unsigned-long int) + fd offset 0 whence )) ;;; Unix-mkdir accepts a name and a mode and attempts to create the ;;; corresponding directory with mode mode. @@ -856,14 +1053,20 @@ (defconstant o_rdonly 0 "Read-only flag.") (defconstant o_wronly 1 "Write-only flag.") (defconstant o_rdwr 2 "Read-write flag.") -(defconstant o_append #o10 "Append flag.") -#+svr4 (defconstant o_ndelay 4 "Non-blocking I/O") -#+(or hpux svr4) +#+(or linux svr4 freebsd) +(defconstant o_ndelay #-linux 4 #+linux #o4000 "Non-blocking I/O") +(defconstant o_append #-linux #o10 #+linux #o2000 "Append flag.") +#+(or hpux svr4 linux) (progn - (defconstant o_creat #o400 "Create if nonexistant flag.") + (defconstant o_creat #-linux #o400 #+linux #o100 "Create if nonexistant flag.") (defconstant o_trunc #o1000 "Truncate flag.") - (defconstant o_excl #o2000 "Error if already exists.")) -#-(or hpux svr4) + (defconstant o_excl #-linux #o2000 #+linux #o200 "Error if already exists.")) +#+linux +(progn + (defconstant o_noctty #o400 "Don't become controlling terminal") + (defconstant o_sync #o10000 "Synchronous writes (on ext2)")) + +#-(or hpux svr4 linux) (progn (defconstant o_creat #o1000 "Create if nonexistant flag.") (defconstant o_trunc #o2000 "Truncate flag.") @@ -1126,18 +1329,19 @@ (defconstant terminal-speeds - '#(nil 50 75 110 nil 150 200 300 600 1200 1800 2400 4800 9600 nil nil)) + '#(0 50 75 110 134 150 200 300 600 1200 1800 2400 4800 9600 nil nil + 57600 115200)) -(defconstant tty-raw #o40) -(defconstant tty-crmod #o20) -(defconstant tty-echo #o10) -(defconstant tty-lcase #o4) -#-hpux -(defconstant tty-cbreak #o2) +(defconstant tty-raw #-linux #o40 #+linux 1) +(defconstant tty-crmod #-linux #o20 #+linux 4) +(defconstant tty-echo #o10) ;; 8 +(defconstant tty-lcase #-linux #o4 #+linux 2) #-hpux +(defconstant tty-cbreak #-linux #o2 #+linux 64) +#-(or linux hpux) (defconstant tty-tandem #o1) -#+(or hpux svr4) +#+(or hpux svr4 linux) (progn (defconstant tty-icanon #o2) (defconstant tty-icrnl #o400) @@ -1147,6 +1351,16 @@ (defconstant vintr 0) (defconstant vquit 1)) +#+freebsd +(progn + (defconstant tty-icanon #x100) + (defconstant tty-icrnl #x100) + (defconstant tty-ocrnl #x2) + (defconstant tty-ixon #x200) + (defconstant veof 0) + (defconstant vintr 8) + (defconstant vquit 9)) + #+hpux (progn (defconstant vdsusp 21) @@ -1157,26 +1371,38 @@ (defconstant vtime 12) (defconstant tcsaflush 2)) -#+svr4 +#+(or linux svr4) (progn - (defconstant vdsusp 11) + #-linux (defconstant vdsusp 11) (defconstant vstart 8) (defconstant vstop 9) (defconstant vsusp 10) - (defconstant vmin 4) + (defconstant vmin #-linux 4 #+linux 6) (defconstant vtime 5) - (defconstant tcsaflush #x5410)) + (defconstant tcsaflush #-linux #x5410 #+linux 2)) + +#+freebsd +(progn + (defconstant vdsusp 11) + (defconstant vstart 12) + (defconstant vstop 13) + (defconstant vsusp 10) + (defconstant vmin 16) + (defconstant vtime 17) + (defconstant tcsaflush #x2)) (eval-when (compile load eval) -(defconstant iocparm-mask #x7f) -(defconstant ioc_void #x20000000) -(defconstant ioc_out #x40000000) -(defconstant ioc_in #x80000000) -(defconstant ioc_inout (logior ioc_in ioc_out)) +#-(or svr4 linux) +(progn + (defconstant iocparm-mask #x7f) ; Freebsd: #x1fff ? + (defconstant ioc_void #x20000000) + (defconstant ioc_out #x40000000) + (defconstant ioc_in #x80000000) + (defconstant ioc_inout (logior ioc_in ioc_out))) -#-svr4 +#-(or linux svr4) (defmacro define-ioctl-command (name dev cmd arg &optional (parm-type :void)) (let* ((ptype (ecase parm-type (:void ioc_void) @@ -1193,7 +1419,7 @@ `(eval-when (eval load compile) (defconstant ,name ,code)))) -#+svr4 +#+(or linux svr4) (defmacro define-ioctl-command (name dev cmd arg &optional (parm-type :void)) (declare (ignore dev arg parm-type)) `(eval-when (eval load compile) @@ -1203,21 +1429,21 @@ ;;; TTY ioctl commands. -(define-ioctl-command TIOCGETP #\t 8 (struct sgttyb) :out) -(define-ioctl-command TIOCSETP #\t 9 (struct sgttyb) :in) -(define-ioctl-command TIOCFLUSH #\t 16 int :in) -(define-ioctl-command TIOCSETC #\t 17 (struct tchars) :in) -(define-ioctl-command TIOCGETC #\t 18 (struct tchars) :out) +(define-ioctl-command TIOCGETP #\t #-linux 8 #+linux #x5481 (struct sgttyb) :out) +(define-ioctl-command TIOCSETP #\t #-linux 9 #+linux #x5482 (struct sgttyb) :in) +(define-ioctl-command TIOCFLUSH #\t #-linux 16 #+linux #x5489 int :in) +(define-ioctl-command TIOCSETC #\t #-linux 17 #+linux #x5484 (struct tchars) :in) +(define-ioctl-command TIOCGETC #\t #-linux 18 #+linux #x5483 (struct tchars) :out) (define-ioctl-command TIOCGWINSZ #\t #-hpux 104 #+hpux 107 (struct winsize) :out) (define-ioctl-command TIOCSWINSZ #\t #-hpux 103 #+hpux 106 (struct winsize) :in) -(define-ioctl-command TIOCNOTTY #\t 113 nil :void) +(define-ioctl-command TIOCNOTTY #\t #-linux 113 #+linux #x5422 nil :void) #-hpux (progn - (define-ioctl-command TIOCSLTC #\t 117 (struct ltchars) :in) - (define-ioctl-command TIOCGLTC #\t 116 (struct ltchars) :out) + (define-ioctl-command TIOCSLTC #\t #-linux 117 #+linux #x5484 (struct ltchars) :in) + (define-ioctl-command TIOCGLTC #\t #-linux 116 #+linux #x5485 (struct ltchars) :out) (define-ioctl-command TIOCSPGRP #\t #-svr4 118 #+svr4 21 int :in) (define-ioctl-command TIOCGPGRP #\t #-svr4 119 #+svr4 20 int :out)) #+hpux @@ -1229,7 +1455,7 @@ (define-ioctl-command TIOCSIGSEND #\t 93 nil)) ;;; File ioctl commands. -(define-ioctl-command FIONREAD #\f 127 int :out) +(define-ioctl-command FIONREAD #\f #-linux 127 #+linux #x541B int :out) (defun unix-ioctl (fd cmd arg) @@ -1240,13 +1466,13 @@ (type (unsigned-byte 32) cmd)) (void-syscall ("ioctl" int unsigned-int (* char)) fd cmd arg)) -#+(or svr4 hpux) +#+(or svr4 hpux freebsd linux) (defun unix-tcgetattr (fd termios) "Get terminal attributes." (declare (type unix-fd fd)) (void-syscall ("tcgetattr" int (* (struct termios))) fd termios)) -#+(or svr4 hpux) +#+(or svr4 hpux freebsd linux) (defun unix-tcsetattr (fd opt termios) "Set terminal attributes." (declare (type unix-fd fd)) @@ -1312,10 +1538,13 @@ ;;; Socket options. -#+hpux +#+(or hpux freebsd) (define-ioctl-command SIOCSPGRP #\s 8 int :in) -#+hpux +#+linux +(define-ioctl-command SIOCSPGRP #\s #x8904 int :in) + +#+(or hpux freebsd linux) (defun siocspgrp (fd pgrp) "Set the socket process-group for the unix file-descriptor FD to PGRP." (alien:with-alien ((alien-pgrp c-call:int pgrp)) @@ -1344,12 +1573,15 @@ (slot ,buf 'st-gid) (slot ,buf 'st-rdev) (slot ,buf 'st-size) - #-svr4 (slot ,buf 'st-atime) - #+svr4 (slot (slot ,buf 'st-atime) 'tv-sec) - #-svr4 (slot ,buf 'st-mtime) - #+svr4 (slot (slot ,buf 'st-mtime) 'tv-sec) - #-svr4 (slot ,buf 'st-ctime) - #+svr4 (slot (slot ,buf 'st-ctime) 'tv-sec) + #-(or svr4 FreeBSD) (slot ,buf 'st-atime) + #+svr4 (slot (slot ,buf 'st-atime) 'tv-sec) + #+FreeBSD (slot (slot ,buf 'st-atime) 'ts-sec) + #-(or svr4 FreeBSD)(slot ,buf 'st-mtime) + #+svr4 (slot (slot ,buf 'st-mtime) 'tv-sec) + #+FreeBSD(slot (slot ,buf 'st-mtime) 'ts-sec) + #-(or svr4 FreeBSD) (slot ,buf 'st-ctime) + #+svr4 (slot (slot ,buf 'st-ctime) 'tv-sec) + #+FreeBSD(slot (slot ,buf 'st-ctime) 'ts-sec) (slot ,buf 'st-blksize) (slot ,buf 'st-blocks))) @@ -1413,7 +1645,7 @@ child processes (rusage_children). NIL and an error number is returned if the call fails." (with-alien ((usage (struct rusage))) - (syscall* ("getrusage" int (* (struct rusage))) + (syscall ("getrusage" int (* (struct rusage))) (values t (+ (* (slot (slot usage 'ru-utime) 'tv-sec) 1000000) (slot (slot usage 'ru-utime) 'tv-usec)) @@ -1437,7 +1669,7 @@ ;; Requires call to tzset() in main. ;; Don't use this now: we -#+svr4 +#+(or linux svr4) (progn (def-alien-variable ("daylight" unix-daylight) int) (def-alien-variable ("timezone" unix-timezone) time-t) @@ -1618,6 +1850,7 @@ (t (values nil enotdir))))) +#-bsd (defun read-dir (dir) (declare (type directory dir)) (let ((daddr (alien-funcall (extern-alien "readdir" @@ -1628,7 +1861,7 @@ (if (zerop (sap-int daddr)) nil (with-alien ((direct (* (struct direct)) daddr)) - #-svr4 + #-(or linux svr4) (let ((nlen (slot direct 'd-namlen)) (ino (slot direct 'd-ino))) (declare (type (unsigned-byte 16) nlen)) @@ -1638,9 +1871,31 @@ string (* vm:vector-data-offset vm:word-bits) (* nlen vm:byte-bits)) (values string ino))) - #+svr4 + #+(or linux svr4) (values (cast (slot direct 'd-name) c-string) (slot direct 'd-ino)))))) +#+bsd +(defun read-dir (dir) + (declare (type directory dir)) + (let ((daddr (alien-funcall (extern-alien "readdir" + (function system-area-pointer + system-area-pointer)) + (directory-dir-struct dir)))) + (declare (type system-area-pointer daddr)) + (if (zerop (sap-int daddr)) + nil + (with-alien ((direct (* (struct direct)) daddr)) + (let ((nlen (slot direct 'd-namlen)) + (fino (slot direct 'd-fileno))) + (declare (type (unsigned-byte 8) nlen) + (type (unsigned-byte 32) fino)) + (let ((string (make-string nlen))) + (kernel:copy-from-system-area + (alien-sap (addr (slot direct 'd-name))) 0 + string (* vm:vector-data-offset vm:word-bits) + (* nlen vm:byte-bits)) + (values string fino))))))) + (defun close-dir (dir) (declare (type directory dir)) diff --git a/code/x86-vm.lisp b/code/x86-vm.lisp new file mode 100644 index 000000000..d32f7fb70 --- /dev/null +++ b/code/x86-vm.lisp @@ -0,0 +1,388 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: X86 -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +;(ext:file-comment +; "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/x86-vm.lisp,v 1.1 1997/01/18 14:30:50 ram Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the X86 specific runtime stuff. +;;; + +(in-package :x86) +(use-package "SYSTEM") +(use-package "ALIEN") +(use-package "C-CALL") +(use-package "UNIX") +(use-package :kernel) + +(export '(fixup-code-object internal-error-arguments + sigcontext-program-counter sigcontext-register + sigcontext-float-register sigcontext-floating-point-modes + extern-alien-name sanctify-for-execution + alternate-get-global-address)) + + +;;;; The sigcontext structure. +;;;; Add machine specific features to *features* + +(pushnew :x86 *features*) + + + +#+linux +(def-alien-type nil + (struct fpreg + (significand (array unsigned-short 4)) + (exponent unsigned-short))) +#+linux +(def-alien-type nil + (struct fpstate + (cw unsigned-long) + (sw unsigned-long) + (tag unsigned-long) + (ipoff unsigned-long) + (cssel unsigned-long) + (dataoff unsigned-long) + (datasel unsigned-long) + (fpreg (array (struct fpreg) 8)) + (status unsigned-long))) + +;;; for FreeBSD +#+freebsd +(def-alien-type sigcontext + (struct nil + (sc-onstack unsigned-int) + (sc-mask unsigned-int) + (sc-sp unsigned-int) + (sc-fp unsigned-int) + (sc-isp unsigned-int) + (sc-pc unsigned-int) + (sc-efl unsigned-int) ; sc_ps + (sc-es unsigned-int) + (sc-ds unsigned-int) + (sc-cs unsigned-int) + (sc-ss unsigned-int) + (sc-edi unsigned-int) + (sc-esi unsigned-int) + (sc-ebx unsigned-int) + (sc-edx unsigned-int) + (sc-ecx unsigned-int) + (sc-eax unsigned-int))) + +;; For Linux... +#+linux +(def-alien-type sigcontext + (struct nil + (gs unsigned-short) + (__gsh unsigned-short) + (fs unsigned-short) + (__fsh unsigned-short) + (sc-es unsigned-short) + (__esh unsigned-short) + (sc-ds unsigned-short) + (__dsh unsigned-short) + (sc-edi unsigned-long) + (sc-esi unsigned-long) + (ebp unsigned-long) + (sc-sp unsigned-long) + (sc-ebx unsigned-long) + (sc-edx unsigned-long) + (sc-ecx unsigned-long) + (sc-eax unsigned-long) + (trapno unsigned-long) + (err unsigned-long) + (sc-pc unsigned-long) + (sc-cs unsigned-short) + (__csh unsigned-short) + (sc-efl unsigned-long) + (esp_at_signal unsigned-long) + (sc-ss unsigned-short) + (__ssh unsigned-short) +; (fpstate unsigned-long) ;; fpstate struct pointer + (fpstate (* (struct fpstate))) + (sc-mask unsigned-long) + (cr2 unsigned-long))) + + + +;;;; MACHINE-TYPE and MACHINE-VERSION + +#-cross-compiler +(defun machine-type () + "Returns a string describing the type of the local machine." + "X86") + + +#-cross-compiler +(defun machine-version () + "Returns a string describing the version of the local machine." + "X86") + + + +;;; FIXUP-CODE-OBJECT -- Interface +;;; This gets called by LOAD to resolve newly positioned objects +;;; with things (like code instructions) that have to refer to them. + +(defun fixup-code-object (code offset fixup kind) + (declare (type index offset)) + (system:without-gcing + (let ((sap (truly-the system-area-pointer (c::code-instructions code)))) + (unless (member kind '(:absolute :relative)) + (error "Unknown code-object-fixup kind ~s." kind)) + (ecase kind + (:absolute + ;; word at sap + offset contains a value to be replaced by + ;; adding that value to fixup. + (setf (sap-ref-32 sap offset) + (+ fixup (sap-ref-32 sap offset)))) + (:relative + ;; fixup is actual address wanted. replace word with value + ;; to add to that loc to get there. + ;; (format t "x86-fixup ~a ~x ~x ~a~&" code offset fixup kind) + (let* ((loc-sap (+ (sap-int sap) offset)) + (rel-val (- fixup loc-sap 4))) + (declare (type (unsigned-byte 32) loc-sap) + (type (signed-byte 32) rel-val)) + ;;(format t "sap ~x ~x ~x~&" (sap-int sap) loc-sap rel-val) + (setf (sap-ref-32 sap offset) rel-val)) )))) + nil) + + + +;;;; Internal-error-arguments. + +;;; INTERNAL-ERROR-ARGUMENTS -- interface. +;;; +;;; Given the sigcontext, extract the internal error arguments from the +;;; instruction stream. +;;; +(defun internal-error-arguments (scp) + (declare (type (alien (* sigcontext)) scp)) + (with-alien ((scp (* sigcontext) scp)) + (let ((pc (int-sap (slot scp 'sc-pc)))) + (declare (type system-area-pointer pc)) + ;; using INT3 the pc is .. INT3 <here> code length bytes... + (let* ((length (sap-ref-8 pc 1)) + (vector (make-array length :element-type '(unsigned-byte 8)))) + (declare (type (unsigned-byte 8) length) + (type (simple-array (unsigned-byte 8) (*)) vector)) + (copy-from-system-area pc (* vm:byte-bits 2) + vector (* vm:word-bits + vm:vector-data-offset) + (* length vm:byte-bits)) + (let* ((index 0) + (error-number (c::read-var-integer vector index))) + (collect ((sc-offsets)) + (loop + (when (>= index length) + (return)) + (sc-offsets (c::read-var-integer vector index))) + (values error-number (sc-offsets)))))))) + + +;;;; Sigcontext access functions. + +;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface. +;;; +(defun sigcontext-program-counter (scp) + (declare (type (alien (* sigcontext)) scp)) + (with-alien ((scp (* sigcontext) scp)) + (int-sap (slot scp 'sc-pc)))) + +;;; SIGCONTEXT-REGISTER -- Interface. +;;; +;;; An escape register saves the value of a register for a frame that someone +;;; interrupts. +;;; + +(defun sigcontext-register (scp index) + (declare (type (alien (* sigcontext)) scp)) + (with-alien ((scp (* sigcontext) scp)) + (case index ; ugly -- I know. + (#.eax-offset (slot scp 'sc-eax)) + (#.ecx-offset (slot scp 'sc-ecx)) + (#.edx-offset (slot scp 'sc-edx)) + (#.ebx-offset (slot scp 'sc-ebx)) + (#.esp-offset (slot scp 'sc-sp)) +#-linux (#.ebp-offset (slot scp 'sc-fp)) +#+linux (#.ebp-offset (slot scp 'ebp)) + (#.esi-offset (slot scp 'sc-esi)) + (#.edi-offset (slot scp 'sc-edi))))) + + +(defun %set-sigcontext-register (scp index new) + (declare (type (alien (* sigcontext)) scp)) + (with-alien ((scp (* sigcontext) scp)) + (case index + (#.eax-offset (setf (slot scp 'sc-eax) new)) + (#.ecx-offset (setf (slot scp 'sc-ecx) new)) + (#.edx-offset (setf (slot scp 'sc-edx) new)) + (#.ebx-offset (setf (slot scp 'sc-ebx) new)) + (#.esp-offset (setf (slot scp 'sc-sp) new)) +#-linux (#.ebp-offset (setf (slot scp 'sc-fp) new)) +#+linux (#.ebp-offset (setf (slot scp 'ebp) new)) + (#.esi-offset (setf (slot scp 'sc-esi) new)) + (#.edi-offset (setf (slot scp 'sc-edi) new)))) + new) + +(defsetf sigcontext-register %set-sigcontext-register) + + +;;; SIGCONTEXT-FLOAT-REGISTER -- Interface +;;; +;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register. +;;; Format is the type of float to return. +;;; XXX +#-linux +(defun sigcontext-float-register (scp index format) + (declare (type (alien (* sigcontext)) scp)) + (with-alien ((scp (* sigcontext) scp)) + ;; fp regs not in sigcontext -- need new vop or c support + (let ((sap #+nil (alien-sap (slot scp 'sc-fpregs)))) + (declare (ignore sap)) + index + (ecase format + (single-float 0s0 + #+nil (system:sap-ref-single sap (* index vm:word-bytes))) + (double-float 0d0 + #+nil(system:sap-ref-double sap (* index vm:word-bytes))))))) + +#+linux +(defun sigcontext-float-register (scp index format) + (declare (type (alien (* sigcontext)) scp)) + (with-alien ((scp (* sigcontext) scp)) + ;; fp regs in sigcontext !!! + (let ((reg-sap (alien-sap (deref (slot (deref (slot scp 'fpstate) 0) + 'fpreg) + index)))) + (ecase format + (single-float + (system:sap-ref-single reg-sap 0)) + (double-float + (system:sap-ref-double reg-sap 0)))))) + +;;; +#-linux +(defun %set-sigcontext-float-register (scp index format new-value) + (declare (type (alien (* sigcontext)) scp)) + scp index format new-value + #+nil + (with-alien ((scp (* sigcontext) scp)) + (let ((sap (alien-sap (slot scp 'fpregs)))) + (ecase format + (single-float + (setf (sap-ref-single sap (* index vm:word-bytes)) new-value)) + (double-float + (setf (sap-ref-double sap (* index vm:word-bytes)) new-value)))))) +#+linux +(defun %set-sigcontext-float-register (scp index format new-value) + (declare (type (alien (* sigcontext)) scp)) + (with-alien ((scp (* sigcontext) scp)) + (let ((reg-sap (alien-sap (deref (slot (deref (slot scp 'fpstate) 0) + 'fpreg) + index)))) + (ecase format + (single-float + (setf (system:sap-ref-single reg-sap 0) new-value)) + (double-float + (setf (system:sap-ref-double reg-sap 0)new-value)))))) + +;;; + +(defsetf sigcontext-float-register %set-sigcontext-float-register) + +;;; SIGCONTEXT-FLOATING-POINT-MODES -- Interface +;;; +;;; Given a sigcontext pointer, return the floating point modes word in the +;;; same format as returned by FLOATING-POINT-MODES. +;;; + +#+FreeBSD +(defun sigcontext-floating-point-modes (scp) + (declare (type (alien (* sigcontext)) scp) + (ignore scp)) + ;; This is broken until some future release of FreeBSD!!! + (floating-point-modes)) + +#+linux +(defun sigcontext-floating-point-modes (scp) + (declare (type (alien (* sigcontext)) scp)) + (let ((cw (slot (deref (slot scp 'fpstate) 0) 'cw)) + (sw (slot (deref (slot scp 'fpstate) 0) 'sw))) + ;;(format t "cw = ~4x~%sw = ~4x~%" cw sw) + ;; NOT TESTED -- clear sticky bits to clear interrupt condition + (setf (slot (deref (slot scp 'fpstate) 0) 'sw) (logandc2 sw #x3f)) + ;;(format t "new sw = ~x~%" (slot (deref (slot scp 'fpstate) 0) 'sw)) + ;; simulate floating-point-modes VOP + (logior (ash (logand sw #xffff) 16) (logxor (logand cw #xffff) #x3f)))) + + +;;; EXTERN-ALIEN-NAME -- interface. +;;; +;;; The loader uses this to convert alien names to the form they occure in +;;; the symbol table (for example, prepending an underscore). +;;; +;;; On the x86 under FreeBSD, we prepend an underscore. If this is not +;;; done under Linux then this is the place to make the change. +;;; +(defun extern-alien-name (name) + (declare (type simple-string name)) + (lisp:concatenate 'string #+linux "" #-linux "_" name)) + +;;; This used to live in foreign.lisp but it gets loaded too late +;;; to be useful. This gets used by the loader to map lisp foreign +;;; symbol names to the OS's version of it. This was added for the +;;; Linux port -- maybe it makes the above extern-alien-name +;;; obsolete? +(defun system:alternate-get-global-address(symbol) + (declare (type simple-string symbol)) + (let ((namex symbol) + (table lisp::*foreign-symbols*)) ; defined in load.lisp + (cond ((gethash namex table nil)) +#+linux ((gethash (concatenate 'string "PVE_stub_" namex) table nil)) +#+linux ((gethash (concatenate 'string "" namex) table nil)) ; Linux +#+freebsd ((gethash (concatenate 'string "_" namex) table nil)); FreeBSD + ((gethash (concatenate 'string "__" namex) table nil)) + ((gethash (concatenate 'string "__libc_" namex) table nil)) + (t (progn (format t "Error: can't be in alt-get-gl-addr ~a" namex) + ;; returning 0 is VERY dangerous! + 0))))) + + + +;;; SANCTIFY-FOR-EXECUTION -- Interface. +;;; +;;; Do whatever is necessary to make the given code component executable. +;;; On the sparc, we don't need to do anything, because the i and d caches +;;; are unified. +;;; +(defun sanctify-for-execution (component) + (declare (ignore component)) + nil) + +;;; FLOAT-WAIT +;;; +;;; This is used in error.lisp to insure floating-point exceptions +;;; are properly trapped. The compiler translates this to a VOP. +;;; Note: if you are compiling this from an old version you may need +;;; to disable this until the float-wait VOP is entrenched. +(defun float-wait() + (float-wait)) + +;;; FLOAT CONSTANTS +;;; +;;; These are used by the FP move-from-{single|double} VOPs +;;; rather than the i387 load constant instructions to avoid +;;; consing in some cases. + +(defvar *fp-constant-0s0* 0s0) +(defvar *fp-constant-0d0* 0d0) +(defvar *fp-constant-1s0* 1s0) +(defvar *fp-constant-1d0* 1d0) diff --git a/compiler/aliencomp.lisp b/compiler/aliencomp.lisp index 955ecd7c9..f3ba012bb 100644 --- a/compiler/aliencomp.lisp +++ b/compiler/aliencomp.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/aliencomp.lisp,v 1.22 1994/10/31 04:27:28 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/aliencomp.lisp,v 1.23 1997/01/18 14:31:28 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -679,15 +679,21 @@ (let* ((arg (pop args)) (sc (tn-sc tn)) (scn (sc-number sc)) - (temp-tn (make-representation-tn (tn-primitive-type tn) scn)) + (temp-tn + (unless (backend-featurep :x86) + (make-representation-tn (tn-primitive-type tn) scn))) (move-arg-vops (svref (sc-move-arg-vops sc) scn))) (assert arg) (assert (= (length move-arg-vops) 1) () "No unique move-arg-vop for moves in SC ~S." (sc-name sc)) - (emit-move call block (continuation-tn call block arg) temp-tn) - (emit-move-arg-template call block (first move-arg-vops) - temp-tn nsp tn))) + (if (backend-featurep :x86) + (emit-move-arg-template call block (first move-arg-vops) + (continuation-tn call block arg) nsp tn) + (progn + (emit-move call block (continuation-tn call block arg) temp-tn) + (emit-move-arg-template call block (first move-arg-vops) + temp-tn nsp tn))))) (assert (null args)) (unless (listp result-tns) (setf result-tns (list result-tns))) diff --git a/compiler/constraint.lisp b/compiler/constraint.lisp index e75761d33..a331e569f 100644 --- a/compiler/constraint.lisp +++ b/compiler/constraint.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/constraint.lisp,v 1.15 1994/10/31 04:27:28 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/constraint.lisp,v 1.16 1997/01/18 14:31:31 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -305,6 +305,60 @@ res))) +;;; FLOAT-TYPE-P -- Internal +;;; +;;; Return true if X is a float NUMERIC-TYPE. +;;; +(defun float-type-p (x) + (declare (type ctype x)) + (and (numeric-type-p x) + (eq (numeric-type-class x) 'float) + (eq (numeric-type-complexp x) :real))) + +;;; CONSTRAIN-FLOAT-TYPE -- Internal +;;; +;;; Exactly the same as CONSTRAIN-INTEGER-TYPE, but for float numbers. +;;; +(defun constrain-float-type (x y greater or-equal) + (declare (type numeric-type x y)) + (flet ((exclude (x) + (cond ((not x) nil) + (or-equal x) + (greater + (if (consp x) + (car x) + x)) + (t + (if (consp x) + x + (list x))))) + (bound (x) + (if greater (numeric-type-low x) (numeric-type-high x)))) + #+nil + (format t "~%constraint-float-type:~% ~s~% ~s~% ~s~% ~s~%" + x y greater or-equal) + (let* ((x-bound (bound x)) + (y-bound (exclude (bound y))) + (new-bound (cond ((not x-bound) + y-bound) + ((not y-bound) + x-bound) + (greater + (max-bound x-bound y-bound)) + (t + (min-bound x-bound y-bound)))) + (res (copy-numeric-type x))) + #+nil + (format t "x-bound, y-bound, new-bound = ~s, ~s, ~s~%" + x-bound y-bound new-bound) + (if greater + (setf (numeric-type-low res) new-bound) + (setf (numeric-type-high res) new-bound)) + #+nil + (format t "~&constrain-float-type returns ~s~%" res) + res))) + + ;;; CONSTRAIN-REF-TYPE -- Internal ;;; ;;; Given the set of Constraints for a variable and the current set of @@ -341,11 +395,18 @@ (change-ref-leaf ref other) (when (constant-p other) (return))))))) ((< >) - (when (and (integer-type-p res) (integer-type-p y)) - (let ((greater (eq kind '>))) - (let ((greater (if not-p (not greater) greater))) - (setq res - (constrain-integer-type res y greater not-p))))))))) + (cond ((and (integer-type-p res) (integer-type-p y)) + (let ((greater (eq kind '>))) + (let ((greater (if not-p (not greater) greater))) + (setq res + (constrain-integer-type res y greater not-p))))) + #+constrain-float-type + ((and (float-type-p res) (float-type-p y)) + (let ((greater (eq kind '>))) + (let ((greater (if not-p (not greater) greater))) + (setq res + (constrain-float-type res y greater not-p))))) + ))))) (let* ((cont (node-cont ref)) (dest (continuation-dest cont))) @@ -514,3 +575,4 @@ (use-result-constraints block)) (undefined-value)) + diff --git a/compiler/float-tran.lisp b/compiler/float-tran.lisp index 14a90785f..b4ffed819 100644 --- a/compiler/float-tran.lisp +++ b/compiler/float-tran.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/float-tran.lisp,v 1.23 1994/10/31 04:27:28 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/float-tran.lisp,v 1.24 1997/01/18 14:31:35 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -36,17 +36,17 @@ (deftransform %double-float ((n) (double-float) * :when :both) 'n) -(deftransform coerce ((n type) - (* (constant-argument - (member float short-float single-float))) - * :when :both) - '(%single-float n)) - -(deftransform coerce ((n type) - (* (constant-argument - (member double-float long-float))) - * :when :both) - '(%double-float n)) +(deftransform coerce ((n type) (* *) * :when :both) + (unless (constant-continuation-p type) + (give-up)) + `(the ,(continuation-value type) + ,(let ( (tspec (specifier-type (continuation-value type))) ) + (cond ((csubtypep tspec (specifier-type 'double-float)) + '(%double-float n)) + ((csubtypep tspec (specifier-type 'float)) + '(%single-float n)) + (t + (give-up)))))) ;;; Not strictly float functions, but primarily useful on floats: ;;; @@ -178,12 +178,88 @@ (deftransform integer-decode-float ((x) (double-float) * :when :both) '(integer-decode-double-float x)) +#-x86 (deftransform scale-float ((f ex) (single-float *) * :when :both) '(scale-single-float f ex)) +#-x86 (deftransform scale-float ((f ex) (double-float *) * :when :both) '(scale-double-float f ex)) +#+x86 +(deftransform scale-float ((f ex) (single-float (signed-byte 32)) *) + '(coerce (%scalbn (coerce f 'double-float) ex) 'single-float)) + +#+x86 +(deftransform scale-float ((f ex) (double-float (signed-byte 32)) * + :when :both) + '(%scalbn f ex)) + +;;; toy@rtp.ericsson.se: +;;; +;;; Optimizers for scale-float. If the float has bounds, new bounds +;;; are computed for the result, if possible. + +#+propagate-float-type +(progn +(macrolet + ((frob (name) + `(defoptimizer (,name derive-type) ((f ex)) + (flet ((scale-bound (x n) + ;; We need to be a bit careful here and catch any + ;; overflows that might occur. We can ignore + ;; underflows which become zeros. + (set-bound + (handler-case + (scale-float (bound-value x) n) + (floating-point-overflow () + nil)) + (consp x)))) + (let ((f-type (continuation-type f)) + (ex-type (continuation-type ex))) + (when (and (numeric-type-p f-type) + (numeric-type-p ex-type)) + (let ((f-lo (numeric-type-low f-type)) + (f-hi (numeric-type-high f-type)) + (ex-lo (numeric-type-low ex-type)) + (ex-hi (numeric-type-high ex-type)) + (new-lo nil) + (new-hi nil)) + (when (and f-hi ex-hi) + (setf new-hi (scale-bound f-hi ex-hi))) + (when (and f-lo ex-lo) + (setf new-lo (scale-bound f-lo ex-lo))) + (make-numeric-type :class (numeric-type-class f-type) + :format (numeric-type-format f-type) + :complexp :real + :low new-lo + :high new-hi)))))))) + (frob scale-single-float) + (frob scale-double-float)) + +;;; Defoptimizers for %single-float and %double-float. This makes the +;;; FLOAT function return the correct ranges if the input has some +;;; defined range. Quite useful if we want to convert some time of +;;; bounded integer into a float. + +(macrolet ((frob (fun type) + `(defoptimizer (,fun derive-type) ((num)) + (let ((num-type (continuation-type num))) + (when (numeric-type-p num-type) + ;; We are trying to float some number to a float + ;; type. The result is obviously a float with the + ;; same range as NUM. + (make-numeric-type + :class 'float + :format ',type + :low (numeric-type-low num-type) + :high (numeric-type-high num-type))))) + )) + (frob %single-float single-float) + (frob %double-float double-float)) + +) ; end progn + ;;;; Float contagion: @@ -235,11 +311,13 @@ ;;; Derive the result to be float for argument types in the appropriate domain. ;;; -(dolist (stuff '((asin (real (-1.0) (1.0))) - (acos (real (-1.0) (1.0))) +#-propagate-fun-type +(dolist (stuff '((asin (real -1.0 1.0)) + (acos (real -1.0 1.0)) (acosh (real 1.0)) - (atanh (real (-1.0) (1.0))) - (sqrt (real 0.0)))) + (atanh (real -1.0 1.0)) + (sqrt (real 0.0)) + )) (destructuring-bind (name type) stuff (let ((type (specifier-type type))) (setf (function-info-derive-type (function-info-or-lose name)) @@ -250,32 +328,72 @@ type) (specifier-type 'float))))))) +#-propagate-fun-type (defoptimizer (log derive-type) ((x &optional y)) (when (and (csubtypep (continuation-type x) - (specifier-type '(real (0.0)))) + (specifier-type '(real 0.0))) (or (null y) (csubtypep (continuation-type y) - (specifier-type '(real (0.0)))))) + (specifier-type '(real 0.0))))) (specifier-type 'float))) ;;;; Irrational transforms: -(defknown (%sin %cos %tan %asin %acos %atan %sinh %cosh %tanh %asinh - %acosh %atanh %exp %log %log10 %sqrt) +(defknown (%tan %sinh %asinh %atanh %log %logb %log10 #+x86 %tan-quick) (double-float) double-float (movable foldable flushable)) -(defknown (%atan2 %pow %hypot) - (double-float double-float) double-float +(defknown (%sin %cos %tanh #+x86 %sin-quick #+x86 %cos-quick) + (double-float) (double-float -1.0d0 1.0d0) + (movable foldable flushable)) + +(defknown (%asin %atan) + (double-float) (double-float #.(- (/ pi 2)) #.(/ pi 2)) + (movable foldable flushable)) + +(defknown (%acos) + (double-float) (double-float 0.0d0 #.pi) + (movable foldable flushable)) + +(defknown (%cosh) + (double-float) (double-float 1.0d0) + (movable foldable flushable)) + +(defknown (%acosh %exp %sqrt) + (double-float) (double-float 0.0d0) + (movable foldable flushable)) + +(defknown (%hypot) + (double-float double-float) (double-float 0d0) (movable foldable flushable)) +(defknown (%pow) + (double-float double-float) double-float + (movable foldable flushable)) + +(defknown (%atan2) + (double-float double-float) (double-float #.(- pi) #.pi) + (movable foldable flushable)) + +(defknown (%scalb) + (double-float double-float) double-float + (movable foldable flushable)) + +(defknown (%scalbn) + (double-float (signed-byte 32)) double-float + (movable foldable flushable)) + +(defknown (%log1p-limited) + (double-float) double-float + (movable foldable flushable)) + (dolist (stuff '((exp %exp *) (log %log float) (sqrt %sqrt float) - (sin %sin *) - (cos %cos *) - (tan %tan *) + #-x86 (sin %sin *) + #-x86 (cos %cos *) + #-x86 (tan %tan *) (asin %asin float) (acos %acos float) (atan %atan *) @@ -291,16 +409,557 @@ (deftransform name ((x) '(double-float) rtype :eval-name t :when :both) `(,prim x)))) +;;; The argument range is limited on the x86 FP trig. functions. A +;;; post-test can detect a failure (and load a suitable result), but +;;; this test is avoided if possible. +#+x86 +(dolist (stuff '((sin %sin %sin-quick) + (cos %cos %cos-quick) + (tan %tan %tan-quick))) + (destructuring-bind (name prim prim-quick) stuff + (deftransform name ((x) '(single-float) '* :eval-name t :when :both) + (cond ((csubtypep (continuation-type x) + (specifier-type '(single-float (#.(- (expt 2s0 64))) + (#.(expt 2s0 64))))) + `(coerce (,prim-quick (coerce x 'double-float)) 'single-float)) + (t + (compiler-note + "Unable to avoid inline argument range check~@ + because the argument range (~s) was not within 2^64" + (type-specifier (continuation-type x))) + `(coerce (,prim (coerce x 'double-float)) 'single-float)))) + (deftransform name ((x) '(double-float) '* :eval-name t :when :both) + (cond ((csubtypep (continuation-type x) + (specifier-type '(double-float (#.(- (expt 2d0 64))) + (#.(expt 2d0 64))))) + `(,prim-quick x)) + (t + (compiler-note + "Unable to avoid inline argument range check~@ + because the argument range (~s) was not within 2^64" + (type-specifier (continuation-type x))) + `(,prim x)))))) + (dolist (stuff '((expt %pow t) (atan %atan2 t))) (destructuring-bind (name prim rtype) stuff - (deftransform name ((x y) '(single-float) rtype :eval-name t) + (deftransform name ((x y) '(single-float single-float) rtype :eval-name t) `(coerce (,prim (coerce x 'double-float) (coerce y 'double-float)) 'single-float)) - (deftransform name ((x y) '(double-float) rtype :eval-name t :when :both) + (deftransform name ((x y) '(double-float double-float) + rtype :eval-name t :when :both) `(,prim x y)))) (deftransform log ((x y) (float float) float) '(/ (log x) (log y))) + +#+propagate-fun-type +(progn +;;;; Optimizers for elementary functions +;;;; +;;;; These optimizers compute the output range of the elementary +;;;; function, based on the domain of the input. +;;;; + +;;; Handle some simple transformations + +(deftransform abs ((x) ((complex double-float)) double-float :when :both) + '(%hypot (realpart x) (imagpart x))) + +(deftransform abs ((x) ((complex single-float)) single-float :when :both) + '(coerce (%hypot (coerce (the single-float (realpart x)) 'double-float) + (coerce (the single-float (imagpart x)) 'double-float)) + 'single-float)) + +(deftransform phase ((x) ((complex double-float)) double-float :when :both) + '(%atan2 (imagpart x) (realpart x))) + +(deftransform phase ((x) ((complex single-float)) single-float :when :both) + '(coerce (%atan2 (coerce (the single-float (imagpart x)) 'double-float) + (coerce (the single-float (realpart x)) 'double-float)) + 'single-float)) + +(deftransform phase ((x) ((float)) float :when :both) + '(if (minusp (float-sign x)) + (float pi x) + (float 0 x))) + + +;;; Return the float format of the result of an elementary function. +;;; If the format is NIL (which means type FLOAT), we return NIL. If +;;; the format is 'DOUBLE-FLOAT, we return that. For any other case, +;;; we return 'SINGLE-FLOAT. + +(proclaim '(inline elfun-format numeric-type-real-p)) +(defun elfun-float-format (format) + (if format + (if (eq format 'double-float) + 'double-float + 'single-float))) + +;;; The number is of type REAL. + +(defun numeric-type-real-p (type) + (and (numeric-type-p type) + (eq (numeric-type-complexp type) :real))) + +;;; Macro to handle most cases of computing the bounds for a +;;; function. +;;; +;;; NUM is a continuation representing the argument to the +;;; function. +;;; +;;; COND is an sexp that returns T when the number satisfies the +;;; desired condition. The sexp can refer to the two variables, LO +;;; and HI, which are set to the lower and upper bounds of NUM. +;;; +;;; LIMIT-FUN is a function that returns the lower and upper bounds. + +(defmacro elfun-derive-type (num cond limit-fun) + (let ((type (gensym)) + (lo-lim (gensym)) + (hi-lim (gensym))) + `(let ((,type (continuation-type ,num))) + (when (numeric-type-real-p ,type) + (let ((lo (numeric-type-low ,type)) + (hi (numeric-type-high ,type))) + (when ,cond + (multiple-value-bind (,lo-lim ,hi-lim) + (funcall ,limit-fun lo hi) + (make-numeric-type :class 'float + :format (elfun-float-format + (numeric-type-format ,type)) + :complexp :real + :low ,lo-lim + :high ,hi-lim)))))))) + +;;; Handle these monotonic increasing functions whose domain is +;;; possibly part of the real line +(macrolet ((frob (name cond def-lo-bnd def-hi-bnd) + (let ((num (gensym)) + (lo-bnd (gensym)) + (hi-bnd (gensym))) + `(defoptimizer (,name derive-type) ((,num)) + (elfun-derive-type + ,num + ,cond + #'(lambda (,lo-bnd ,hi-bnd) + ;; Since the function is monotonic increasing, the + ;; lower bound and the upper bound are the values + ;; of the function at the bounds of the input + ;; range. + (values (if ,lo-bnd + (set-bound (,name (bound-value ,lo-bnd)) + (consp ,lo-bnd)) + ,def-lo-bnd) + (if ,hi-bnd + (set-bound (,name (bound-value ,hi-bnd)) + (consp ,hi-bnd)) + ,def-hi-bnd)))))))) + + ;; These functions are easy because they are defined for the whole + ;; real line. + (frob exp t 0 nil) + (frob sinh t nil nil) + (frob tanh t -1 1) + (frob asinh t nil nil) + + ;; These functions are only defined for part of the real line. The + ;; condition selectes the desired part of the line. + (frob sqrt (and lo + (>= (bound-value lo) 0)) + 0 nil) + (frob asin (and lo hi + (>= (bound-value lo) -1) + (<= (bound-value hi) 1)) + #.(- (/ pi 2)) #.(/ pi 2)) + (frob acosh (and lo (>= (bound-value lo) 1)) + nil nil) + (frob atanh (and lo hi + (>= (bound-value lo) -1) + (<= (bound-value hi) 1)) + -1 1) + ) + +;;; acos is monotonic decreasing, so we need to swap the function +;;; values at the lower and upper bounds of the input domain. +(defoptimizer (acos derive-type) ((num)) + (elfun-derive-type + num + (and lo hi + (>= (bound-value lo) -1) + (<= (bound-value hi) 1)) + #'(lambda (lo hi) + (values (if hi + (set-bound (acos (bound-value hi)) (consp hi))) + (if lo + (set-bound (acos (bound-value lo)) (consp lo))))))) + +;;; Compute return type for EXPT. No bounds are computed because +;;; that's pretty complicated in general. We only return a lower +;;; bound of 0 if we know that 0 is a lower bound. The general case +;;; will have to wait for another day. + +(defoptimizer (expt derive-type) ((x y)) + (let ((x-type (continuation-type x)) + (y-type (continuation-type y))) + (when (and (numeric-type-p x-type) (numeric-type-p y-type)) + (let ((x-lo (numeric-type-low x-type)) + (y-lo (numeric-type-low y-type))) + ;; There are several cases to handle for Y. We only handle + ;; the case where Y is an integer and Y is a float. For Y + ;; rational, the result could be a rational or float. + + (cond ((eq (numeric-type-class y-type) 'integer) + (cond ((and y-lo (>= (bound-value y-lo) 0)) + ;; When the power is a non-negative integer, the + ;; result is of the same class and format as the + ;; base. If the base is known to be + ;; non-negative, the result is too. We can + ;; easily compute the bound on the result in + ;; this case, but that's for another day. + (make-numeric-type + :class (numeric-type-class x-type) + :format (numeric-type-format x-type) + :complexp :real + :low (if (and x-lo (>= (bound-value x-lo) 0)) + 0 + nil) + :high nil)) + (t + ;; The power maybe positive or negative. + (let ((pos (and x-lo (>= (bound-value x-lo) 0)))) + ;; If the base is positive, the result is + ;; positive. + (cond ((member (numeric-type-class x-type) + '(integer rational)) + ;; Rational raised to a non-negative + ;; integral power is rational. + (make-numeric-type + :class 'rational + :complexp :real + :low (if pos 0 nil) + :high nil)) + (t + ;; Float raised to integral power is a + ;; float. + (make-numeric-type + :class 'float + :format (numeric-type-format x-type) + :complexp :real + :low (if pos 0 nil) + :high nil))))))) + ((eq (numeric-type-class y-type) 'float) + ;; The power is a float. The result is either a float + ;; or complex. We punt if the result is complex. + (let ((pos (and x-lo (>= (bound-value x-lo) 0)))) + ;; If both the base and the power are non-negative, + ;; the result is a non-negative real. In any case + ;; the result is a float of some time. + (make-numeric-type + :class 'float + :format (if (or (eq (numeric-type-format x-type) + 'double-float) + (eq (numeric-type-format y-type) + 'double-float)) + 'double-float + 'single-float) + :complexp :real + :low (if pos 0 nil) + :high nil)))))))) + + +(defoptimizer (log derive-type) ((x &optional y)) + ;; We only handle the case where both x and y are non-negative reals. + (when (and (csubtypep (continuation-type x) + (specifier-type '(real 0.0))) + (or (null y) + (csubtypep (continuation-type y) + (specifier-type '(real 0.0))))) + ;; If we get here, x must be a numeric type like (real 0.0). + (cond (y + ;; The base is given. We punt on this case and just say + ;; the result is a float. + (specifier-type 'float)) + + (t + ;; We have (log x) for non-negative x. Get the bounds + ;; on the result. + (elfun-derive-type + x + t + #'(lambda (lo hi) + (values (if (zerop (bound-value lo)) + nil + (set-bound (log (bound-value lo)) (consp lo))) + (if hi + (set-bound (log (bound-value hi)) (consp hi)) + nil)))))))) + + +(defoptimizer (atan derive-type) ((y &optional x)) + ;; We only handle the case where both x and y are real + (let ((y-type (continuation-type y))) + (when (numeric-type-real-p y-type) + (cond ((and x (numeric-type-real-p (continuation-type x))) + ;; We punt on this case and just return the max bounds + (make-numeric-type + :class 'float + :format (float-format-max + (numeric-type-format y-type) + (numeric-type-format (continuation-type x))) + :complexp :real + :low #.(- pi) + :high #.pi)) + (t + ;; One arg case is easy to handle. + (elfun-derive-type + y + t + #'(lambda (lo hi) + (values (if lo + (set-bound (atan (bound-value lo)) (consp lo)) + #.(- (/ pi 2))) + (if hi + (set-bound (atan (bound-value hi)) (consp hi)) + #.(/ pi 2)))))))))) + +(defoptimizer (cosh derive-type) ((num)) + (let ((type (continuation-type num))) + (when (numeric-type-real-p type) + (multiple-value-bind (lo hi) + (extract-bounds type) + (let* ((max-bnd (max-bound (bound-abs lo) (bound-abs hi))) + (min-bnd (min-bound (bound-abs lo) (bound-abs hi)))) + (make-numeric-type + :class 'float + :format (elfun-float-format (numeric-type-format type)) + :complexp :real + :low (if (and (bound-< lo 0) (bound-< 0 hi)) + ;; If zero is in the input domain, then the lower + ;; bound is cosh(0). Otherwise it's the min of + ;; the bounds. + 1 + (if (symbolp min-bnd) + nil + (set-bound (cosh (bound-value min-bnd)) + (consp min-bnd)))) + :high (if (symbolp max-bnd) + nil + (set-bound (cosh (bound-value max-bnd)) + (consp max-bnd))))))))) + +(defoptimizer (phase derive-type) ((num)) + (let ((type (continuation-type num))) + (cond ((numeric-type-real-p type) + ;; Taking the phase of a real number. The answer is either 0 or pi. + (multiple-value-bind (lo hi) + (extract-bounds type) + ;; If 0 is contained in the bounds, the answer is either + ;; 0 or pi, but we don't know which, so return a float of + ;; the appropriate type. + (cond ((bound-< hi 0) + ;; The upper bound is less than 0, so we know that + ;; the phase must be pi. + (make-numeric-type :class 'float + :format (elfun-float-format + (numeric-type-format type)) + :complexp :real + :low pi + :high pi)) + ((bound-< 0 lo) + ;; The lower bound is greater than zero, + ;; so the answer must be zero. + (make-numeric-type :class 'float + :format (elfun-float-format + (numeric-type-format type)) + :complexp :real + :low 0 + :high 0)) + (t + ;; The bounds must contain zero. The answer is 0 or pi. + (make-numeric-type :class 'float + :format (elfun-float-format + (numeric-type-format type)) + :complexp :real + :low 0 + :high pi))))) + (t + ;; We have a complex number. The answer is the range -pi + ;; to pi. (-pi is included because we have -0.) + (make-numeric-type :class 'float + :format (elfun-float-format + (numeric-type-format type)) + :complexp :real + :low #.(- pi) + :high pi))))) + +;;; Make REALPART and IMAGPART return the appropriate types. This +;;; helps a lot in optimized code. + +#+nil +(defknown (%realpart) + (complex) real + (flushable movable)) + +#+nil +(defknown (%imagpart) + (complex) real + (flushable movable)) + +#+nil +(defoptimizer (%realpart derive-type) ((num)) + (let ((type (continuation-type num))) + (cond ((numeric-type-real-p type) + ;; The realpart of a real has the same type and range as the input. + (make-numeric-type :class (numeric-type-class type) + :format (numeric-type-format type) + :complexp :real + :low (numeric-type-low type) + :high (numeric-type-high type))) + (t + ;; We have a complex number. The result has the same type + ;; as the real part, except that it's real, not complex, + ;; obviously. + (make-numeric-type :class (numeric-type-class type) + :format (numeric-type-format type) + :complexp :real + :low (numeric-type-low type) + :high (numeric-type-high type)))))) + +#+nil +(defoptimizer (%imagpart derive-type) ((num)) + (let ((type (continuation-type num))) + (cond ((numeric-type-real-p type) + ;; The imagpart of a real has the same type as the input, + ;; except that it's zero + (make-numeric-type :class (numeric-type-class type) + :format (numeric-type-format type) + :complexp :real + :low 0 + :high 0)) + (t + ;; We have a complex number. The result has the same type + ;; as the imaginary part, except that it's real, not complex, + ;; obviously. + (make-numeric-type :class (numeric-type-class type) + :format (numeric-type-format type) + :complexp :real + :low (numeric-type-low type) + :high (numeric-type-high type)))))) + + +) ;end progn + + +;;;; Here are the optimizers for sin, cos, and tan. While computing +;;;; the bounds for these functions is easy, I'm not sure about the +;;;; reliability of these functions. Mainly, these functions do a +;;;; range reduction which may not be exactly the same as done in the +;;;; trig functions so that roundoff may signficantly affect the +;;;; limits returned. +;;;; +;;;; Thus, if x is (double-float 1d0 #.pi), the sin optimizer would +;;;; return (double-float 1.2246467991473534d-16 +;;;; 0.8414709848078965d0), which is close to but not the same as +;;;; (double-float 0d0 0.8414709848078965d0), which is closer to the +;;;; truth. +;;;; +;;;; Proceed at your own risk here by adding propagate-trig-fun to +;;;; your *features*. + +#+(and propagate-fun-type propagate-trig-fun) +(progn +(defoptimizer (tan derive-type) ((num)) + (let ((type (continuation-type num))) + (when (numeric-type-real-p type) + (let ((xl (numeric-type-low type)) + (xh (numeric-type-high type))) + (cond ((and xl xh + (<= (- (bound-value xh) (bound-value xl)) pi)) + ;; We have a bounded input range and the range covers + ;; no more than one period. We can compute bounds now. + ;; We reduce the argument range to a single period. + (multiple-value-bind (npi x-lo) + (truncate (bound-value xl) pi) + (let* ((x-hi (- (bound-value xh) (* npi pi)))) + ;; If pi/2 is in the input range, the domain is the + ;; whole real line. + (format t "x-lo, x-hi = ~s ~s~%" x-lo x-hi) + (if (<= x-lo #.(* 0.5d0 pi) x-hi) + (make-numeric-type + :class 'float + :format (elfun-float-format (numeric-type-format type)) + :complexp :real + :low nil + :high nil) + (make-numeric-type + :class 'float + :format (elfun-float-format (numeric-type-format type)) + :complexp :real + :low (set-bound (tan x-lo) (consp x-lo)) + :high (set-bound (tan x-hi) (consp x-hi))))))) + (t + ;; The range covers more than one period, so the answer + ;; is obvious. + (make-numeric-type + :class 'float + :format (elfun-float-format (numeric-type-format type)) + :complexp :real + :low nil + :high nil))))))) + + +(defun trig-limits (num fun bound-one bound-minus-one) + (let ((type (continuation-type num))) + (when (numeric-type-real-p type) + (let ((two-pi #.(* 2 pi)) + (xl (numeric-type-low type)) + (xh (numeric-type-high type))) + (cond ((and xl xh + (<= (- (bound-value xh) (bound-value xl)) #.(* 2 pi))) + ;; We have a bounded input range and the range covers + ;; no more than one period. We can compute bounds now. + ;; We reduce the argument range to a single period. + (multiple-value-bind (nperiods x-lo) + (ftruncate (bound-value xl) two-pi) + (let* ((x-hi (- (bound-value xh) (* nperiods two-pi))) + (bound-list (list (set-bound (funcall fun x-lo) + (consp xl)) + (set-bound (funcall fun x-hi) + (consp xh))))) + ;; Add the upper and lower values for bounds on the + ;; function if the range covers the corresponding + ;; points. + (when (<= x-lo bound-one x-hi) + (push 1 bound-list)) + (when (<= x-lo bound-minus-one x-hi) + (push -1 bound-list)) + (make-numeric-type :class 'float + :format (elfun-float-format + (numeric-type-format type)) + :complexp :real + :low (min-bound-list bound-list) + :high (max-bound-list bound-list))))) + (t + ;; The range covers more than one period, + ;; so the answer is obvious. + (make-numeric-type :class 'float + :format (elfun-float-format + (numeric-type-format type)) + :complexp :real + :low nil + :high nil))))))) + +(defoptimizer (sin derive-type) ((num)) + (trig-limits num #'sin #.(/ pi 2) #.(* 1.5d0 pi))) + +(defoptimizer (cos derive-type) ((num)) + (trig-limits num #'cos 0 pi)) + +) ; end progn + + + diff --git a/compiler/fndb.lisp b/compiler/fndb.lisp index 8d6dc0560..01c96a25d 100644 --- a/compiler/fndb.lisp +++ b/compiler/fndb.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/fndb.lisp,v 1.67 1996/07/08 19:01:21 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/fndb.lisp,v 1.68 1997/01/18 14:31:34 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -947,7 +947,9 @@ (flushable)) (defknown make-pathname - (&key (:defaults pathnamelike) (:host pathname-host) (:device pathname-device) + (&key (:defaults pathnamelike) + (:host (or string pathname-host)) + (:device pathname-device) (:directory (or pathname-directory string (member :wild))) (:name (or pathname-name string (member :wild))) (:type (or pathname-type string (member :wild))) @@ -1046,7 +1048,7 @@ (or string null) (flushable)) -(defknown describe (t &optional stream) (values)) +(defknown describe (t &optional (or stream (member t nil))) (values)) (defknown inspect (t) (values)) (defknown room (&optional (member t nil :default)) void) diff --git a/compiler/generic/core.lisp b/compiler/generic/core.lisp index a0e80b1a6..7cce3194d 100644 --- a/compiler/generic/core.lisp +++ b/compiler/generic/core.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/core.lisp,v 1.31 1994/10/31 04:38:06 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/core.lisp,v 1.32 1997/01/18 14:31:14 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -95,7 +95,13 @@ (gethash name lisp::*assembler-routines*)) (:foreign (assert (stringp name)) - (gethash name lisp::*foreign-symbols*))) + (gethash name lisp::*foreign-symbols*)) + ;;; pw -- don't the RISC systems need this too? + #+x86 + (:code-object + (values + (get-lisp-obj-address code) + t))) (unless found (error (ecase flavor (:assembly-routine "Undefined assembler routine: ~S") @@ -104,6 +110,8 @@ (vm:fixup-code-object code offset value kind))))) + + ;;; REFERENCE-CORE-FUNCTION -- Internal ;;; ;;; Stick a reference to the function Fun in Code-Object at index I. If the diff --git a/compiler/generic/new-genesis.lisp b/compiler/generic/new-genesis.lisp index 73c3d8306..8874d6daf 100644 --- a/compiler/generic/new-genesis.lisp +++ b/compiler/generic/new-genesis.lisp @@ -4,7 +4,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.19 1994/10/31 04:38:06 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.20 1997/01/18 14:31:16 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -419,14 +419,14 @@ (etypecase num (single-float (let ((des (allocate-unboxed-object *dynamic* vm:word-bits - vm:single-float-size + (1- vm:single-float-size) vm:single-float-type))) (write-indexed des vm:single-float-value-slot (make-random-descriptor (single-float-bits num))) des)) (double-float (let ((des (allocate-unboxed-object *dynamic* vm:word-bits - vm:double-float-size + (1- vm:double-float-size) vm:double-float-type)) (high-bits (make-random-descriptor (double-float-high-bits num))) (low-bits (make-random-descriptor (double-float-low-bits num)))) @@ -456,7 +456,7 @@ (defun sap-to-core (sap) (let ((des (allocate-unboxed-object *dynamic* vm:word-bits - vm:sap-size vm:sap-type))) + (1- vm:sap-size) vm:sap-type))) (write-indexed des vm:sap-pointer-slot (make-random-descriptor (sap-int sap))) des)) @@ -554,7 +554,7 @@ ;;; ;;; Return a handle on an interned symbol. If necessary allocate ;;; the symbol and record which package the symbol was referenced in. -;;; When we allocatethe symbol, make sure we record a reference to +;;; When we allocate the symbol, make sure we record a reference to ;;; the symbol in the home package so that the package gets set. ;;; (defun cold-intern (symbol &optional (package (symbol-package symbol))) @@ -698,7 +698,13 @@ (frob *static-space-free-pointer* (allocate-descriptor *static* 0 vm:even-fixnum-type)) (frob *initial-dynamic-space-free-pointer* - (allocate-descriptor *dynamic* 0 vm:even-fixnum-type)))) + (allocate-descriptor *dynamic* 0 vm:even-fixnum-type)) + + (when (c:backend-featurep :x86) + (frob x86::*fp-constant-0d0* (number-to-core 0d0)) + (frob x86::*fp-constant-1d0* (number-to-core 1d0)) + (frob x86::*fp-constant-0s0* (number-to-core 0s0)) + (frob x86::*fp-constant-1s0* (number-to-core 1s0))))) ;;; Make-Make-Package-Args -- Internal ;;; @@ -1425,9 +1431,12 @@ ;; Note: we round the number of constants up to assure that ;; the code vector will be properly aligned. (round-up raw-header-size 2)) - (des (allocate-descriptor *dynamic* - (+ (ash header-size vm:word-shift) size) - vm:other-pointer-type))) + (des (allocate-descriptor + (if (c:backend-featurep :x86) + *static* + *dynamic*) + (+ (ash header-size vm:word-shift) size) + vm:other-pointer-type))) (write-memory des (make-other-immediate-descriptor header-size vm:code-header-type)) @@ -1597,12 +1606,54 @@ (return)) (multiple-value-bind (value name) - (if (string= "0x" line :end2 2) - (values (parse-integer line :start 2 :end 10 :radix 16) - (subseq line 13)) - (values (parse-integer line :end #-alpha 8 #+alpha 16 - :radix 16) - (subseq line #-alpha 11 #+alpha 19))) + (if (string= "0x" line :end2 2) +;;; (values (parse-integer line :start 2 +;;; :end #-alpha 10 #+alpha 18 :radix 16) +;;; (subseq line #-alpha 13 #+alpha 19)) +;;; (values (parse-integer line :end #-alpha 8 #+alpha 16 +;;; :radix 16) +;;; (subseq line #-alpha 11 #+alpha 19))) +;;; If your nm produces 64-bit addresses, there's 3 ways to get +;;; new-genesis to work: Yet another is to use 'sed' in your Config file. +;; OPTION 1 --- hard-wire 16 bit values into line +;; i.e. replace above six lines with these +; (values (parse-integer line :start 2 :end 18 :radix 16) +; (subseq line #-alpha 21 #+alpha 19)) +; (values (parse-integer line :end 16 :radix 16) +; (subseq line #-alpha 19 #+alpha 19))) +;; OPTION 2 --- scan line, read junk, and do subseq until non-int char found +; (values (parse-integer line :start 2 :end 16 :radix 16 +; :junk-allowed t) +; (let ((pos 2)) +; (loop +; (setq pos (+ pos 8)) +; (if (not (digit-char-p (char line pos) 16)) +; (return))) +; (subseq line (+ pos 3)))) +; (values (parse-integer line :end 16 :radix 16 +; :junk-allowed t) +; (let ((pos 0)) +; (loop +; (setq pos (+ pos 8)) +; (if (not (digit-char-p (char line pos) 16)) +; (return))) +; (subseq line (+ pos 3))))) +;;; OPTION 3 --- use environment variable for 64 bit linux +;; i.e. in setenv.lsp add (pushnew :linux64 *features*) +;; (using the alpha flag also works, but I don't know if it has +;; side-effects) + (values (parse-integer line :start 2 :radix 16 + :end #-(or alpha linux64) 10 + #+(or alpha linux64) 18) + (subseq line #-(or alpha linux64) 13 + #+(or alpha linux64) 19)) + (values (parse-integer line :radix 16 + :end #-(or alpha linux64) 8 + #+(or alpha linux64) 16) + (subseq line #-(or alpha linux64) 11 + #+(or alpha linux64) 19))) +;; END OPTIONS + (multiple-value-bind (old-value found) (gethash name *cold-foreign-symbol-table*) @@ -1612,13 +1663,28 @@ version))) (defun lookup-foreign-symbol (name) - (multiple-value-bind - (value found) - (gethash name *cold-foreign-symbol-table* 0) - (unless found - (warn "Undefined foreign symbol: ~S" name)) - value)) + (let ((is-linux (and (eq (c:backend-fasl-file-implementation c:*backend*) + #.c:x86-fasl-file-implementation) + (c:backend-featurep :linux)))) + + (cond + ((and is-linux (gethash (concatenate 'string "PVE_stub_" name) + *cold-foreign-symbol-table* nil))) + ;; Non-linux case + ((gethash name *cold-foreign-symbol-table* nil)) + ((and is-linux (gethash (concatenate 'string "__libc_" name) + *cold-foreign-symbol-table* nil))) + ((and is-linux (gethash (concatenate 'string "__" name) + *cold-foreign-symbol-table* nil))) + ((and is-linux (gethash (concatenate 'string "_" name) + *cold-foreign-symbol-table* nil))) + (t + (warn "Undefined foreign symbol: ~S" name) + 0)))) +;; FreeBSD wants C language symbols prefixed with "_" including all the +;; syscalls and Unix library things. Linux doesn't or maybe does +;; depending on things I don't know about yet? (defun lookup-maybe-prefix-foreign-symbol (name) (lookup-foreign-symbol (concatenate 'string @@ -1626,7 +1692,6 @@ ((#.c:pmax-fasl-file-implementation #.c:rt-fasl-file-implementation #.c:rt-afpa-fasl-file-implementation - #.c:x86-fasl-file-implementation #.c:hppa-fasl-file-implementation #.c:alpha-fasl-file-implementation #.c:sgi-fasl-file-implementation) @@ -1634,7 +1699,12 @@ (#.c:sparc-fasl-file-implementation (if (c:backend-featurep :svr4) "" - "_"))) + "_")) + (#.c:x86-fasl-file-implementation + (if (c:backend-featurep :freebsd) + "_" ; FreeBSD + "")) ; Linux + ) name))) (defvar *cold-assembler-routines* nil) diff --git a/compiler/generic/vm-ir2tran.lisp b/compiler/generic/vm-ir2tran.lisp index 730090f6e..15ec1a42a 100644 --- a/compiler/generic/vm-ir2tran.lisp +++ b/compiler/generic/vm-ir2tran.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-ir2tran.lisp,v 1.8 1994/10/31 04:38:06 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-ir2tran.lisp,v 1.9 1997/01/18 14:31:15 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -128,10 +128,6 @@ (continuation-tn node block rank) result)) (move-continuation-result node block locs cont))) -#+gengc -(setf (function-info-ltn-annotate (function-info-or-lose 'make-array-header)) - #'annotate-funny-call) - ;;;; Replacements for stuff in ir2tran to make gengc work. diff --git a/compiler/generic/vm-macs.lisp b/compiler/generic/vm-macs.lisp index 2c011a5fb..c49acd101 100644 --- a/compiler/generic/vm-macs.lisp +++ b/compiler/generic/vm-macs.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-macs.lisp,v 1.15 1994/10/31 04:38:06 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-macs.lisp,v 1.16 1997/01/18 14:31:15 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -186,8 +186,7 @@ (let ((info (function-info-or-lose name))) (setf (function-info-ir2-convert info) #'(lambda (node block) - (ir2-convert-reffer node block name offset lowtag))) - (setf (function-info-ltn-annotate info) #'annotate-funny-call)) + (ir2-convert-reffer node block name offset lowtag)))) name) (defmacro def-reffer (name offset lowtag) @@ -200,8 +199,7 @@ #'(lambda (node block) (ir2-convert-setfer node block name offset lowtag)) #'(lambda (node block) - (ir2-convert-setter node block name offset lowtag)))) - (setf (function-info-ltn-annotate info) #'annotate-funny-call)) + (ir2-convert-setter node block name offset lowtag))))) name) (defmacro def-setter (name offset lowtag) @@ -216,8 +214,7 @@ lowtag inits)) #'(lambda (node block) (ir2-convert-fixed-allocation node block name words header - lowtag inits)))) - (setf (function-info-ltn-annotate info) #'annotate-funny-call)) + lowtag inits))))) name) (defmacro def-alloc (name words variable-length header lowtag inits) @@ -244,8 +241,8 @@ ;;; one place to make sure they are all unique. (defparameter fasl-file-implementations - '(nil "Pmax" "Sparc" "RT" "RT/AFPA" "x86" "HPPA" "Alpha" "SGI" - "Big-endian byte-code" "Little-endian byte-code")) + '(nil "Pmax" "Sparc" "RT" "RT/AFPA" "x86" "HPPA" + "Big-endian byte-code" "Little-endian byte-code" "Alpha" "SGI")) (defconstant pmax-fasl-file-implementation 1) (defconstant sparc-fasl-file-implementation 2) (defconstant rt-fasl-file-implementation 3) diff --git a/compiler/generic/vm-tran.lisp b/compiler/generic/vm-tran.lisp index 28a920ec9..114a49cc4 100644 --- a/compiler/generic/vm-tran.lisp +++ b/compiler/generic/vm-tran.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-tran.lisp,v 1.34 1994/10/31 04:38:06 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-tran.lisp,v 1.35 1997/01/18 14:31:17 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -310,7 +310,7 @@ '(%sxhash-simple-string s-expr)) (deftransform sxhash ((s-expr) (symbol)) - (%sxhash-simple-string (symbol-name s-expr))) + '(%sxhash-simple-string (symbol-name s-expr))) (deftransform sxhash ((s-expr) (single-float)) '(let ((bits (single-float-bits s-expr))) diff --git a/compiler/ir2tran.lisp b/compiler/ir2tran.lisp index dfaab4676..09fbde5d9 100644 --- a/compiler/ir2tran.lisp +++ b/compiler/ir2tran.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir2tran.lisp,v 1.59 1994/10/31 04:27:28 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir2tran.lisp,v 1.60 1997/01/18 14:31:24 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1133,11 +1133,15 @@ (declare (type bind node) (type ir2-block block) (type clambda fun)) (let ((start-label (entry-info-offset (leaf-info fun))) (env (environment-info (node-environment node)))) - (vop xep-allocate-frame node block start-label) (let ((ef (functional-entry-function fun))) - (when (and (optional-dispatch-p ef) - (optional-dispatch-more-entry ef)) - (vop copy-more-arg node block (optional-dispatch-max-args ef))) + (if (and (optional-dispatch-p ef) + (optional-dispatch-more-entry ef)) + ;; Special case the xep-allocate-frame + copy-more-arg case. + (progn + (vop xep-allocate-frame node block start-label #+x86 t) + (vop copy-more-arg node block (optional-dispatch-max-args ef))) + ;; No more args, so normal entry. + (vop xep-allocate-frame node block start-label #+x86 nil)) (if (ir2-environment-environment env) (let ((closure diff --git a/compiler/loadcom.lisp b/compiler/loadcom.lisp index d91bb374b..5dbb23c5a 100644 --- a/compiler/loadcom.lisp +++ b/compiler/loadcom.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/loadcom.lisp,v 1.47 1994/10/31 04:27:28 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/loadcom.lisp,v 1.48 1997/01/18 14:31:36 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -25,7 +25,6 @@ (load "c:ir1util") (load "c:ir1tran") (load "c:ir1final") -(load "c:srctran") (load "c:array-tran") (load "c:seqtran") (load "c:typetran") @@ -33,6 +32,7 @@ (load "vm:vm-tran") (load "c:float-tran") (load "c:saptran") +(load "c:srctran") (load "c:locall") (load "c:dfo") (load "c:ir1opt") diff --git a/compiler/main.lisp b/compiler/main.lisp index de05e4c40..c7159ffa3 100644 --- a/compiler/main.lisp +++ b/compiler/main.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/main.lisp,v 1.107 1994/10/31 04:27:28 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/main.lisp,v 1.108 1997/01/18 14:31:32 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1712,12 +1712,14 @@ (error-severity nil) (source (verify-source-files source)) (source-info (make-file-source-info source)) - (default (pathname (first source)))) + (default (pathname (first source))) + (diddle-case (logical-pathname-p (pathname default)))) (unwind-protect (progn (flet ((frob (file type) (if (eq file t) - (make-pathname :type type :defaults default) + (make-pathname :type (lisp::maybe-diddle-case type diddle-case) + :defaults default) (pathname file)))) (when output-file diff --git a/compiler/new-assem.lisp b/compiler/new-assem.lisp index e4fb7c0ee..e9ae92b1c 100644 --- a/compiler/new-assem.lisp +++ b/compiler/new-assem.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/new-assem.lisp,v 1.25 1994/10/31 04:27:28 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/new-assem.lisp,v 1.26 1997/01/18 14:31:26 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -762,13 +762,16 @@ (:include annotation) (:conc-name alignment-) (:predicate alignment-p) - (:constructor make-alignment (bits size))) + (:constructor make-alignment (bits size fill-byte))) ;; ;; The minimum number of low-order bits that must be zero. (bits 0 :type alignment) ;; ;; The amount of filler we are assuming this alignment op will take. - (size 0 :type (integer 0 #.(1- (ash 1 max-alignment))))) + (size 0 :type (integer 0 #.(1- (ash 1 max-alignment)))) + ;; + ;; The byte used as filling. + (fill-byte 0 :type (or assembly-unit (signed-byte #.assembly-unit-bits)))) ;;; BACK-PATCH -- a reference to someplace that needs to be back-patched when ;;; we actually know what label positions, etc. are. @@ -913,12 +916,12 @@ ;;; EMIT-SKIP -- interface. ;;; -(defun emit-skip (segment amount) +(defun emit-skip (segment amount &optional (fill-byte 0)) "Output AMOUNT zeros (in bytes) to SEGMENT." (declare (type segment segment) (type index amount)) (dotimes (i amount) - (emit-byte segment 0)) + (emit-byte segment fill-byte)) (ext:undefined-value)) ;;; EMIT-ANNOTATION -- internal. @@ -1044,7 +1047,7 @@ ;;; number of bytes. If so, we do so. Otherwise, we create and emit ;;; an alignment note. ;;; -(defun emit-alignment (segment vop bits) +(defun emit-alignment (segment vop bits &optional (fill-byte 0)) (when (segment-run-scheduler segment) (schedule-pending-instructions segment)) (let ((hook (segment-inst-hook segment))) @@ -1059,12 +1062,12 @@ ;; note to cover the rest. (let ((slop (logand offset (1- (ash 1 alignment))))) (unless (zerop slop) - (emit-skip segment (- (ash 1 alignment) slop)))) + (emit-skip segment (- (ash 1 alignment) slop) fill-byte))) (let ((size (logand (1- (ash 1 bits)) (lognot (1- (ash 1 alignment)))))) (assert (> size 0)) - (emit-annotation segment (make-alignment bits size)) - (emit-skip segment size)) + (emit-annotation segment (make-alignment bits size fill-byte)) + (emit-skip segment size fill-byte)) (setf (segment-alignment segment) bits) (setf (segment-sync-posn segment) (segment-current-posn segment))) (t @@ -1073,10 +1076,10 @@ ;; the last alignment was met. (let* ((mask (1- (ash 1 bits))) (new-offset (logand (+ offset mask) (lognot mask)))) - (emit-skip segment (- new-offset offset))) + (emit-skip segment (- new-offset offset) fill-byte)) ;; But we emit an alignment with size=0 so we can verify ;; that everything works. - (emit-annotation segment (make-alignment bits 0))))) + (emit-annotation segment (make-alignment bits 0 fill-byte))))) (ext:undefined-value)) @@ -1179,7 +1182,8 @@ (setf (segment-fill-pointer segment) (system:int-sap 0)) (setf (segment-block-end segment) (system:int-sap 0)) (setf (segment-last-annotation segment) prev) - (emit-alignment segment nil (alignment-bits note)) + (emit-alignment segment nil (alignment-bits note) + (alignment-fill-byte note)) (let* ((new-index (segment-current-index segment)) (size (- new-index index)) (old-size (alignment-size note)) @@ -1374,9 +1378,9 @@ ;;; ALIGN -- interface. ;;; -(defmacro align (bits) +(defmacro align (bits &optional (fill-byte 0)) "Emit an alignment restriction to the current segment." - `(emit-alignment *current-segment* *current-vop* ,bits)) + `(emit-alignment *current-segment* *current-vop* ,bits ,fill-byte)) ;;; LABEL-POSITION -- interface. ;;; @@ -1399,7 +1403,9 @@ (setf (segment-postits segment) (segment-postits other-segment)) (dolist (postit postits) (emit-back-patch segment 0 postit))) - (emit-alignment segment nil max-alignment) + (if (c:backend-featurep :x86) + (emit-alignment segment nil max-alignment #x90) + (emit-alignment segment nil max-alignment)) (let ((offset-in-last-block (rem (segment-current-index segment) output-block-size))) (unless (zerop offset-in-last-block) diff --git a/compiler/pack.lisp b/compiler/pack.lisp index 6bf0c9ad4..e53ec2fa6 100644 --- a/compiler/pack.lisp +++ b/compiler/pack.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/pack.lisp,v 1.53 1994/10/31 04:27:28 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/pack.lisp,v 1.54 1997/01/18 14:31:27 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1118,6 +1118,17 @@ ;;; (defun select-load-tn-location (op sc) (declare (type tn-ref op) (type sc sc)) + + ;; Check any target location first. + (let ((target (tn-ref-target op))) + (when target + (let* ((tn (tn-ref-tn target)) + (loc (tn-offset tn))) + (when (and (eq (sc-sb sc) (sc-sb (tn-sc tn))) + (member (the index loc) (sc-locations sc)) + (not (load-tn-conflicts-in-sc op sc loc nil))) + (return-from select-load-tn-location loc))))) + (dolist (loc (sc-locations sc) nil) (unless (load-tn-conflicts-in-sc op sc loc nil) (return loc)))) @@ -1267,16 +1278,38 @@ (proclaim '(inline check-operand-restrictions)) (defun check-operand-restrictions (scs ops) (declare (list scs) (type (or tn-ref null) ops)) + + ;; Check the targeted operands first. + (do ((scs scs (cdr scs)) + (op ops (tn-ref-across op))) + ((null scs)) + (let ((target (tn-ref-target op))) + (when target + (let* ((load-tn (tn-ref-load-tn op)) + (load-scs (svref (car scs) + (sc-number + (tn-sc (or load-tn (tn-ref-tn op))))))) + (if load-tn + (assert (eq load-scs t)) + (unless (eq load-scs t) + (setf (tn-ref-load-tn op) + (pack-load-tn (car scs) op)))))))) + (do ((scs scs (cdr scs)) (op ops (tn-ref-across op))) ((null scs)) - (let* ((load-tn (tn-ref-load-tn op)) - (load-scs (svref (car scs) - (sc-number (tn-sc (or load-tn (tn-ref-tn op))))))) - (if load-tn - (assert (eq load-scs t)) - (unless (eq load-scs t) - (setf (tn-ref-load-tn op) (pack-load-tn (car scs) op)))))) + (let ((target (tn-ref-target op))) + (unless target + (let* ((load-tn (tn-ref-load-tn op)) + (load-scs (svref (car scs) + (sc-number + (tn-sc (or load-tn (tn-ref-tn op))))))) + (if load-tn + (assert (eq load-scs t)) + (unless (eq load-scs t) + (setf (tn-ref-load-tn op) + (pack-load-tn (car scs) op)))))))) + (undefined-value)) @@ -1528,12 +1561,48 @@ (unless (eq (sb-kind sb) :unbounded) (error "~S wired to a location that is out of bounds." tn)) (grow-sc sc end)) + + ;; For non x86 ports the presence of a save-tn associated with a + ;; tn is used to identify the old-fp and return-pc tns. It depends + ;; on the old-fp and return-pc being passed in registers. + (unless (backend-featurep :x86) + (when (and (not (eq (tn-kind tn) :specified-save)) + (conflicts-in-sc original sc offset)) + (error "~S wired to a location that it conflicts with." tn))) + + ;; Use the above check, but only print a verbose warning. Helpful + ;; for debugging the x86 port. + #+x86-debug-pack-wired-tn (when (and (not (eq (tn-kind tn) :specified-save)) (conflicts-in-sc original sc offset)) - (error "~S wired to a location that it conflicts with." tn)) + (format t "~&* Pack-wired-tn possible conflict:~% ~ + tn: ~s; tn-kind: ~s~% ~ + sc: ~s~% ~ + sb: ~s; sb-name: ~s; sb-kind: ~s~% ~ + offset: ~s; end: ~s~% ~ + original ~s~% ~ + tn-save-tn: ~s; tn-kind of tn-save-tn: ~s~%" + tn (tn-kind tn) sc + sb (sb-name sb) (sb-kind sb) + offset end + original + (tn-save-tn tn) (tn-kind (tn-save-tn tn)))) + + (when (backend-featurep :x86) + ;; On the x86 ports the old-fp and return-pc are often passed + ;; on the stack so the above hack for the other ports does not + ;; always work. Here the old-fp and return-pc tns are + ;; identified by being on the stack in their standard save + ;; locations. + (when (and (not (eq (tn-kind tn) :specified-save)) + (not (and (eq (sb-name sb) 'vm::stack) + (or (= offset 0) + (= offset 1)))) + (conflicts-in-sc original sc offset)) + (error "~S wired to a location that it conflicts with." tn))) + (add-location-conflicts original sc offset))) - (defevent repack-block "Repacked a block due to TN unpacking.") ;;; Pack -- Interface diff --git a/compiler/srctran.lisp b/compiler/srctran.lisp index 214b568ca..e0f3ba99c 100644 --- a/compiler/srctran.lisp +++ b/compiler/srctran.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.45 1994/10/31 04:27:28 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.46 1997/01/18 14:31:30 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -253,7 +253,256 @@ :low low :high high)) (numeric-contagion x y)))) +;;; Derive-Real-Type -- Internal +;;; +;;; Same as derive-integer-type except it can handle float types. +;;; This also contains derive-integer-type as a special case. +;;; +#+propagate-float-type +(defun derive-real-type (x y fun) + (declare (type continuation x y) (type function fun)) + (let ((x (continuation-type x)) + (y (continuation-type y))) + (derive-real-numeric-or-union-type x y fun))) + +#+propagate-float-type +(defun derive-real-numeric-or-union-type (x y fun) + (cond ((union-type-p x) + (let ((new-union '())) + (dolist (type (union-type-types x)) + (setf new-union (cons (derive-real-numeric-or-union-type + type y fun) new-union))) + (make-union-type (derive-merged-union-types new-union)))) + ((union-type-p y) + (let ((new-union '())) + (dolist (type (union-type-types y)) + (setf new-union (cons (derive-real-numeric-or-union-type + x type fun) new-union))) + (make-union-type (derive-merged-union-types new-union)))) + ((and (numeric-type-p x) (numeric-type-p y)) + (derive-simple-real-type x y fun)) + (t + (numeric-contagion x y)))) + +#+propagate-float-type +(defun merge-types-aux (tlist) + ;; Merge the first interval in the list with the rest of + ;; intervals in the list. The list of intervals MUST be + ;; sorted in ascending order of lower limits. + (let* ((cur (first tlist)) + (res (list cur))) + (multiple-value-bind (cur-lo cur-hi) + (extract-bounds cur) + (declare (ignore cur-lo)) + (dolist (type (rest tlist) + res) + (multiple-value-bind (type-lo type-hi) + (extract-bounds type) + (cond ((not (bound-< type-lo cur-hi)) + ;; Left limit of the current interval lies + ;; within our interval, so merge these two + ;; intervals into our interval. + (setf (numeric-type-high cur) + (nilify-bound (max-bound cur-hi type-hi)))) + (t + ;; Otherwise, we can't merge these two intervals + (setf res (cons type res))))))))) + +#+propagate-float-type +(defun merge-types (ilist &optional (result '())) + ;; Compare the first element with the rest to merge + ;; whatever we can into the first element. The first + ;; element is totally merged, so we only need to consider + ;; whatever is left. + (cond ((null ilist) + result) + ((cdr ilist) + (let ((new-types (merge-types-aux ilist))) + (merge-types (rest new-types) (cons (first new-types) result)))) + (t + (cons (first ilist) result)))) + +#+propagate-float-type +(defun derive-merged-union-types (types) + (labels ((interval-< (a b) + (multiple-value-bind (a-lo a-hi) + (extract-bounds a) + (declare (ignore a-hi)) + (multiple-value-bind (b-lo b-hi) + (extract-bounds b) + (declare (ignore b-hi)) + (bound-< a-lo b-lo))))) + (merge-types (sort types #'interval-<)))) + +#+propagate-float-type +(defun derive-simple-real-type (x y fun) + (declare (type numeric-type x y) (type function fun)) + (cond ((and (eq (numeric-type-class x) 'integer) + (eq (numeric-type-class y) 'integer) + (eq (numeric-type-complexp x) :real) + (eq (numeric-type-complexp y) :real)) + (multiple-value-bind (low high) + (funcall fun x y) + (make-numeric-type :class 'integer :complexp :real + :low low :high high))) + ((and (numeric-type-p x) (numeric-type-p y) + (eq (numeric-type-class x) 'float) + (eq (numeric-type-class y) 'float) + (eq (numeric-type-complexp x) :real) + (eq (numeric-type-complexp y) :real) + (eq (numeric-type-format x) (numeric-type-format y))) + ;; We have two floats of some kind. We will handle float + ;; contagion here instead of using the general + ;; numeric-contagion which loses the bounds on the numbers, + ;; if any. + (multiple-value-bind (low high) + (funcall fun x y) + (make-numeric-type + :class 'float + :format (float-format-max (numeric-type-format x) + (numeric-type-format y)) + :complexp :real + :low low :high high))) + (t + (numeric-contagion x y)))) + + +;;;; Helper methods for dealing with inclusive and exclusive bounds. + +;;; Return the value of a bound. Ignore the issue if the bound is +;;; inclusive or exclusive. If no bound is given, return nil (which +;;; is the bound value). + +(defun bound-value (bnd) + (if (consp bnd) + (car bnd) + bnd)) + +;;; Take a numeric argument and extract the bounds. If any bound is +;;; not given (nil), return the appropriate infinity instead. + +(defun extract-bounds (arg) + (let ((lo (numeric-type-low arg)) + (hi (numeric-type-high arg))) + ;; Replace nil values with the appropriate bound + (values (or lo 'neg-inf) + (or hi 'pos-inf)))) + +;;; Convert a bound from extract-bounds to be either the bound or nil. + +(defun nilify-bound (b) + (if (symbolp b) + nil + b)) + +(defun set-bound (val exclusive) + (if exclusive + `(,val) + val)) + +(defun bound-< (x y) + (cond ((eq x 'pos-inf) + nil) + ((eq x 'neg-inf) + (not (eq y 'neg-inf))) + (t + ;; x is some number + (if (symbolp y) + (not (bound-< y x)) + ;; Both x and y are numbers + (let ((xbnd (bound-value x)) + (ybnd (bound-value y))) + (or (< xbnd ybnd) + ;; If the bounds are equal, we need to check if the + ;; bounds are exclusive. The result is true if x is + ;; an inclusive bound but y is not. + (and (= xbnd ybnd) + (numberp x) + (consp y)))))))) + +;;; Determine if a bound is less than zero + +(defun bound-minusp (b) + (bound-< b 0)) + +;;; Determine if a bound is greater than zero + +(defun bound-plusp (b) + (not (bound-< b 0))) + +;;; Find the sign of a bound + +(defun bound-sign (x) + (cond ((eq x 'neg-inf) + -1) + ((eq x 'pos-inf) + 1) + (t + (signum (bound-value x))))) + +;;; Compute the product of two bounds + +(defun bound-prod (x y) + (cond ((or (symbolp x) (symbolp y)) + ;; One of the numbers is infinity. The result is also infinity. + (if (minusp (* (bound-sign x) (bound-sign y))) + 'neg-inf + 'pos-inf)) + (t + ;; The limits are numbers. + (let ((res (* (bound-value x) (bound-value y)))) + (set-bound res (or (consp x) (consp y))))))) + +;;; Compute the quotient of two bounds + +(defun bound-quot (x y) + (cond ((symbolp x) + ;; Infinity divided by anything will be infinity + (bound-prod x y)) + ((symbolp y) + ;; A number divided by infinity is always 0 + 0) + (t + ;; At this point we have the ratio of two numbers. Watch out + ;; for division by zero! + (cond ((zerop (bound-value y)) + (if (bound-minusp x) + 'neg-inf + 'pos-inf)) + (t + (let ((res (/ (bound-value x) (bound-value y)))) + (set-bound res (or (consp x) (consp y))))))))) + +;;; Compute the absolute value of a bound. + +(defun bound-abs (x) + (if (symbolp x) + 'pos-inf + (set-bound (abs (bound-value x)) (consp x)))) + +;;; Given a list of float bounds, find the maximum. If the maximum is +;;; infinity, return nil instead. + +(defun max-bound (x y) + (if (bound-< x y) + y + x)) + +(defun min-bound (x y) + (if (bound-< x y) + x + y)) + +(defun max-bound-list (lst) + (nilify-bound (reduce #'max-bound lst))) + +(defun min-bound-list (lst) + (nilify-bound (reduce #'min-bound lst))) + + + +#-propagate-float-type (defoptimizer (+ derive-type) ((x y)) (derive-integer-type x y @@ -265,6 +514,29 @@ (values (frob (numeric-type-low x) (numeric-type-low y)) (frob (numeric-type-high x) (numeric-type-high y))))))) +#+propagate-float-type +(defoptimizer (+ derive-type) ((x y)) + (derive-real-type + x y + #'(lambda (x y) + (labels ((frob (x y) + (if (and x y) + (set-bound (+ (bound-value x) (bound-value y)) + (or (consp x) (consp y))) + nil))) + #| + (debug:backtrace) + (format t "~%+-derive: ~s ~s~%" x y) + (format t "to ~s ~s~%" + (frob (numeric-type-low x) (numeric-type-low y)) + (frob (numeric-type-high x) (numeric-type-high y))) + |# + + (values (frob (numeric-type-low x) (numeric-type-low y)) + (frob (numeric-type-high x) (numeric-type-high y))))))) + + +#-propagate-float-type (defoptimizer (- derive-type) ((x y)) (derive-integer-type x y @@ -276,6 +548,20 @@ (values (frob (numeric-type-low x) (numeric-type-high y)) (frob (numeric-type-high x) (numeric-type-low y))))))) +#+propagate-float-type +(defoptimizer (- derive-type) ((x y)) + (derive-real-type + x y + #'(lambda (x y) + (labels ((frob (x y) + (if (and x y) + (set-bound (- (bound-value x) (bound-value y)) + (or (consp x) (consp y))) + nil))) + (values (frob (numeric-type-low x) (numeric-type-high y)) + (frob (numeric-type-high x) (numeric-type-low y))))))) + +#-propagate-float-type (defoptimizer (* derive-type) ((x y)) (derive-integer-type x y @@ -298,9 +584,80 @@ (* x-high y-high) nil)))))))) +#+propagate-float-type +(defoptimizer (* derive-type) ((x y)) + (let ((same-arg (same-leaf-ref-p x y))) + (derive-real-type + x y + #'(lambda (x y) + (multiple-value-bind (x-low x-high) + (extract-bounds x) + (cond (same-arg + (let ((new-limits (list (bound-prod x-low x-low) + (bound-prod x-high x-high)))) + ;; There are two cases to handle: 0 is in + ;; the range and 0 is not. + (cond ((and (bound-minusp x-low) + (bound-plusp x-high)) + ;; The low limit is 0 and the high + ;; is the max of the square of the + ;; bounds. + (values 0 + (max-bound-list new-limits))) + (t + ;; Since zero is not within the + ;; range, the answer is obvious + (values (min-bound-list new-limits) + (max-bound-list new-limits)))))) + (t + (multiple-value-bind (y-low y-high) + (extract-bounds y) + (let ((new-limits (list (bound-prod x-low y-low) + (bound-prod x-low y-high) + (bound-prod x-high y-low) + (bound-prod x-high y-high)))) + (values (min-bound-list new-limits) + (max-bound-list new-limits))))))))))) + + + +#-propagate-float-type (defoptimizer (/ derive-type) ((x y)) (numeric-contagion (continuation-type x) (continuation-type y))) +#+propagate-float-type +(defoptimizer (/ derive-type) ((top bot)) + ;; We only handle the case where both of the arguments are + ;; floats. Otherwise, the general numeric contagion holds. + + (let ((x-num (continuation-type top)) + (y-num (continuation-type bot))) + (if (not (and (numeric-type-p x-num) (numeric-type-p y-num) + (eq (numeric-type-complexp x-num) :real) + (eq (numeric-type-complexp y-num) :real) + (eq (numeric-type-class x-num) 'float) + (eq (numeric-type-class y-num) 'float))) + (numeric-contagion x-num y-num) + (derive-real-type + top bot + #'(lambda (x y) + (multiple-value-bind (y-low y-high) + (extract-bounds y) + (cond ((and (bound-minusp y-low) + (bound-plusp y-high)) + ;; If 0 is within the bounds of y, the result is + ;; clear: any float is possible for the quotient. + (values nil nil)) + (t + (multiple-value-bind (x-low x-high) + (extract-bounds x) + (let ((new-limits (list (bound-quot x-low y-low) + (bound-quot x-low y-high) + (bound-quot x-high y-low) + (bound-quot x-high y-high)))) + (values (min-bound-list new-limits) + (max-bound-list new-limits)))))))))))) + (defoptimizer (ash derive-type) ((n shift)) (or (let ((n-type (continuation-type n))) @@ -334,6 +691,7 @@ *universal-type*)) +#-propagate-float-type (macrolet ((frob (fun) `#'(lambda (type type2) (declare (ignore type2)) @@ -347,7 +705,24 @@ (defoptimizer (lognot derive-type) ((int)) (derive-integer-type int int (frob lognot)))) +#+propagate-float-type +(macrolet ((frob (fun) + `#'(lambda (type type2) + (declare (ignore type2)) + (let ((lo (numeric-type-low type)) + (hi (numeric-type-high type))) + (values (if hi (,fun hi) nil) (if lo (,fun lo) nil)))))) + + (defoptimizer (%negate derive-type) ((num)) + (flet ((negate-bound (b) + (set-bound (- (bound-value b)) (consp b)))) + (derive-real-type num num (frob negate-bound)))) + (defoptimizer (lognot derive-type) ((int)) + (derive-integer-type int int (frob lognot)))) + + +#-propagate-float-type (defoptimizer (abs derive-type) ((num)) (let ((type (continuation-type num))) (if (and (numeric-type-p type) @@ -367,7 +742,40 @@ nil))) (numeric-contagion type type)))) - +#+propagate-float-type +(defoptimizer (abs derive-type) ((num)) + (let ((type (continuation-type num))) + (when (numeric-type-p type) + (cond ((eq (numeric-type-complexp type) :complex) + ;; The absolute value of a complex number is always a + ;; non-negative float. + (make-numeric-type :class 'float + :format (elfun-float-format (numeric-type-format type)) + :complexp :real + :low 0 + :high nil)) + ((eq (numeric-type-complexp type) :real) + ;; The absolute value of a real number is a non-negative + ;; real of the same type. + (let ((lo (numeric-type-low type)) + (hi (numeric-type-high type))) + (make-numeric-type :class (numeric-type-class type) + :format (numeric-type-format type) + :complexp :real + :low (cond ((and hi (minusp (bound-value hi))) + (bound-abs hi)) + (lo + (set-bound (max 0 (bound-value lo)) + (consp lo))) + (t + 0)) + :high (if (and hi lo) + (max-bound-list (list (bound-abs hi) + (bound-abs lo))) + nil)))))))) + + +;; ;; bugged below?? #-propagate-float-type) (defoptimizer (truncate derive-type) ((number divisor)) (let ((number-type (continuation-type number)) (divisor-type (continuation-type divisor)) @@ -387,6 +795,54 @@ divisor-low divisor-high)))) *universal-type*))) +#+propagate-float-type +(progn +#+nil +(defoptimizer (truncate derive-type) ((number divisor)) + (let ((number-type (continuation-type number)) + (divisor-type (continuation-type divisor)) + (integer-type (specifier-type '(or integer real)))) + (if (and (numeric-type-p number-type) + (csubtypep number-type integer-type) + (numeric-type-p divisor-type) + (csubtypep divisor-type integer-type)) + (let ((number-low (numeric-type-low number-type)) + (number-high (numeric-type-high number-type)) + (divisor-low (numeric-type-low divisor-type)) + (divisor-high (numeric-type-high divisor-type))) + (setf number-low (if (consp number-low) (car number-low) number-low)) + (setf number-high (if (consp number-high) (car number-high) number-high)) + (setf divisor-low (if (consp divisor-low) (car divisor-low) divisor-low)) + (setf divisor-high (if (consp divisor-high) (car divisor-high) divisor-high)) + (if (csubtypep number-type (specifier-type 'integer)) + (values-specifier-type + `(values ,(integer-truncate-derive-type number-low number-high + divisor-low divisor-high) + ,(integer-rem-derive-type number-low number-high + divisor-low divisor-high))) + (values-specifier-type + `(values ,(integer-truncate-derive-type number-low number-high + divisor-low divisor-high) + ,(real-rem-derive-type number-low number-high + divisor-low divisor-high))))) + *universal-type*))) + +(defoptimizer (%unary-truncate derive-type) ((number)) + (let ((number-type (continuation-type number))) + (if (and (numeric-type-p number-type) + (csubtypep number-type (specifier-type 'real))) + (let ((number-low (numeric-type-low number-type)) + (number-high (numeric-type-high number-type))) + (setf number-low (if (consp number-low) (car number-low) number-low)) + (setf number-high (if (consp number-high) (car number-high) number-high)) + (values-specifier-type + `(values ,(integer-truncate-derive-type number-low number-high 1 1) + ,(real-rem-derive-type number-low number-high 1 1)))) + *universal-type*))) +) + + + ;;; NUMERIC-RANGE-INFO -- internal. ;;; ;;; Derive useful information about the range. Returns three values: @@ -404,6 +860,7 @@ ;;; INTEGER-TRUNCATE-DERIVE-TYPE -- internal ;;; +#-propagate-float-type (defun integer-truncate-derive-type (number-low number-high divisor-low divisor-high) ;; The result cannot be larger in magnitude than the number, but the sign @@ -467,7 +924,7 @@ ;; The number we are dividing is unbounded, so we can't tell ;; anything about the result. 'integer))))) - + (defun integer-rem-derive-type (number-low number-high divisor-low divisor-high) (if (and divisor-low divisor-high) @@ -497,6 +954,106 @@ 0 '*)))) +#+propagate-float-type +(progn +(defun integer-truncate-derive-type + (number-low number-high divisor-low divisor-high) + ;; The result cannot be larger in magnitude than the number, but the sign + ;; might change. If we can determine the sign of either the number or + ;; the divisor, we can eliminate some of the cases. + (multiple-value-bind + (number-sign number-min number-max) + (numeric-range-info number-low number-high) + (multiple-value-bind + (divisor-sign divisor-min divisor-max) + (numeric-range-info divisor-low divisor-high) + (when (and divisor-max (zerop divisor-max)) + ;; We've got a problem: guarenteed division by zero. + (return-from integer-truncate-derive-type t)) + (when (zerop divisor-min) + ;; We'll assume that they arn't going to divide by zero. + (if (integerp divisor-min) + (incf divisor-min) + (incf divisor-min (if (typep divisor-min 'single-float) + least-positive-normalized-single-float + least-positive-normalized-double-float)))) + (cond ((and number-sign divisor-sign) + ;; We know the sign of both. + (if (eq number-sign divisor-sign) + ;; Same sign, so the result will be positive. + `(integer ,(if divisor-max + (truncate number-min divisor-max) + 0) + ,(if number-max + (truncate number-max divisor-min) + '*)) + ;; Different signs, the result will be negative. + `(integer ,(if number-max + (- (truncate number-max divisor-min)) + '*) + ,(if divisor-max + (- (truncate number-min divisor-max)) + 0)))) + ((eq divisor-sign '+) + ;; The divisor is positive. Therefore, the number will just + ;; become closer to zero. + `(integer ,(if number-low + (truncate number-low divisor-min) + '*) + ,(if number-high + (truncate number-high divisor-min) + '*))) + ((eq divisor-sign '-) + ;; The divisor is negative. Therefore, the absolute value of + ;; the number will become closer to zero, but the sign will also + ;; change. + `(integer ,(if number-high + (- (truncate number-high divisor-min)) + '*) + ,(if number-low + (- (truncate number-low divisor-min)) + '*))) + ;; The divisor could be either positive or negative. + (number-max + ;; The number we are dividing has a bound. Divide that by the + ;; smallest posible divisor. + (let ((bound (truncate number-max divisor-min))) + `(integer ,(- bound) ,bound))) + (t + ;; The number we are dividing is unbounded, so we can't tell + ;; anything about the result. + 'integer))))) + +(defun real-rem-derive-type + (number-low number-high divisor-low divisor-high) + (if (and divisor-low divisor-high) + ;; We know the range of the divisor, and the remainder must be smaller + ;; than the divisor. We can tell the sign of the remainer if we know + ;; the sign of the number. + (let ((divisor-max (float (max (abs divisor-low) (abs divisor-high))))) + `(float ,(if (or (null number-low) + (minusp number-low)) + (- divisor-max) + 0.0) + ,(if (or (null number-high) + (plusp number-high)) + divisor-max + 0.0))) + ;; The divisor is potentially either very positive or very negative. + ;; Therefore, the remainer is unbounded, but we might be able to tell + ;; something about the sign from the number. + `(float ,(if (and number-low (not (minusp number-low))) + ;; The number we are dividing is positive. Therefore, + ;; the remainder must be positive. + 0.0 + '*) + ,(if (and number-high (not (plusp number-high))) + ;; The number we are dividing is negative. Therefore, + ;; the remainder must be negative. + 0.0 + '*)))) +) + (defoptimizer (random derive-type) ((bound &optional state)) (let ((type (continuation-type bound))) (when (numeric-type-p type) @@ -1281,6 +1838,7 @@ ;;; Y's high, the X >= Y (so return NIL). If not, at least make sure any ;;; constant arg is second. ;;; +#-propagate-float-type (defun ir1-transform-< (x y first second inverse) (if (same-leaf-ref-p x y) 'nil @@ -1300,6 +1858,28 @@ (t (give-up)))))) +#+propagate-float-type +(defun ir1-transform-< (x y first second inverse) + (if (same-leaf-ref-p x y) + 'nil + (let* ((x-type (numeric-type-or-lose x)) + (y-type (numeric-type-or-lose y))) + #+nil + (format t "ir1-trans-<:~% ~s~% ~s~%" x-type y-type) + (multiple-value-bind (x-lo x-hi) + (extract-bounds x-type) + (multiple-value-bind (y-lo y-hi) + (extract-bounds y-type) + (cond ((bound-< x-hi y-lo) + 't) + ((bound-< y-hi x-lo) + 'nil) + ((and (constant-continuation-p first) + (not (constant-continuation-p second))) + `(,inverse y x)) + (t + (give-up)))))))) + (deftransform < ((x y) (integer integer) * :when :both) (ir1-transform-< x y x y '>)) @@ -1307,6 +1887,15 @@ (deftransform > ((x y) (integer integer) * :when :both) (ir1-transform-< y x x y '<)) +#+propagate-float-type +(deftransform < ((x y) (float float) * :when :both) + (ir1-transform-< x y x y '>)) + +#+propagate-float-type +(deftransform > ((x y) (float float) * :when :both) + (ir1-transform-< y x x y '<)) + + ;;;; Converting N-arg comparisons: ;;; @@ -1546,3 +2135,6 @@ (declare (ignore tee)) (funcall control *standard-output* ,@arg-names) nil))) + + + diff --git a/compiler/x86/alloc.lisp b/compiler/x86/alloc.lisp new file mode 100644 index 000000000..0f8729efc --- /dev/null +++ b/compiler/x86/alloc.lisp @@ -0,0 +1,268 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/alloc.lisp,v 1.1 1997/01/18 14:31:20 ram Exp $") +;;; +;;; ********************************************************************** +;;; +;;; Allocation VOPs for the x86 port. +;;; +;;; Written by William Lott. +;;; +;;; Debugged by Paul F. Werkowski Spring/Summer 1995. +;;; + +(in-package :x86) + + +;;;; LIST and LIST* + +(define-vop (list-or-list*) + (:args (things :more t)) + (:temporary (:sc dword-reg) ptr temp) + (:temporary (:sc dword-reg :to (:result 0) :target result) res) + (:info num) + (:results (result :scs (descriptor-reg))) + (:variant-vars star) + (:policy :safe) + (:generator 0 + (cond ((zerop num) + ;; (move result nil-value) + (inst mov result nil-value)) + ((and star (= num 1)) + (move result (tn-ref-tn things))) + (t + (macrolet + ((store-car (tn list &optional (slot vm:cons-car-slot)) + `(let ((reg + (sc-case ,tn + ((any-reg descriptor-reg) ,tn) + ((descriptor-stack immediate-stack) + (move temp ,tn) + temp)))) + (storew reg ,list ,slot vm:list-pointer-type)))) + (let ((cons-cells (if star (1- num) num))) + #-cgc + (with-allocation (temp) + (inst lea res + (make-ea :byte :base temp :disp list-pointer-type)) + (inst add temp (* (pad-data-block cons-size) cons-cells))) + #+cgc + (with-cgc-allocation (temp (* (pad-data-block cons-size) + cons-cells)) + (inst lea res + (make-ea :byte :base temp :disp list-pointer-type))) + (move ptr res) + (dotimes (i (1- cons-cells)) + (store-car (tn-ref-tn things) ptr) + (setf things (tn-ref-across things)) + (inst add ptr (pad-data-block cons-size)) + (storew ptr ptr (- cons-cdr-slot cons-size) + list-pointer-type)) + (store-car (tn-ref-tn things) ptr) + (cond (star + (setf things (tn-ref-across things)) + (store-car (tn-ref-tn things) ptr cons-cdr-slot)) + (t + (storew nil-value ptr cons-cdr-slot + list-pointer-type))) + (assert (null (tn-ref-across things))))) + (move result res))))) + +(define-vop (list list-or-list*) + (:variant nil)) + +(define-vop (list* list-or-list*) + (:variant t)) + + +;;;; Special purpose inline allocators. + +(define-vop (allocate-code-object) + (:args (boxed-arg :scs (any-reg) :target boxed) + (unboxed-arg :scs (any-reg) :target unboxed)) + (:results (result :scs (descriptor-reg))) + (:temporary (:sc dword-reg :from :eval) temp) + (:temporary (:sc dword-reg :from (:argument 0)) boxed) + (:temporary (:sc dword-reg :from (:argument 1)) unboxed) + (:generator 100 + (move boxed boxed-arg) + (inst add boxed (fixnum (1+ code-trace-table-offset-slot))) + (inst and boxed (lognot lowtag-mask)) + (move unboxed unboxed-arg) + (inst shr unboxed word-shift) + (inst add unboxed lowtag-mask) + (inst and unboxed (lognot lowtag-mask)) + #+nil ;; keep this here in case we load code in dynamic again + (with-allocation (temp) + (inst lea result (make-ea :byte :base temp :disp other-pointer-type)) + (inst add temp boxed) + (inst add temp unboxed)) + (progn ;; now loading code into static space cause it can't move + (load-symbol-value temp lisp::*static-space-free-pointer*) + (inst lea result (make-ea :byte :base temp :disp other-pointer-type)) + (inst add temp boxed) + (inst add temp unboxed) + (store-symbol-value temp lisp::*static-space-free-pointer*)) + (inst shl boxed (- type-bits word-shift)) + (inst or boxed code-header-type) + (storew boxed result 0 other-pointer-type) + (storew unboxed result code-code-size-slot other-pointer-type) + ;; (move temp nil-value) + (inst mov temp nil-value) + (storew temp result code-entry-points-slot other-pointer-type) + (storew temp result code-debug-info-slot other-pointer-type))) + +;;; Top-Level-Forms have a short lifetime as they are unreachable +;;; once the loader eval's them. No point loading them in static +;;; space. This justs gives the loader a way to grab a chunk +;;; of the dynamic heap. +(define-vop (allocate-dynamic-code-object) + (:args (boxed-arg :scs (any-reg) :target boxed) + (unboxed-arg :scs (any-reg) :target unboxed)) + (:results (result :scs (descriptor-reg))) + (:temporary (:sc dword-reg :from :eval) temp) + (:temporary (:sc dword-reg :from (:argument 0)) boxed) + (:temporary (:sc dword-reg :from (:argument 1)) unboxed) + (:generator 100 + (move boxed boxed-arg) + (inst add boxed (fixnum (1+ code-trace-table-offset-slot))) + (inst and boxed (lognot lowtag-mask)) + (move unboxed unboxed-arg) + (inst shr unboxed word-shift) + (inst add unboxed lowtag-mask) + (inst and unboxed (lognot lowtag-mask)) + #-cgc + (with-allocation (temp) + (inst lea result (make-ea :byte :base temp :disp other-pointer-type)) + (inst add temp boxed) + (inst add temp unboxed)) + #+cgc + (progn + (move temp boxed) + (inst add temp unboxed) + (with-cgc-allocation (temp temp) + (inst lea result (make-ea :byte :base temp :disp other-pointer-type)))) + (inst shl boxed (- type-bits word-shift)) + (inst or boxed code-header-type) + (storew boxed result 0 other-pointer-type) + (storew unboxed result code-code-size-slot other-pointer-type) + (inst mov temp nil-value) + (storew temp result code-entry-points-slot other-pointer-type) + (storew temp result code-debug-info-slot other-pointer-type))) + +(define-vop (make-fdefn) + (:policy :fast-safe) + (:translate make-fdefn) + (:args (name :scs (descriptor-reg) :to :eval)) + (:temporary (:sc dword-reg) alloc) + (:results (result :scs (descriptor-reg) :from :argument)) + (:generator 37 + (with-fixed-allocation (result alloc fdefn-type fdefn-size) + (storew name result fdefn-name-slot other-pointer-type) + (storew nil-value result fdefn-function-slot other-pointer-type) + (storew (make-fixup (extern-alien-name "undefined_tramp") :foreign) result + fdefn-raw-addr-slot other-pointer-type)))) + + +(define-vop (make-closure) + (:args (function :to :save :scs (descriptor-reg))) + (:info length) + (:temporary (:sc any-reg) temp) + (:results (result :scs (descriptor-reg))) + (:generator 10 + (let ((size (+ length closure-info-offset))) + #-cgc + (with-allocation (temp) + (inst lea result (make-ea :byte :base temp :disp function-pointer-type)) + (inst add temp (pad-data-block size)) + (storew 0 temp 0) + (storew (logior (ash (1- size) type-bits) closure-header-type) + result 0 function-pointer-type)) + #+cgc + (with-cgc-allocation(temp (pad-data-block size)) + (inst lea result + (make-ea :byte :base temp :disp function-pointer-type)) + (storew (logior (ash (1- size) type-bits) closure-header-type) + temp 0)) + + (loadw temp function closure-function-slot function-pointer-type) + (storew temp result closure-function-slot function-pointer-type)))) + +;;; The compiler likes to be able to directly make value cells. +;;; +(define-vop (make-value-cell) + (:args (value :to :save :scs (descriptor-reg any-reg))) + (:temporary (:sc any-reg) temp) + (:results (result :scs (descriptor-reg))) + (:generator 10 + (with-fixed-allocation + (result temp value-cell-header-type value-cell-size)) + (storew value result value-cell-value-slot other-pointer-type))) + + + +;;;; Automatic allocators for primitive objects. + +(define-vop (make-unbound-marker) + (:args) + (:results (result :scs (any-reg))) + (:generator 1 + (inst mov result unbound-marker-type))) + +(define-vop (fixed-alloc) + (:args) + (:info name words type lowtag) + (:ignore name) + (:results (result :scs (descriptor-reg))) + (:temporary (:sc descriptor-reg) temp) + (:generator #-cgc 4 #+cgc 50 + #-cgc + (with-allocation(temp) ; dynamic free ptr + (inst lea result (make-ea :byte :base temp :disp lowtag)) + (inst add temp (pad-data-block words)) + (storew 0 temp 0 0)) + #+cgc + (with-cgc-allocation(temp (pad-data-block words)) + (inst lea result (make-ea :byte :base temp :disp lowtag))) + + (when type ; dunno what this does yet + (inst mov temp (logior (ash (1- words) type-bits) type)) + (storew temp result 0 lowtag)))) + +(define-vop (var-alloc) + (:args (extra :scs (any-reg))) + (:arg-types positive-fixnum) + (:info name words type lowtag) + (:ignore name) + (:results (result :scs (descriptor-reg))) + (:temporary (:sc any-reg) bytes header alloc) + (:generator #-cgc 6 #+cgc 50 + (inst lea bytes + (make-ea :dword :base extra :disp (* (1+ words) word-bytes))) + (inst mov header bytes) + (inst shl header (- type-bits 2)) ; w+1 to length field + + (inst lea header ; (w-1 << 8) | type + (make-ea :dword :base header :disp (+ (ash -2 type-bits) type))) + (inst and bytes (lognot lowtag-mask)) + #-cgc + (with-allocation (alloc) + (inst lea result (make-ea :byte :base alloc :disp lowtag)) + (storew header result 0 lowtag) + (inst add alloc bytes) + (storew 0 alloc 0)) + ;; Note that the above inst stores into the free space which + ;; is probably already zeroed. It is a lose in the cgc case because + ;; it might trash the next region header. + #+cgc + (with-cgc-allocation (alloc bytes) + (inst lea result (make-ea :byte :base alloc :disp lowtag)) + (storew header result 0 lowtag)))) + diff --git a/compiler/x86/arith.lisp b/compiler/x86/arith.lisp new file mode 100644 index 000000000..cebeffede --- /dev/null +++ b/compiler/x86/arith.lisp @@ -0,0 +1,1047 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/arith.lisp,v 1.1 1997/01/18 14:31:24 ram Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the VM definition arithmetic VOPs for the x86. +;;; +;;; Written by William Lott. +;;; +;;; Debugged by Paul F. Werkowski Spring/Summer 1995. +;;; + +(in-package :x86) + + + +;;;; Unary operations. + +(define-vop (fast-safe-arith-op) + (:policy :fast-safe) + (:effects) + (:affected)) + + +(define-vop (fixnum-unop fast-safe-arith-op) + (:args (x :scs (any-reg) :target res)) + (:results (res :scs (any-reg))) + (:note "inline fixnum arithmetic") + (:arg-types tagged-num) + (:result-types tagged-num)) + +(define-vop (signed-unop fast-safe-arith-op) + (:args (x :scs (signed-reg) :target res)) + (:results (res :scs (signed-reg))) + (:note "inline (signed-byte 32) arithmetic") + (:arg-types signed-num) + (:result-types signed-num)) + +(define-vop (fast-negate/fixnum fixnum-unop) + (:translate %negate) + (:generator 1 + (move res x) + (inst neg res))) + +(define-vop (fast-negate/signed signed-unop) + (:translate %negate) + (:generator 2 + (move res x) + (inst neg res))) + +(define-vop (fast-lognot/fixnum fixnum-unop) + (:translate lognot) + (:generator 2 + (move res x) + (inst xor res (fixnum -1)))) + +(define-vop (fast-lognot/signed signed-unop) + (:translate lognot) + (:generator 1 + (move res x) + (inst not res))) + + + +;;;; Binary fixnum operations. + +;;; Assume that any constant operand is the second arg... + +(define-vop (fast-fixnum-binop fast-safe-arith-op) + (:args (x :target r :scs (any-reg) + :load-if (not (and (sc-is x immediate-stack) + (sc-is y any-reg) + (location= x r)))) + (y :scs (any-reg immediate-stack))) + (:arg-types tagged-num tagged-num) + (:results (r :scs (any-reg) :from (:argument 0) + :load-if (not (and (sc-is x immediate-stack) + (sc-is y any-reg) + (location= x r))))) + (:result-types tagged-num) + (:note "inline fixnum arithmetic")) + +(define-vop (fast-unsigned-binop fast-safe-arith-op) + (:args (x :target r :scs (unsigned-reg) + :load-if (not (and (sc-is x unsigned-stack) + (sc-is y unsigned-reg) + (location= x r)))) + (y :scs (unsigned-reg unsigned-stack))) + (:arg-types unsigned-num unsigned-num) + (:results (r :scs (unsigned-reg) :from (:argument 0) + :load-if (not (and (sc-is x unsigned-stack) + (sc-is y unsigned-reg) + (location= x r))))) + (:result-types unsigned-num) + (:note "inline (unsigned-byte 32) arithmetic")) + +(define-vop (fast-signed-binop fast-safe-arith-op) + (:args (x :target r :scs (signed-reg) + :load-if (not (and (sc-is x signed-stack) + (sc-is y signed-reg) + (location= x r)))) + (y :scs (signed-reg signed-stack))) + (:arg-types signed-num signed-num) + (:results (r :scs (signed-reg) :from (:argument 0) + :load-if (not (and (sc-is x signed-stack) + (sc-is y signed-reg) + (location= x r))))) + (:result-types signed-num) + (:note "inline (signed-byte 32) arithmetic")) + +(define-vop (fast-fixnum-binop-c fast-safe-arith-op) + (:args (x :target r :scs (any-reg immediate-stack))) + (:info y) + (:arg-types tagged-num (:constant (signed-byte 30))) + (:results (r :scs (any-reg) + :load-if (not (location= x r)))) + (:result-types tagged-num) + (:note "inline fixnum arithmetic")) + +(define-vop (fast-unsigned-binop-c fast-safe-arith-op) + (:args (x :target r :scs (unsigned-reg unsigned-stack))) + (:info y) + (:arg-types unsigned-num (:constant (unsigned-byte 32))) + (:results (r :scs (unsigned-reg) + :load-if (not (location= x r)))) + (:result-types unsigned-num) + (:note "inline (unsigned-byte 32) arithmetic")) + +(define-vop (fast-signed-binop-c fast-safe-arith-op) + (:args (x :target r :scs (signed-reg signed-stack))) + (:info y) + (:arg-types signed-num (:constant (signed-byte 32))) + (:results (r :scs (signed-reg) + :load-if (not (location= x r)))) + (:result-types signed-num) + (:note "inline (signed-byte 32) arithmetic")) + + +(eval-when (compile load eval) + +(defmacro define-binop (translate untagged-penalty op) + `(progn + (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM") + fast-fixnum-binop) + (:translate ,translate) + (:generator 2 + (move r x) + (inst ,op r y))) + (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum) + fast-fixnum-binop-c) + (:translate ,translate) + (:generator 1 + (move r x) + (inst ,op r (fixnum y)))) + (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED") + fast-signed-binop) + (:translate ,translate) + (:generator ,(1+ untagged-penalty) + (move r x) + (inst ,op r y))) + (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed) + fast-signed-binop-c) + (:translate ,translate) + (:generator ,untagged-penalty + (move r x) + (inst ,op r y))) + (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED") + fast-unsigned-binop) + (:translate ,translate) + (:generator ,(1+ untagged-penalty) + (move r x) + (inst ,op r y))) + (define-vop (,(symbolicate 'fast- translate '-c/unsigned=>unsigned) + fast-unsigned-binop-c) + (:translate ,translate) + (:generator ,untagged-penalty + (move r x) + (inst ,op r y))))) + +); eval-when + + + +;(define-binop + 4 add) +(define-binop - 4 sub) +(define-binop logand 2 and) +(define-binop logior 2 or) +(define-binop logxor 2 xor) + + +;;; Special handling of add on the x86; can use lea to avoid a +;;; register load, otherwise it uses add. +(define-vop (fast-+/fixnum=>fixnum fast-safe-arith-op) + (:translate +) + (:args (x :target r :scs (any-reg) + :load-if (not (and (sc-is x immediate-stack) + (sc-is y any-reg) + (location= x r)))) + (y :scs (any-reg immediate-stack))) + (:arg-types tagged-num tagged-num) + (:results (r :scs (any-reg) :from (:argument 0) + :load-if (not (and (sc-is x immediate-stack) + (sc-is y any-reg) + (location= x r))))) + (:result-types tagged-num) + (:note "inline fixnum arithmetic") + (:generator 2 + (if (and (sc-is x any-reg) + (sc-is y any-reg) + (sc-is r any-reg) + (not (location= x r))) + (inst lea r (make-ea :dword :base x :index y :scale 1)) + (progn + (move r x) + (inst add r y))))) + +(define-vop (fast-+-c/fixnum=>fixnum fast-safe-arith-op) + (:translate +) + (:args (x :target r :scs (any-reg immediate-stack))) + (:info y) + (:arg-types tagged-num (:constant (signed-byte 30))) + (:results (r :scs (any-reg) + :load-if (not (location= x r)))) + (:result-types tagged-num) + (:note "inline fixnum arithmetic") + (:generator 1 + (if (and (sc-is x any-reg) + (sc-is r any-reg) + (not (location= x r))) + (inst lea r (make-ea :dword :base x :disp (fixnum y))) + (progn + (move r x) + (inst add r (fixnum y)))))) + +(define-vop (fast-+/signed=>signed fast-safe-arith-op) + (:translate +) + (:args (x :target r :scs (signed-reg) + :load-if (not (and (sc-is x signed-stack) + (sc-is y signed-reg) + (location= x r)))) + (y :scs (signed-reg signed-stack))) + (:arg-types signed-num signed-num) + (:results (r :scs (signed-reg) :from (:argument 0) + :load-if (not (and (sc-is x signed-stack) + (sc-is y signed-reg) + (location= x r))))) + (:result-types signed-num) + (:note "inline (signed-byte 32) arithmetic") + (:generator 5 + (if (and (sc-is x signed-reg) + (sc-is y signed-reg) + (sc-is r signed-reg) + (not (location= x r))) + (inst lea r (make-ea :dword :base x :index y :scale 1)) + (progn + (move r x) + (inst add r y))))) + +(define-vop (fast-+-c/signed=>signed fast-safe-arith-op) + (:translate +) + (:args (x :target r :scs (signed-reg signed-stack))) + (:info y) + (:arg-types signed-num (:constant (signed-byte 32))) + (:results (r :scs (signed-reg) + :load-if (not (location= x r)))) + (:result-types signed-num) + (:note "inline (signed-byte 32) arithmetic") + (:generator 4 + (if (and (sc-is x signed-reg) + (sc-is r signed-reg) + (not (location= x r))) + (inst lea r (make-ea :dword :base x :disp y)) + (progn + (move r x) + (inst add r y))))) + +(define-vop (fast-+/unsigned=>unsigned fast-safe-arith-op) + (:translate +) + (:args (x :target r :scs (unsigned-reg) + :load-if (not (and (sc-is x unsigned-stack) + (sc-is y unsigned-reg) + (location= x r)))) + (y :scs (unsigned-reg unsigned-stack))) + (:arg-types unsigned-num unsigned-num) + (:results (r :scs (unsigned-reg) :from (:argument 0) + :load-if (not (and (sc-is x unsigned-stack) + (sc-is y unsigned-reg) + (location= x r))))) + (:result-types unsigned-num) + (:note "inline (unsigned-byte 32) arithmetic") + (:generator 5 + (if (and (sc-is x unsigned-reg) + (sc-is y unsigned-reg) + (sc-is r unsigned-reg) + (not (location= x r))) + (inst lea r (make-ea :dword :base x :index y :scale 1)) + (progn + (move r x) + (inst add r y))))) + +(define-vop (fast-+-c/unsigned=>unsigned fast-safe-arith-op) + (:translate +) + (:args (x :target r :scs (unsigned-reg unsigned-stack))) + (:info y) + (:arg-types unsigned-num (:constant (unsigned-byte 32))) + (:results (r :scs (unsigned-reg) + :load-if (not (location= x r)))) + (:result-types unsigned-num) + (:note "inline (unsigned-byte 32) arithmetic") + (:generator 4 + (if (and (sc-is x unsigned-reg) + (sc-is r unsigned-reg) + (not (location= x r))) + (inst lea r (make-ea :dword :base x :disp y)) + (progn + (move r x) + (inst add r y))))) + + +;;;; Multiplication and division. + +(define-vop (fast-*/fixnum=>fixnum fast-safe-arith-op) + (:translate *) + ;; We need different loading characteristics. + (:args (x :scs (any-reg immediate-stack) :target r) + (y :scs (any-reg immediate-stack))) + (:arg-types tagged-num tagged-num) + (:results (r :scs (any-reg) :from (:argument 0))) + (:result-types tagged-num) + (:note "inline fixnum arithmetic") + (:generator 20 + (move r x) + (inst sar r 2) + (inst imul r y))) + +(define-vop (fast-*/fixnum=>fixnum-c fast-safe-arith-op) + (:translate *) + ;; We need different loading characteristics. + (:args (x :target r :scs (any-reg immediate-stack))) + (:info y) + (:arg-types tagged-num (:constant (signed-byte 30))) + (:results (r :scs (any-reg))) + (:result-types tagged-num) + (:note "inline fixnum arithmetic") + (:generator 18 + (inst imul r x y))) + +(define-vop (fast-*/signed=>signed fast-safe-arith-op) + (:translate *) + ;; We need different loading characteristics. + (:args (x :scs (signed-reg signed-stack) :target r) + (y :scs (signed-reg signed-stack))) + (:arg-types signed-num signed-num) + (:results (r :scs (signed-reg) :from (:argument 0))) + (:result-types signed-num) + (:note "inline (signed-byte 32) arithmetic") + (:generator 25 + (move r x) + (inst imul r y))) + +(define-vop (fast-*/signed=>signed-c fast-safe-arith-op) + (:translate *) + ;; We need different loading characteristics. + (:args (x :target r :scs (signed-reg signed-stack))) + (:info y) + (:arg-types signed-num (:constant (signed-byte 32))) + (:results (r :scs (signed-reg))) + (:result-types signed-num) + (:note "inline (signed-byte 32) arithmetic") + (:generator 23 + (inst imul r x y))) + + +(define-vop (fast-truncate/signed=>signed fast-safe-arith-op) + (:translate truncate) + (:args (x :scs (signed-reg signed-stack) :target eax) + (y :scs (signed-reg signed-stack))) + (:arg-types signed-num signed-num) + (:temporary (:sc dword-reg :offset eax-offset :target quo + :from (:argument 0) :to (:result 0)) + eax) + (:temporary (:sc dword-reg :offset edx-offset :target rem + :from (:argument 0) :to (:result 1)) + edx) + (:results (quo :scs (signed-reg signed-stack)) + (rem :scs (signed-reg signed-stack))) + (:result-types signed-num signed-num) + (:note "inline (signed-byte 32) arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:generator 30 + (let ((zero (generate-error-code vop division-by-zero-error x y))) + (inst cmp y 0) + (inst jmp :eq zero)) + (move eax x) + (inst cdq) + (inst idiv eax y) + (move quo eax) + (move rem edx))) + + + +;;;; Shifting +(define-vop (fast-ash-c) + (:policy :fast-safe) + (:translate ash) + (:note nil) + (:args (number :scs (signed-reg unsigned-reg) :target result)) + (:info amount) + (:arg-types (:or signed-num unsigned-num) (:constant integer)) + (:results (result :scs (signed-reg unsigned-reg))) + (:result-types (:or signed-num unsigned-num)) + (:generator 2 + (cond ((and (= amount 1) + (not (location= number result))) + (inst lea result (make-ea :dword :index number :scale 2))) + ((and (= amount 2) + (not (location= number result))) + (inst lea result (make-ea :dword :index number :scale 4))) + ((and (= amount 3) + (not (location= number result))) + (inst lea result (make-ea :dword :index number :scale 8))) + (t + (move result number) + (cond ((plusp amount) + ;; We don't have to worry about overflow because of the + ;; result type restriction. + (inst shl result amount)) + ((sc-is number signed-reg) + ;; If the amount is greater than 31, only shift by 31. We + ;; have to do this because the shift instructions only look + ;; at the low five bits of the result. + (inst sar result (min 31 (- amount)))) + (t + (inst shr result (min 31 (- amount))))))))) + +;; has problems when result is on stack -- maybe not spec'e right? +;; targeting still not understood -- target number<>result seems ok now +;; but extra moves required for amount. +;; Problem shows up in code/type.lisp TYPE/= +(define-vop (fast-ash-left) + (:note "inline ASH") + (:args (number :scs (signed-reg unsigned-reg) + :target result + :load-if + (not (and (sc-is number signed-stack unsigned-stack) + (location= number result)))) + (amount :scs (unsigned-reg) :target ecx)) + (:arg-types (:or signed-num unsigned-num) positive-fixnum) + (:temporary (:sc dword-reg :offset ecx-offset :from (:argument 1)) ecx) + (:results (result :scs (signed-reg unsigned-reg) + :from (:argument 0) + :load-if + (not (and (sc-is result signed-stack unsigned-stack) + (location= number result))))) + (:result-types (:or signed-num unsigned-num)) + (:translate ash) + (:policy :fast-safe) + (:generator 3 + (move result number) + (move ecx amount) + ;; The result-type assures us that this shift will not overflow. + (inst shl result :cl))) + + +(define-vop (fast-ash) + (:policy :fast-safe) + (:note "inline ASH") + (:translate ash) + (:args (number :scs (signed-reg unsigned-reg) :target result) + (amount :scs (signed-reg) :target ecx)) + (:arg-types (:or signed-num unsigned-num) signed-num) + (:results (result :scs (signed-reg unsigned-reg) + :from (:argument 0))) + (:result-types (:or signed-num unsigned-num)) + (:temporary (:sc dword-reg :offset ecx-offset :from (:argument 1)) ecx) + (:generator 5 + (move result number) + (move ecx amount) + (inst or ecx ecx) + (inst jmp :ns positive) + (inst neg ecx) + (inst cmp ecx 31) + (inst jmp :be okay) + (inst mov ecx 31) + OKAY + (sc-case number + (signed-reg (inst sar result :cl)) + (unsigned-reg (inst shr result :cl))) + (inst jmp done) + + POSITIVE + ;; The result-type assures us that this shift will not overflow. + (inst shl result :cl) + + DONE)) + + +;;; note documentation for this function is wrong - rtfm +(define-vop (signed-byte-32-len) + (:translate integer-length) + (:note "inline (signed-byte 32) integer-length") + (:policy :fast-safe) + (:args (arg :scs (signed-reg signed-stack))) + (:arg-types signed-num) + (:results (res :scs (any-reg))) + (:result-types positive-fixnum) + (:generator 30 + (move res arg) + (inst cmp res 0) + (inst jmp :ge POS) + (inst not res) + POS + (inst bsr res res) + (inst jmp :z zero) + (inst inc res) + (inst shl res 2) + (inst jmp done) + ZERO + (inst xor res res) + DONE)) + +(define-vop (unsigned-byte-32-count) + (:translate logcount) + (:note "inline (unsigned-byte 32) logcount") + (:policy :fast-safe) + (:args (arg :scs (unsigned-reg))) + (:arg-types unsigned-num) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:temporary (:sc dword-reg :from (:argument 0)) temp) + (:generator 30 + (move result arg) + + (inst mov temp result) + (inst shr temp 1) + (inst and result #x55555555) + (inst and temp #x55555555) + (inst add result temp) + + (inst mov temp result) + (inst shr temp 2) + (inst and result #x33333333) + (inst and temp #x33333333) + (inst add result temp) + + (inst mov temp result) + (inst shr temp 4) + (inst and result #x0f0f0f0f) + (inst and temp #x0f0f0f0f) + (inst add result temp) + + (inst mov temp result) + (inst shr temp 8) + (inst and result #x00ff00ff) + (inst and temp #x00ff00ff) + (inst add result temp) + + (inst mov temp result) + (inst shr temp 16) + (inst and result #x0000ffff) + (inst and temp #x0000ffff) + (inst add result temp))) + + + +;;;; Binary conditional VOPs: + +(define-vop (fast-conditional) + (:conditional) + (:info target not-p) + (:effects) + (:affected) + (:policy :fast-safe)) + +(define-vop (fast-conditional/fixnum fast-conditional) + (:args (x :scs (any-reg) + :load-if (not (and (sc-is x immediate-stack) + (sc-is y any-reg)))) + (y :scs (any-reg immediate-stack))) + (:arg-types tagged-num tagged-num) + (:note "inline fixnum comparison")) + +(define-vop (fast-conditional-c/fixnum fast-conditional/fixnum) + (:args (x :scs (any-reg immediate-stack))) + (:arg-types tagged-num (:constant (signed-byte 30))) + (:info target not-p y)) + +(define-vop (fast-conditional/signed fast-conditional) + (:args (x :scs (signed-reg) + :load-if (not (and (sc-is x signed-stack) + (sc-is y signed-reg)))) + (y :scs (signed-reg signed-stack))) + (:arg-types signed-num signed-num) + (:note "inline (signed-byte 32) comparison")) + +(define-vop (fast-conditional-c/signed fast-conditional/signed) + (:args (x :scs (signed-reg signed-stack))) + (:arg-types signed-num (:constant (signed-byte 32))) + (:info target not-p y)) + +(define-vop (fast-conditional/unsigned fast-conditional) + (:args (x :scs (unsigned-reg) + :load-if (not (and (sc-is x unsigned-stack) + (sc-is y unsigned-reg)))) + (y :scs (unsigned-reg unsigned-stack))) + (:arg-types unsigned-num unsigned-num) + (:note "inline (unsigned-byte 32) comparison")) + +(define-vop (fast-conditional-c/unsigned fast-conditional/unsigned) + (:args (x :scs (unsigned-reg unsigned-stack))) + (:arg-types unsigned-num (:constant (unsigned-byte 32))) + (:info target not-p y)) + + +(defmacro define-conditional-vop (tran cond unsigned not-cond not-unsigned) + `(progn + ,@(mapcar + #'(lambda (suffix cost signed) + (unless (and (member suffix '(/fixnum -c/fixnum)) + (eq tran 'eql)) + `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)" + tran suffix)) + ,(intern + (format nil "~:@(FAST-CONDITIONAL~A~)" + suffix))) + (:translate ,tran) + (:generator ,cost + (inst cmp x + ,(if (eq suffix '-c/fixnum) '(fixnum y) 'y)) + (inst jmp (if not-p + ,(if signed not-cond not-unsigned) + ,(if signed cond unsigned)) + target))))) + '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned) + '(4 3 6 5 6 5) + '(t t t t nil nil)))) + +(define-conditional-vop < :l :b :ge :ae) + +(define-conditional-vop > :g :a :le :be) + +(define-conditional-vop eql :e :e :ne :ne) + +;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a +;;; known fixnum. + +;;; These versions specify a fixnum restriction on their first arg. We have +;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on +;;; the first arg and a higher cost. The reason for doing this is to prevent +;;; fixnum specific operations from being used on word integers, spuriously +;;; consing the argument. +;;; + +(define-vop (fast-eql/fixnum fast-conditional) + (:args (x :scs (any-reg) + :load-if (not (and (sc-is x immediate-stack) + (sc-is y any-reg)))) + (y :scs (any-reg immediate-stack))) + (:arg-types tagged-num tagged-num) + (:note "inline fixnum comparison") + (:translate eql) + (:generator 4 + (inst cmp x y) + (inst jmp (if not-p :ne :e) target))) +;;; +(define-vop (generic-eql/fixnum fast-eql/fixnum) + (:args (x :scs (any-reg descriptor-reg)) + (y :scs (any-reg immediate-stack))) + (:arg-types * tagged-num) + (:variant-cost 7)) + +(define-vop (fast-eql-c/fixnum fast-conditional/fixnum) + (:args (x :scs (any-reg immediate-stack))) + (:arg-types tagged-num (:constant (signed-byte 30))) + (:info target not-p y) + (:translate eql) + (:generator 2 + (inst cmp x (fixnum y)) + (inst jmp (if not-p :ne :e) target))) +;;; +(define-vop (generic-eql-c/fixnum fast-eql-c/fixnum) + (:args (x :scs (any-reg immediate-stack descriptor-reg descriptor-stack))) + (:arg-types * (:constant (signed-byte 30))) + (:variant-cost 6)) + + +;;;; 32-bit logical operations + +(define-vop (merge-bits) + (:translate merge-bits) + (:args (shift :scs (signed-reg unsigned-reg) :target ecx) + (prev :scs (unsigned-reg) :target result) + (next :scs (unsigned-reg))) + (:arg-types tagged-num unsigned-num unsigned-num) + (:temporary (:sc dword-reg :offset ecx-offset :from (:argument 0)) ecx) + (:results (result :scs (unsigned-reg) :from (:argument 1))) + (:result-types unsigned-num) + (:policy :fast-safe) + (:generator 4 + (move ecx shift) + (move result prev) + (inst shrd result next :cl))) + +(define-vop (32bit-logical) + (:args (x :scs (unsigned-reg) :target r + :load-if (not (and (sc-is x unsigned-stack) + (location= x r)))) + (y :scs (unsigned-reg) + :load-if (or (not (sc-is y unsigned-stack)) + (and (sc-is x unsigned-stack) + (location= x r))))) + (:arg-types unsigned-num unsigned-num) + (:results (r :scs (unsigned-reg) :from (:argument 0) + :load-if (not (and (sc-is x unsigned-stack) + (location= x r))))) + (:result-types unsigned-num) + (:policy :fast-safe)) + +(define-vop (32bit-logical-not) + (:translate 32bit-logical-not) + (:args (x :scs (unsigned-reg) :target r + :load-if (not (and (sc-is x unsigned-stack) + (location= x r))))) + (:arg-types unsigned-num) + (:results (r :scs (unsigned-reg) + :load-if (not (and (sc-is x unsigned-stack) + (location= x r))))) + (:result-types unsigned-num) + (:policy :fast-safe) + (:generator 1 + (move r x) + (inst not r))) + +(define-vop (32bit-logical-and 32bit-logical) + (:translate 32bit-logical-and) + (:generator 1 + (move r x) + (inst and r y))) + +(def-source-transform 32bit-logical-nand (x y) + `(32bit-logical-not (32bit-logical-and ,x ,y))) + +(define-vop (32bit-logical-or 32bit-logical) + (:translate 32bit-logical-or) + (:generator 1 + (move r x) + (inst or r y))) + +(def-source-transform 32bit-logical-nor (x y) + `(32bit-logical-not (32bit-logical-or ,x ,y))) + +(define-vop (32bit-logical-xor 32bit-logical) + (:translate 32bit-logical-xor) + (:generator 1 + (move r x) + (inst xor r y))) + +(def-source-transform 32bit-logical-eqv (x y) + `(32bit-logical-not (32bit-logical-xor ,x ,y))) + +(def-source-transform 32bit-logical-orc1 (x y) + `(32bit-logical-or (32bit-logical-not ,x) ,y)) + +(def-source-transform 32bit-logical-orc2 (x y) + `(32bit-logical-or ,x (32bit-logical-not ,y))) + +(def-source-transform 32bit-logical-andc1 (x y) + `(32bit-logical-and (32bit-logical-not ,x) ,y)) + +(def-source-transform 32bit-logical-andc2 (x y) + `(32bit-logical-and ,x (32bit-logical-not ,y))) + + +(define-vop (shift-towards-someplace) + (:policy :fast-safe) + (:args (num :scs (unsigned-reg) :target r) + (amount :scs (unsigned-reg signed-reg) :target ecx)) + (:arg-types unsigned-num positive-fixnum) + (:temporary (:sc dword-reg :offset ecx-offset :from (:argument 1)) ecx) + (:results (r :scs (unsigned-reg))) + (:result-types unsigned-num)) + +(define-vop (shift-towards-start shift-towards-someplace) + (:translate shift-towards-start) + (:generator 1 + (move r num) + (move ecx amount) + (inst shr r :cl))) + +(define-vop (shift-towards-end shift-towards-someplace) + (:translate shift-towards-end) + (:generator 1 + (move r num) + (move ecx amount) + (inst shl r :cl))) + + + +;;;; Bignum stuff. + +(define-vop (bignum-length get-header-data) + (:translate bignum::%bignum-length) + (:policy :fast-safe)) + +(define-vop (bignum-set-length set-header-data) + (:translate bignum::%bignum-set-length) + (:policy :fast-safe)) + +(define-full-reffer bignum-ref * bignum-digits-offset other-pointer-type + (unsigned-reg) unsigned-num bignum::%bignum-ref) + +(define-full-setter bignum-set * bignum-digits-offset other-pointer-type + (unsigned-reg) unsigned-num bignum::%bignum-set) + +(define-vop (digit-0-or-plus) + (:translate bignum::%digit-0-or-plusp) + (:policy :fast-safe) + (:args (digit :scs (unsigned-reg))) + (:arg-types unsigned-num) + (:conditional) + (:info target not-p) + (:generator 3 + (inst or digit digit) + (inst jmp (if not-p :s :ns) target))) + + +;;; For add and sub with carry the sc of carry argument is any-reg so +;;; the it may be passed as a fixnum or word and thus may be 0, 1, or +;;; 4. This is easy to deal with and may save a fixnum-word +;;; conversion. +;;; +(define-vop (add-w/carry) + (:translate bignum::%add-with-carry) + (:policy :fast-safe) + (:args (a :scs (unsigned-reg) :target result) + (b :scs (unsigned-reg unsigned-stack) :to :eval) + (c :scs (any-reg) :target temp)) + (:arg-types unsigned-num unsigned-num positive-fixnum) + (:temporary (:sc any-reg :from (:argument 2) :to :eval) temp) + (:results (result :scs (unsigned-reg) :from (:argument 0)) + (carry :scs (unsigned-reg))) + (:result-types unsigned-num positive-fixnum) + (:generator 4 + (move result a) + (move temp c) + (inst neg temp) ; Set the carry flag to 0 if c=0 else to 1 + (inst adc result b) + (inst mov carry 0) + (inst adc carry carry))) + +;;; Note: the borrow is the oppostite of the x86 convention - 1 for no +;;; borrow and 0 for a borrow. +(define-vop (sub-w/borrow) + (:translate bignum::%subtract-with-borrow) + (:policy :fast-safe) + (:args (a :scs (unsigned-reg) :to :eval :target result) + (b :scs (unsigned-reg unsigned-stack) :to :result) + (c :scs (any-reg immediate-stack))) + (:arg-types unsigned-num unsigned-num positive-fixnum) + (:results (result :scs (unsigned-reg) :from :eval) + (borrow :scs (unsigned-reg))) + (:result-types unsigned-num positive-fixnum) + (:generator 5 + (inst cmp c 1) ; Set the carry flag to 1 if c=0 else to 0 + (move result a) + (inst sbb result b) + (inst mov borrow 0) + (inst adc borrow borrow) + (inst xor borrow 1))) + + +(define-vop (bignum-mult-and-add-3-arg) + (:translate bignum::%multiply-and-add) + (:policy :fast-safe) + (:args (x :scs (unsigned-reg unsigned-stack) :target eax) + (y :scs (unsigned-reg unsigned-stack)) + (carry-in :scs (unsigned-reg unsigned-stack))) + (:arg-types unsigned-num unsigned-num unsigned-num) + (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0) + :to (:result 1) :target lo) eax) + (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1) + :to (:result 0) :target hi) edx) + (:results (hi :scs (unsigned-reg unsigned-stack)) + (lo :scs (unsigned-reg unsigned-stack))) + (:result-types unsigned-num unsigned-num) + (:generator 20 + (move eax x) + (inst mul eax y) + (inst add eax carry-in) + (inst adc edx 0) + (move hi edx) + (move lo eax))) + +(define-vop (bignum-mult-and-add-4-arg) + (:translate bignum::%multiply-and-add) + (:policy :fast-safe) + (:args (x :scs (unsigned-reg unsigned-stack) :target eax) + (y :scs (unsigned-reg unsigned-stack)) + (prev :scs (unsigned-reg unsigned-stack)) + (carry-in :scs (unsigned-reg unsigned-stack))) + (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num) + (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0) + :to (:result 1) :target lo) eax) + (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1) + :to (:result 0) :target hi) edx) + (:results (hi :scs (unsigned-reg unsigned-stack)) + (lo :scs (unsigned-reg unsigned-stack))) + (:result-types unsigned-num unsigned-num) + (:generator 20 + (move eax x) + (inst mul eax y) + (inst add eax prev) + (inst adc edx 0) + (inst add eax carry-in) + (inst adc edx 0) + (move hi edx) + (move lo eax))) + + +(define-vop (bignum-mult) + (:translate bignum::%multiply) + (:policy :fast-safe) + (:args (x :scs (unsigned-reg unsigned-stack) :target eax) + (y :scs (unsigned-reg unsigned-stack))) + (:arg-types unsigned-num unsigned-num) + (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0) + :to (:result 1) :target lo) eax) + (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1) + :to (:result 0) :target hi) edx) + (:results (hi :scs (unsigned-reg unsigned-stack)) + (lo :scs (unsigned-reg unsigned-stack))) + (:result-types unsigned-num unsigned-num) + (:generator 20 + (move eax x) + (inst mul eax y) + (move hi edx) + (move lo eax))) + +(define-vop (bignum-lognot) + (:translate bignum::%lognot) + (:policy :fast-safe) + (:args (x :scs (unsigned-reg unsigned-stack) :target r)) + (:arg-types unsigned-num) + (:results (r :scs (unsigned-reg) + :load-if (not (location= x r)))) + (:result-types unsigned-num) + (:generator 1 + (move r x) + (inst not r))) + +(define-vop (fixnum-to-digit) + (:translate bignum::%fixnum-to-digit) + (:policy :fast-safe) + (:args (fixnum :scs (any-reg immediate-stack) :target digit)) + (:arg-types tagged-num) + (:results (digit :scs (unsigned-reg) + :load-if (not (location= fixnum digit)))) + (:result-types unsigned-num) + (:generator 1 + (move digit fixnum) + (inst sar digit 2))) + +(define-vop (bignum-floor) + (:translate bignum::%floor) + (:policy :fast-safe) + (:args (div-high :scs (unsigned-reg unsigned-stack) :target edx) + (div-low :scs (unsigned-reg unsigned-stack) :target eax) + (divisor :scs (unsigned-reg unsigned-stack))) + (:arg-types unsigned-num unsigned-num unsigned-num) + (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 1) + :to (:result 0) :target quo) eax) + (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 0) + :to (:result 1) :target rem) edx) + (:results (quo :scs (unsigned-reg unsigned-stack)) + (rem :scs (unsigned-reg unsigned-stack))) + (:result-types unsigned-num unsigned-num) + (:generator 300 + (move edx div-high) + (move eax div-low) + (inst div eax divisor) + (move quo eax) + (move rem edx))) + +(define-vop (signify-digit) + (:translate bignum::%fixnum-digit-with-correct-sign) + (:policy :fast-safe) + (:args (digit :scs (unsigned-reg unsigned-stack) :target res)) + (:arg-types unsigned-num) + (:results (res :scs (any-reg signed-reg) + :load-if (not (and (sc-is res immediate-stack signed-stack) + (location= digit res))))) + (:result-types signed-num) + (:generator 1 + (move res digit) + (when (sc-is res any-reg immediate-stack) + (inst shl res 2)))) + +(define-vop (digit-ashr) + (:translate bignum::%ashr) + (:policy :fast-safe) + (:args (digit :scs (unsigned-reg unsigned-stack) :target result) + (count :scs (unsigned-reg unsigned-stack) :target ecx)) + (:arg-types unsigned-num positive-fixnum) + (:temporary (:sc dword-reg :offset ecx-offset :from (:argument 1)) ecx) + (:results (result :scs (unsigned-reg) :from (:argument 0) + :load-if (not (and (sc-is result unsigned-stack) + (location= digit result))))) + (:result-types unsigned-num) + (:generator 1 + (move result digit) + (move ecx count) + (inst sar result :cl))) + +(define-vop (digit-lshr digit-ashr) + (:translate bignum::%digit-logical-shift-right) + (:generator 1 + (move result digit) + (move ecx count) + (inst shr result :cl))) + +(define-vop (digit-ashl digit-ashr) + (:translate bignum::%ashl) + (:generator 1 + (move result digit) + (move ecx count) + (inst shl result :cl))) + + +;;;; Static functions. + +(define-static-function two-arg-/ (x y) :translate /) + +(define-static-function two-arg-gcd (x y) :translate gcd) +(define-static-function two-arg-lcm (x y) :translate lcm) + +(define-static-function two-arg-and (x y) :translate logand) +(define-static-function two-arg-ior (x y) :translate logior) +(define-static-function two-arg-xor (x y) :translate logxor) diff --git a/compiler/x86/array.lisp b/compiler/x86/array.lisp new file mode 100644 index 000000000..f5f957a96 --- /dev/null +++ b/compiler/x86/array.lisp @@ -0,0 +1,655 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/array.lisp,v 1.1 1997/01/18 14:31:24 ram Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the x86 definitions for array operations. +;;; +;;; Written by William Lott +;;; +;;; Debugged by Paul F. Werkowski Spring/Summer 1995. +;;; +(in-package :x86) + + +;;;; Allocator for the array header. + + +(define-vop (make-array-header) + (:translate make-array-header) + (:policy :fast-safe) + (:args (type :scs (any-reg)) + (rank :scs (any-reg))) + (:arg-types positive-fixnum positive-fixnum) + (:temporary (:sc any-reg) bytes) + (:temporary (:sc any-reg) header) + (:temporary (:sc any-reg) alloc) + (:results (result :scs (descriptor-reg))) + (:generator 13 + (inst lea bytes + (make-ea :dword :base rank + :disp (+ (* (1+ array-dimensions-offset) word-bytes) + lowtag-mask))) + (inst and bytes (lognot lowtag-mask)) + (inst lea header (make-ea :dword :base rank + :disp (fixnum (1- array-dimensions-offset)))) + (inst shl header type-bits) + (inst or header type) + (inst shr header 2) + #-cgc + (with-allocation (alloc) + (inst lea result (make-ea :dword :base alloc :disp other-pointer-type)) + (inst add alloc bytes)) + #+cgc + (with-cgc-allocation (alloc bytes) + (inst lea result (make-ea :dword :base alloc :disp other-pointer-type))) + (storew header result 0 other-pointer-type))) + + +;;;; Additional accessors and setters for the array header. + +(defknown lisp::%array-dimension (t index) index + (flushable)) +(defknown lisp::%set-array-dimension (t index index) index + ()) + +(define-full-reffer %array-dimension * + array-dimensions-offset other-pointer-type + (any-reg) positive-fixnum lisp::%array-dimension) + +(define-full-setter %set-array-dimension * + array-dimensions-offset other-pointer-type + (any-reg) positive-fixnum lisp::%set-array-dimension) + + +(defknown lisp::%array-rank (t) index (flushable)) + +(define-vop (array-rank-vop) + (:translate lisp::%array-rank) + (:policy :fast-safe) + (:args (x :scs (descriptor-reg))) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 6 + (loadw res x 0 other-pointer-type) + (inst shr res type-bits) + (inst sub res (1- array-dimensions-offset)))) + + + +;;;; Bounds checking routine. + +(define-vop (check-bound) + (:translate %check-bound) + (:policy :fast-safe) + (:args (array) + (bound :scs (any-reg)) + (index :scs (any-reg immediate) :target result)) + (:arg-types * positive-fixnum tagged-num) + (:results (result :scs (any-reg immediate-stack))) + (:result-types positive-fixnum) + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (let ((error (generate-error-code vop invalid-array-index-error + array bound index)) + (index (if (sc-is index immediate) (fixnum (tn-value index)) index))) + (inst cmp bound index) + ;; We use below-or-equal even though it's an unsigned test, because + ;; negative indexes appear as real large unsigned numbers. Therefore, + ;; we get the < 0 and >= bound test all rolled into one. + (inst jmp :be error) + (unless (and (tn-p index) (location= result index)) + (inst mov result index)) + ))) + + +;;;; Accessors/Setters + +;;; Variants built on top of word-index-ref, etc. I.e. those vectors whos +;;; elements are represented in integer registers and are built out of +;;; 8, 16, or 32 bit elements. + +(eval-when (compile eval) + +(defmacro def-full-data-vector-frobs (type element-type &rest scs) + `(progn + (define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type + vector-data-offset other-pointer-type ,scs ,element-type + data-vector-ref) + (define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type + vector-data-offset other-pointer-type ,scs ,element-type + data-vector-set))) + +); eval-when (compile eval) + +(def-full-data-vector-frobs simple-vector * descriptor-reg any-reg) + + +(def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num + unsigned-reg) + +;;; Integer vectors whos elements are smaller than a byte. I.e. bit, 2-bit, +;;; and 4-bit vectors. +;;; + +(eval-when (compile eval) + +(defmacro def-small-data-vector-frobs (type bits) + (let* ((elements-per-word (floor vm:word-bits bits)) + (bit-shift (1- (integer-length elements-per-word)))) + `(progn + (define-vop (,(symbolicate 'data-vector-ref/ type)) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (unsigned-reg))) + (:arg-types ,type positive-fixnum) + (:results (result :scs (unsigned-reg) :from (:argument 0))) + (:result-types positive-fixnum) + (:temporary (:sc dword-reg :offset ecx-offset) ecx) + (:generator 20 + (move ecx index) + (inst shr ecx ,bit-shift) + (inst mov result + (make-ea :dword :base object :index ecx :scale 4 + :disp (- (* vector-data-offset word-bytes) + other-pointer-type))) + (move ecx index) + (inst and ecx ,(1- elements-per-word)) + ,@(unless (= bits 1) + `((inst shl ecx ,(1- (integer-length bits))))) + (inst shr result :cl) + (inst and result ,(1- (ash 1 bits))))) + (define-vop (,(symbolicate 'data-vector-ref-c/ type)) + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:arg-types ,type (:constant index)) + (:info index) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 15 + (multiple-value-bind (word extra) (floor index ,elements-per-word) + (loadw result object (+ word vector-data-offset) + other-pointer-type) + (unless (zerop extra) + (inst shr result (* extra ,bits))) + (unless (= extra ,(1- elements-per-word)) + (inst and result ,(1- (ash 1 bits))))))) + (define-vop (,(symbolicate 'data-vector-set/ type)) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :target ptr) + (index :scs (unsigned-reg) :target ecx) + (value :scs (unsigned-reg immediate) :target result)) + (:arg-types ,type positive-fixnum positive-fixnum) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:temporary (:sc dword-reg) word-index) + (:temporary (:sc dword-reg :from (:argument 0)) ptr old) + (:temporary (:sc dword-reg :offset ecx-offset :from (:argument 1)) + ecx) + (:generator 25 + (move word-index index) + (inst shr word-index ,bit-shift) + (inst lea ptr + (make-ea :dword :base object :index word-index :scale 4 + :disp (- (* vector-data-offset word-bytes) + other-pointer-type))) + (loadw old ptr) + (move ecx index) + (inst and ecx ,(1- elements-per-word)) + ,@(unless (= bits 1) + `((inst shl ecx ,(1- (integer-length bits))))) + (inst ror old :cl) + (unless (and (sc-is value immediate) + (= (tn-value value) ,(1- (ash 1 bits)))) + (inst and old ,(lognot (1- (ash 1 bits))))) + (sc-case value + (immediate + (unless (zerop (tn-value value)) + (inst or old (logand (tn-value value) ,(1- (ash 1 bits)))))) + (unsigned-reg + (inst or old value))) + (inst rol old :cl) + (storew old ptr) + (sc-case value + (immediate + (inst mov result (tn-value value))) + (unsigned-reg + (move result value))))) + (define-vop (,(symbolicate 'data-vector-set-c/ type)) + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (value :scs (unsigned-reg immediate) :target result)) + (:arg-types ,type (:constant index) positive-fixnum) + (:info index) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:temporary (:sc dword-reg :to (:result 0)) old) + (:generator 20 + (multiple-value-bind (word extra) (floor index ,elements-per-word) + (inst mov old + (make-ea :dword :base object + :disp (- (* (+ word vector-data-offset) word-bytes) + other-pointer-type))) + (sc-case value + (immediate + (let* ((value (tn-value value)) + (mask ,(1- (ash 1 bits))) + (shift (* extra ,bits))) + (unless (= value mask) + (inst and old (lognot (ash mask shift)))) + (unless (zerop value) + (inst or old (ash value shift))))) + (unsigned-reg + (let ((shift (* extra ,bits))) + (unless (zerop shift) + (inst ror old shift) + (inst and old (lognot ,(1- (ash 1 bits)))) + (inst or old value) + (inst rol old shift))))) + (inst mov (make-ea :dword :base object + :disp (- (* (+ word vector-data-offset) word-bytes) + other-pointer-type)) + old) + (sc-case value + (immediate + (inst mov result (tn-value value))) + (unsigned-reg + (move result value))))))))) + + +); eval-when (compile eval) + +(def-small-data-vector-frobs simple-bit-vector 1) +(def-small-data-vector-frobs simple-array-unsigned-byte-2 2) +(def-small-data-vector-frobs simple-array-unsigned-byte-4 4) + +;;; And the float variants. +;;; + +(define-vop (data-vector-ref/simple-array-single-float) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types simple-array-single-float positive-fixnum) + (:results (value :scs (single-reg))) + (:result-types single-float) + (:generator 5 + (with-empty-tn@fp-top(value) + (inst fld (make-ea :dword :base object :index index :scale 1 + :disp (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)))))) + +(define-vop (data-vector-set/simple-array-single-float) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (single-reg) :target result)) + (:arg-types simple-array-single-float positive-fixnum single-float) + (:results (result :scs (single-reg))) + (:result-types single-float) + (:generator 5 + (if (zerop (tn-offset value)) + (progn + ;; Value is in ST0 + (inst fst (make-ea :dword :base object :index index :scale 1 + :disp (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type))) + (unless (zerop (tn-offset result)) + ;; Value is in ST0 but not result. + (inst fst result))) + (progn + ;; Value is not in ST0. + (inst fxch value) + (inst fst (make-ea :dword :base object :index index :scale 1 + :disp (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type))) + (if (zerop (tn-offset result)) + ;; The result is in ST0. + (inst fst value) + (progn + ;; Neither value or result are in ST0 + (unless (location= value result) + (inst fst result)) + (inst fxch value))))))) + +(define-vop (data-vector-ref/simple-array-double-float) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types simple-array-double-float positive-fixnum) + (:results (value :scs (double-reg))) + (:result-types double-float) + (:generator 7 + (with-empty-tn@fp-top(value) + (inst fldd (make-ea :dword :base object :index index :scale 2 + :disp (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)))))) + +(define-vop (data-vector-set/simple-array-double-float) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (double-reg) :target result)) + (:arg-types simple-array-double-float positive-fixnum double-float) + (:results (result :scs (double-reg))) + (:result-types double-float) + (:generator 20 + (if (zerop (tn-offset value)) + (progn + ;; Value is in ST0 + (inst fstd (make-ea :dword :base object :index index :scale 2 + :disp (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type))) + (unless (zerop (tn-offset result)) + ;; Value is in ST0 but not result. + (inst fstd result))) + (progn + ;; Value is not in ST0. + (inst fxch value) + (inst fstd (make-ea :dword :base object :index index :scale 2 + :disp (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type))) + (if (zerop (tn-offset result)) + ;; The result is in ST0. + (inst fstd value) + (progn + ;; Neither value or result are in ST0 + (unless (location= value result) + (inst fstd result)) + (inst fxch value))))))) + +;;; These VOPs are used for implementing float slots in structures (whose raw +;;; data is an unsigned-32 vector. +;;; pfw-copied from hppa + +(define-vop (raw-ref-single data-vector-ref/simple-array-single-float) + (:translate %raw-ref-single) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum)) +;;; +(define-vop (raw-set-single data-vector-set/simple-array-single-float) + (:translate %raw-set-single) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum single-float)) +;;; +(define-vop (raw-ref-double data-vector-ref/simple-array-double-float) + (:translate %raw-ref-double) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum)) +;;; +(define-vop (raw-set-double data-vector-set/simple-array-double-float) + (:translate %raw-set-double) + (:arg-types simple-array-unsigned-byte-32 positive-fixnum double-float)) + + +;;; These vops are useful for accessing the bits of a vector irrespective of +;;; what type of vector it is. +;;; + +(define-full-reffer raw-bits * 0 other-pointer-type (unsigned-reg) unsigned-num + %raw-bits) +(define-full-setter set-raw-bits * 0 other-pointer-type (unsigned-reg) + unsigned-num %set-raw-bits) + + +;;;; Misc. Array VOPs. + +(define-vop (get-vector-subtype get-header-data)) +(define-vop (set-vector-subtype set-header-data)) + +;;;; +;;;; dtc expanded and fixed the following: + + + +;;; unsigned-byte-8 + +(define-vop (data-vector-ref/simple-array-unsigned-byte-8) + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (unsigned-reg))) + (:arg-types simple-array-unsigned-byte-8 positive-fixnum) + (:results (value :scs (unsigned-reg signed-reg))) + (:result-types positive-fixnum) + (:generator 5 + (inst movzx value + (make-ea :byte :base object :index index :scale 1 + :disp (- (* vector-data-offset word-bytes) + other-pointer-type))))) + + +(define-vop (data-vector-ref-c/simple-array-unsigned-byte-8) + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:info index) + (:arg-types simple-array-unsigned-byte-8 (:constant (signed-byte 30))) + (:results (value :scs (unsigned-reg signed-reg))) + (:result-types positive-fixnum) + (:generator 4 + (inst movzx value + (make-ea :byte :base object + :disp (- (+ (* vector-data-offset word-bytes) index) + other-pointer-type))))) + + +(define-vop (data-vector-set/simple-array-unsigned-byte-8) + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to (:eval 0)) + (index :scs (unsigned-reg) :to (:eval 0)) + (value :scs (unsigned-reg unsigned-stack signed-reg signed-stack) + :target eax)) + (:arg-types simple-array-unsigned-byte-8 positive-fixnum positive-fixnum) + (:temporary (:sc dword-reg :offset eax-offset :target result + :from (:argument 2) :to (:result 0)) + eax) + (:results (result :scs (unsigned-reg signed-reg))) + (:result-types positive-fixnum) + (:generator 5 + (move eax value) + (inst mov + (make-ea :byte :base object :index index :scale 1 + :disp (- (* vector-data-offset word-bytes) other-pointer-type)) + al-tn) + (move result eax))) + + +(define-vop (data-vector-set-c/simple-array-unsigned-byte-8) + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to (:eval 0)) + (value :scs (unsigned-reg unsigned-stack signed-reg signed-stack) + :target eax)) + (:info index) + (:arg-types simple-array-unsigned-byte-8 (:constant (signed-byte 30)) positive-fixnum) + (:temporary (:sc dword-reg :offset eax-offset :target result + :from (:argument 1) :to (:result 0)) + eax) + (:results (result :scs (unsigned-reg signed-reg))) + (:result-types positive-fixnum) + (:generator 4 + (move eax value) + (inst mov + (make-ea :byte :base object + :disp (- (+ (* vector-data-offset word-bytes) index) + other-pointer-type)) + al-tn) + (move result eax))) + + +;;; unsigned-byte-16 + +(define-vop (data-vector-ref/simple-array-unsigned-byte-16) + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (unsigned-reg))) + (:arg-types simple-array-unsigned-byte-16 positive-fixnum) + (:results (value :scs (unsigned-reg signed-reg))) + (:result-types positive-fixnum) + (:generator 5 + (inst movzx value + (make-ea :word :base object :index index :scale 2 + :disp (- (* vector-data-offset word-bytes) + other-pointer-type))))) + + +(define-vop (data-vector-ref-c/simple-array-unsigned-byte-16) + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:info index) + (:arg-types simple-array-unsigned-byte-16 (:constant (signed-byte 30))) + (:results (value :scs (unsigned-reg signed-reg))) + (:result-types positive-fixnum) + (:generator 4 + (inst movzx value + (make-ea :word :base object + :disp (- (+ (* vector-data-offset word-bytes) + (* 2 index)) + other-pointer-type))))) + + +(define-vop (data-vector-set/simple-array-unsigned-byte-16) + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to (:eval 0)) + (index :scs (unsigned-reg) :to (:eval 0)) + (value :scs (unsigned-reg unsigned-stack signed-reg signed-stack) + :target eax)) + (:arg-types simple-array-unsigned-byte-16 positive-fixnum positive-fixnum) + (:temporary (:sc dword-reg :offset eax-offset :target result + :from (:argument 2) :to (:result 0)) + eax) + (:results (result :scs (unsigned-reg signed-reg))) + (:result-types positive-fixnum) + (:generator 5 + (move eax value) + (inst mov (make-ea :word :base object :index index :scale 2 + :disp (- (* vector-data-offset word-bytes) + other-pointer-type)) + ax-tn) + (move result eax))) + + +(define-vop (data-vector-set-c/simple-array-unsigned-byte-16) + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to (:eval 0)) + (value :scs (unsigned-reg unsigned-stack signed-reg signed-stack) + :target eax)) + (:info index) + (:arg-types simple-array-unsigned-byte-16 (:constant (signed-byte 30)) positive-fixnum) + (:temporary (:sc dword-reg :offset eax-offset :target result + :from (:argument 1) :to (:result 0)) + eax) + (:results (result :scs (unsigned-reg signed-reg))) + (:result-types positive-fixnum) + (:generator 4 + (move eax value) + (inst mov + (make-ea :word :base object + :disp (- (+ (* vector-data-offset word-bytes) + (* 2 index)) + other-pointer-type)) + ax-tn) + (move result eax))) + + +;;; simple-string + +(define-vop (data-vector-ref/simple-string) + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (unsigned-reg))) + (:arg-types simple-string positive-fixnum) + (:temporary (:sc dword-reg ; byte-reg + :offset eax-offset ; al-offset + :target value + :from (:eval 0) :to (:result 0)) + eax) + (:ignore eax) + (:results (value :scs (base-char-reg))) + (:result-types base-char) + (:generator 5 + (inst mov al-tn + (make-ea :byte :base object :index index :scale 1 + :disp (- (* vector-data-offset word-bytes) other-pointer-type))) + (move value al-tn))) + +(define-vop (data-vector-ref-c/simple-string) + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:info index) + (:arg-types simple-string (:constant (signed-byte 30))) + (:temporary (:sc dword-reg :offset eax-offset :target value + :from (:eval 0) :to (:result 0)) + eax) + (:ignore eax) + (:results (value :scs (base-char-reg))) + (:result-types base-char) + (:generator 4 + (inst mov al-tn + (make-ea :byte :base object + :disp (- (+ (* vector-data-offset word-bytes) index) + other-pointer-type))) + (move value al-tn))) + + +(define-vop (data-vector-set/simple-string) + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to (:eval 0)) + (index :scs (unsigned-reg) :to (:eval 0)) + (value :scs (base-char-reg))) + (:arg-types simple-string positive-fixnum base-char) + (:results (result :scs (base-char-reg))) + (:result-types base-char) + (:generator 5 + (inst mov (make-ea :byte :base object :index index :scale 1 + :disp (- (* vector-data-offset word-bytes) + other-pointer-type)) + value) + (move result value))) + + +(define-vop (data-vector-set/simple-string-c) + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to (:eval 0)) + (value :scs (base-char-reg))) + (:info index) + (:arg-types simple-string (:constant (signed-byte 30)) base-char) + (:results (result :scs (base-char-reg))) + (:result-types base-char) + (:generator 4 + (inst mov (make-ea :byte :base object + :disp (- (+ (* vector-data-offset word-bytes) + index) + other-pointer-type)) + value) + (move result value))) diff --git a/compiler/x86/c-call.lisp b/compiler/x86/c-call.lisp new file mode 100644 index 000000000..56911e3f9 --- /dev/null +++ b/compiler/x86/c-call.lisp @@ -0,0 +1,214 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/c-call.lisp,v 1.1 1997/01/18 14:31:22 ram Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the VOPs and other necessary machine specific support +;;; routines for call-out to C. +;;; +;;; Written by William Lott. +;;; +;;; Debugged by Paul F. Werkowski Spring/Summer 1995. + +(in-package :x86) +(use-package :alien) +(use-package :alien-internals) + +;; The move-argument vop is going to store args on the stack for call-out. +;; These tn's will be used for that. move-arg is normally used for +;; things going down the stack but C wants to have args indexed in +;; the positive direction. + + +(defun my-make-wired-tn (prim-type-name sc-name offset) + (make-wired-tn (primitive-type-or-lose prim-type-name *backend*) + (sc-number-or-lose sc-name *backend*) + offset)) + +(defstruct arg-state + (stack-frame-size 0)) + +(def-alien-type-method (integer :arg-tn) (type state) + (let ((stack-frame-size (arg-state-stack-frame-size state))) + (setf (arg-state-stack-frame-size state) (1+ stack-frame-size)) + (multiple-value-bind + (ptype stack-sc) + (if (alien-integer-type-signed type) + (values 'signed-byte-32 'signed-stack) + (values 'unsigned-byte-32 'unsigned-stack)) + (my-make-wired-tn ptype stack-sc stack-frame-size)))) + +(def-alien-type-method (system-area-pointer :arg-tn) (type state) + (declare (ignore type)) + (let ((stack-frame-size (arg-state-stack-frame-size state))) + (setf (arg-state-stack-frame-size state) (1+ stack-frame-size)) + (my-make-wired-tn 'system-area-pointer + 'sap-stack + stack-frame-size))) + +(def-alien-type-method (double-float :arg-tn) (type state) + (declare (ignore type)) + (let ((stack-frame-size + (logandc2 (1+ (arg-state-stack-frame-size state)) 1))) + (setf (arg-state-stack-frame-size state) (+ stack-frame-size 2)) + (my-make-wired-tn 'double-float 'double-stack stack-frame-size))) + +(def-alien-type-method (single-float :arg-tn) (type state) + (declare (ignore type)) + (let ((stack-frame-size (arg-state-stack-frame-size state))) + (setf (arg-state-stack-frame-size state) (1+ stack-frame-size)) + (my-make-wired-tn 'single-float 'single-stack stack-frame-size))) + +(defstruct result-state + (num-results 0)) + +(defun result-reg-offset (slot) + (ecase slot + (0 eax-offset) + (1 edx-offset))) + +(def-alien-type-method (integer :result-tn) (type state) + (let ((num-results (result-state-num-results state))) + (setf (result-state-num-results state) (1+ num-results)) + (multiple-value-bind + (ptype reg-sc) + (if (alien-integer-type-signed type) + (values 'signed-byte-32 'signed-reg) + (values 'unsigned-byte-32 'unsigned-reg)) + (my-make-wired-tn ptype reg-sc (result-reg-offset num-results))))) + +(def-alien-type-method (system-area-pointer :result-tn) (type state) + (declare (ignore type)) + (let ((num-results (result-state-num-results state))) + (setf (result-state-num-results state) (1+ num-results)) + (my-make-wired-tn 'system-area-pointer 'sap-reg + (result-reg-offset num-results)))) + +(def-alien-type-method (double-float :result-tn) (type state) + (declare (ignore type)) + (let ((num-results (result-state-num-results state))) + (setf (result-state-num-results state) (1+ num-results)) + (my-make-wired-tn 'double-float 'double-reg (* num-results 2)))) + +(def-alien-type-method (single-float :result-tn) (type state) + (declare (ignore type)) + (let ((num-results (result-state-num-results state))) + (setf (result-state-num-results state) (1+ num-results)) + (my-make-wired-tn 'single-float 'single-reg (* num-results 2)))) + +#+nil ;;pfw obsolete now? +(def-alien-type-method (values :result-tn) (type state) + (mapcar #'(lambda (type) + (invoke-alien-type-method :result-tn type state)) + (alien-values-type-values type))) + +;;; pfw - from alpha +(def-alien-type-method (values :result-tn) (type state) + (let ((values (alien-values-type-values type))) + (when (cdr values) + (error "Too many result values from c-call.")) + (when values + (invoke-alien-type-method :result-tn (car values) state)))) + +(def-vm-support-routine make-call-out-tns (type) + (let ((arg-state (make-arg-state))) + (collect ((arg-tns)) + (dolist #+nil ;; this reversed list seems to cause the alien botches!! + (arg-type (reverse (alien-function-type-arg-types type))) + (arg-type (alien-function-type-arg-types type)) + (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state))) + (values (my-make-wired-tn 'positive-fixnum 'any-reg esp-offset) + (* (arg-state-stack-frame-size arg-state) word-bytes) + (arg-tns) + (invoke-alien-type-method :result-tn + (alien-function-type-result-type type) + (make-result-state)))))) + +(define-vop (foreign-symbol-address) + (:translate foreign-symbol-address) + (:policy :fast-safe) + (:args) + (:arg-types (:constant simple-string)) + (:info foreign-symbol) + (:results (res :scs (sap-reg))) + (:result-types system-area-pointer) + (:generator 2 + (inst lea res (make-fixup (extern-alien-name foreign-symbol) + :foreign)))) + +(define-vop (call-out) + (:args (function :scs (sap-reg)) + (args :more t)) + (:results (results :more t)) + ;; eax is already wired + (:temporary (:sc dword-reg :offset ecx-offset) ecx) + (:temporary (:sc dword-reg :offset edx-offset) edx) + (:temporary (:sc unsigned-stack :from (:eval 0) :to (:eval 1)) cw-temp) + (:node-var node) + (:vop-var vop) + (:save-p t) + (:ignore args ecx edx) + (:generator 0 + (cond ((policy node (> space speed)) + (move eax-tn function) + (inst call (make-fixup (extern-alien-name "call_into_c") :foreign))) + (t + (inst wait) ; Catch any pending FPE exceptions + (inst mov (make-ea :dword :disp (make-fixup + (extern-alien-name + "foreign_function_call_active") + :foreign)) 1) + + ;; Setup the NPX for C + (inst fnstcw cw-temp) ; save exception masks + (inst fninit) + (inst fldcw cw-temp) ; restore exception masks + + (inst call function) + ;; To give the debugger a clue. XX not really internal-error? + (note-this-location vop :internal-error) + + ;; Restore the NPX for lisp. + (inst fldz) ; insure no regs are empty + (inst fldz) + (inst fldz) + (inst fldz) + (inst fldz) + (inst fldz) + (inst fldz) + + (if (and results + (location= (tn-ref-tn results) fr0-tn)) + ;; The return result is in fr0. + (inst fxch fr7-tn) ; move the result back to fr0 + (inst fldz)) ; insure no regs are empty + + (inst mov (make-ea :dword :disp (make-fixup + (extern-alien-name + "foreign_function_call_active") + :foreign)) 0))))) + +(define-vop (alloc-number-stack-space) + (:info amount) + (:results (result :scs (sap-reg any-reg))) + (:generator 0 + (unless (zerop amount) + (let ( (delta (logandc2 (+ amount 3) 3)) ) + (inst sub esp-tn delta))) + (move result esp-tn))) + +(define-vop (dealloc-number-stack-space) + (:info amount) + (:generator 0 + (unless (zerop amount) + (let ( (delta (logandc2 (+ amount 3) 3)) ) + (inst add esp-tn delta))))) + diff --git a/compiler/x86/call.lisp b/compiler/x86/call.lisp new file mode 100644 index 000000000..cb76a6ab6 --- /dev/null +++ b/compiler/x86/call.lisp @@ -0,0 +1,1593 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/call.lisp,v 1.1 1997/01/18 14:31:21 ram Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the VM definition of function call for the x86. +;;; +;;; Written by William Lott. +;;; +;;; Debugged by Paul F. Werkowski Spring/Summer 1995. +;;; +(in-package :x86) + +;;; + + +;;;; Interfaces to IR2 conversion: + +;;; Standard-Argument-Location -- Interface +;;; +;;; Return a wired TN describing the N'th full call argument passing +;;; location. +;;; +(def-vm-support-routine standard-argument-location (n) + (declare (type unsigned-byte n)) + (if (< n register-arg-count) + (make-wired-tn *any-primitive-type* descriptor-reg-sc-number + (nth n register-arg-offsets)) + (make-wired-tn *any-primitive-type* descriptor-stack-sc-number n))) + + +;;; Make-Return-PC-Passing-Location -- Interface +;;; +;;; Make a passing location TN for a local call return PC. +;;; +;;; Always wire the return PC location to the stack in its standard +;;; location. +;;; +;;; No problems. +;#+nil +(def-vm-support-routine make-return-pc-passing-location (standard) + (declare (ignore standard)) + (make-wired-tn *fixnum-primitive-type* + immediate-stack-sc-number + return-pc-save-offset)) +;;; +;;; If standard is true, then use the standard (full call) location, +;;; otherwise use any legal location. +;;; +;;; No problems. +#+nil +(def-vm-support-routine make-return-pc-passing-location (standard) + (if standard + (make-wired-tn *fixnum-primitive-type* immediate-stack-sc-number + return-pc-save-offset) + (make-normal-tn *fixnum-primitive-type*))) + +;;; Make-Old-FP-Passing-Location -- Interface +;;; +;;; Similar to Make-Return-PC-Passing-Location, but makes a location to pass +;;; Old-FP in. +;;; +;;; This is wired in both the standard and the local-call +;;; conventions, because we want to be able to assume it's always there. +;;; Besides, the x86 doesn't have enough registers to really make it +;;; profitable to pass it in a register. +;;; +;;; No problems +;#+nil +(def-vm-support-routine make-old-fp-passing-location (standard) + (declare (ignore standard)) + (make-wired-tn *fixnum-primitive-type* + immediate-stack-sc-number + old-fp-save-offset)) +;;; +;;; If standard is true, then use the standard (full call) location, +;;; otherwise use any legal location. +;;; +;;; No problems. +#+nil +(def-vm-support-routine make-old-fp-passing-location (standard) + (if standard + (make-wired-tn *fixnum-primitive-type* immediate-stack-sc-number old-fp-save-offset) + (make-normal-tn *fixnum-primitive-type*))) + +;;; Make-Old-FP-Save-Location, Make-Return-PC-Save-Location -- Interface +;;; +;;; Make the TNs used to hold Old-FP and Return-PC within the current +;;; function. We treat these specially so that the debugger can find them at a +;;; known location. +;;; +;;; Without using a save-tn - which does not make much sense if it is +;;; wire to the stack? No problems. +(def-vm-support-routine make-old-fp-save-location (env) + (environment-debug-live-tn (make-wired-tn *fixnum-primitive-type* + immediate-stack-sc-number + old-fp-save-offset) + env)) +;;; +;;; Using a save-tn. No problems. +#+nil +(def-vm-support-routine make-old-fp-save-location (env) + (specify-save-tn + (environment-debug-live-tn (make-normal-tn *fixnum-primitive-type*) env) + (make-wired-tn *fixnum-primitive-type* + immediate-stack-sc-number + ocfp-save-offset))) + +;;; +;;; Without using a save-tn - which does not make much sense if it is +;;; wire to the stack? No problems. +(def-vm-support-routine make-return-pc-save-location (env) + (environment-debug-live-tn (make-wired-tn *fixnum-primitive-type* + immediate-stack-sc-number + return-pc-save-offset) + env)) +;;; +;;; Using a save-tn. No problems. +#+nil +(def-vm-support-routine make-return-pc-save-location (env) + (let ((ptype *fixnum-primitive-type*)) + (specify-save-tn + (environment-debug-live-tn (make-normal-tn ptype) env) + (make-wired-tn ptype + immediate-stack-sc-number + return-pc-save-offset)))) + +;;; Make-Argument-Count-Location -- Interface +;;; +;;; Make a TN for the standard argument count passing location. We only +;;; need to make the standard location, since a count is never passed when we +;;; are using non-standard conventions. +;;; +(def-vm-support-routine make-argument-count-location () + (make-wired-tn *fixnum-primitive-type* any-reg-sc-number ecx-offset)) + + +;;; MAKE-NFP-TN -- Interface +;;; +;;; Make a TN to hold the number-stack frame pointer. This is allocated +;;; once per component, and is component-live. +;;; +(def-vm-support-routine make-nfp-tn () + (make-restricted-tn *fixnum-primitive-type* ignore-me-sc-number)) + +;;; MAKE-STACK-POINTER-TN () +;;; +(def-vm-support-routine make-stack-pointer-tn () + (make-normal-tn *fixnum-primitive-type*)) + +;;; MAKE-NUMBER-STACK-POINTER-TN () +;;; +(def-vm-support-routine make-number-stack-pointer-tn () + (make-restricted-tn *fixnum-primitive-type* ignore-me-sc-number)) + +;;; Make-Unknown-Values-Locations -- Interface +;;; +;;; Return a list of TNs that can be used to represent an unknown-values +;;; continuation within a function. +;;; +(def-vm-support-routine make-unknown-values-locations () + (list (make-stack-pointer-tn) + (make-normal-tn *fixnum-primitive-type*))) + + +;;; Select-Component-Format -- Interface +;;; +;;; This function is called by the Entry-Analyze phase, allowing +;;; VM-dependent initialization of the IR2-Component structure. We push +;;; placeholder entries in the Constants to leave room for additional +;;; noise in the code object header. +;;; +(def-vm-support-routine select-component-format (component) + (declare (type component component)) + (dotimes (i code-constants-offset) + (vector-push-extend nil + (ir2-component-constants (component-info component)))) + (undefined-value)) + + +;;;; Frame hackery: + +;;; Used for setting up the Old-FP in local call. +;;; +(define-vop (current-fp) + (:results (val :scs (any-reg immediate-stack))) + (:generator 1 + (move val ebp-tn))) + +;;; We don't have a seperate NFP, so we don't need to do anything here. +;;; +(define-vop (compute-old-nfp) + (:results (val)) + (:ignore val) + (:generator 1 + nil)) + + +(define-vop (xep-allocate-frame) + (:info start-lab copy-more-arg-follows) + (:vop-var vop) + (:generator 1 + ;; Make sure the function is aligned, and drop a label pointing to this + ;; function header. + (align lowtag-bits) + (trace-table-entry trace-table-function-prologue) + (emit-label start-lab) + ;; Skip space for the function header. + (inst function-header-word) + (dotimes (i (1- vm:function-code-offset)) + (inst dword 0)) + + ;; The start of the actual code. + ;; Save the return-pc. + (popw ebp-tn (- (1+ return-pc-save-offset))) + + ;; If copy-more-arg follows it will allocate the correct stack + ;; size. The stack is not allocate first here as this may expose + ;; args on the stack if they take up more space than the frame! + (unless copy-more-arg-follows + ;; The args fit within the frame so just allocate the frame. + (inst lea esp-tn + (make-ea :dword :base ebp-tn + :disp (- (* vm:word-bytes + (max 3 (sb-allocated-size 'stack))))))) + + (trace-table-entry trace-table-normal))) + +;;; This is emitted directly before either a known-call-local, call-local, +;;; or a multiple-call-local. All it does is allocate stack space for the +;;; callee (who has the same size stack as us). +;;; +(define-vop (allocate-frame) + (:results (res :scs (any-reg immediate-stack)) + (nfp)) + (:info callee) + (:ignore nfp callee) + (:generator 2 + (move res esp-tn) + (inst sub esp-tn (* vm:word-bytes (sb-allocated-size 'stack))))) + +;;; Allocate a partial frame for passing stack arguments in a full call. Nargs +;;; is the number of arguments passed. We allocate at least 3 slots, because +;;; the XEP noise is going to want to use them before it can extend the stack. +;;; +(define-vop (allocate-full-call-frame) + (:info nargs) + (:results (res :scs (any-reg immediate-stack))) + (:generator 2 + (move res esp-tn) + (inst sub esp-tn (* (max nargs 3) vm:word-bytes)))) + + + +;;; Default-Unknown-Values -- Internal +;;; +;;; Emit code needed at the return-point from an unknown-values call for a +;;; fixed number of values. Values is the head of the TN-Ref list for the +;;; locations that the values are to be received into. Nvals is the number of +;;; values that are to be received (should equal the length of Values). +;;; +;;; Move-Temp is a Descriptor-Reg TN used as a temporary. +;;; +;;; This code exploits the fact that in the unknown-values convention, a +;;; single value return returns at the return PC + 2, whereas a return of other +;;; than one value returns directly at the return PC. +;;; +;;; If 0 or 1 values are expected, then we just emit an instruction to reset +;;; the SP (which will only be executed when other than 1 value is returned.) +;;; +;;; In the general case we have to do three things: +;;; -- Default unsupplied register values. This need only be done when a +;;; single value is returned, since register values are defaulted by the +;;; called in the non-single case. +;;; -- Default unsupplied stack values. This needs to be done whenever there +;;; are stack values. +;;; -- Reset SP. This must be done whenever other than 1 value is returned, +;;; regardless of the number of values desired. +;;; +;;; +(defun default-unknown-values (vop values nvals) + (declare (type (or tn-ref null) values) + (type unsigned-byte nvals)) + (cond + ((<= nvals 1) + (note-this-location vop :single-value-return) + (inst mov esp-tn ebx-tn)) + ((<= nvals register-arg-count) + (let ((regs-defaulted (gen-label))) + (note-this-location vop :unknown-return) + (inst jmp-short regs-defaulted) + ;; Default the unsuppled registers. + (let* ((2nd-tn-ref (tn-ref-across values)) + (2nd-tn (tn-ref-tn 2nd-tn-ref))) + (inst mov 2nd-tn nil-value) + (when (> nvals 2) + (loop + for tn-ref = (tn-ref-across 2nd-tn-ref) + then (tn-ref-across tn-ref) + for count from 2 below register-arg-count + do count (inst mov (tn-ref-tn tn-ref) 2nd-tn)))) + (inst mov ebx-tn esp-tn) + (emit-label regs-defaulted) + (inst mov esp-tn ebx-tn))) + #+bogus-code-broken-optimization + ((<= nvals 6) + ;; 29+(nvals-3)*21 bytes for this branch. For nvals=6 that is 92 + ;; bytes, which is the same as using the blt below. + (let ((regs-defaulted (gen-label)) + (defaulting-done (gen-label)) + (default-stack-slots (gen-label))) + ;; Branch off to the MV case. + (inst jmp-short regs-defaulted) + + ;; Default the register args + (inst mov eax-tn nil-value) + (loop + for tn-ref = (tn-ref-across values) + then (tn-ref-across tn-ref) + for count from 2 below register-arg-count + do count (inst mov (tn-ref-tn tn-ref) eax-tn)) + ;; Fake other registers so it looks like we returned with all the + ;; registers filled in. + (move ebx-tn esp-tn) + (inst push edx-tn) + (inst jmp default-stack-slots) + + (emit-label regs-defaulted) + (inst mov eax-tn nil-value) + (storew edx-tn ebx-tn (- word-bytes)) + (collect ((defaults)) + (do ((i register-arg-count (1+ i)) + (val (do ((i 0 (1+ i)) + (val values (tn-ref-across val))) + ((= i register-arg-count) val)) + (tn-ref-across val))) + ((null val)) + (let ((default-lab (gen-label)) + (tn (tn-ref-tn val))) + (defaults (cons default-lab tn)) + + (inst cmp ecx-tn (fixnum i)) + (inst jmp :be default-lab) + (loadw edx-tn ebx-tn i) + (inst mov tn edx-tn))) + + (emit-label defaulting-done) + (loadw edx-tn ebx-tn (- word-bytes)) + (move esp-tn ebx-tn) + + (let ((defaults (defaults))) + (when defaults + (assemble (*elsewhere*) + (trace-table-entry trace-table-function-prologue) + (dolist (default defaults) + (emit-label (car default)) + (inst mov (cdr default) eax-tn)) + (inst jmp defaulting-done) + (trace-table-entry trace-table-normal))))))) + (t + ;; 92 bytes for this branch. + (let ((regs-defaulted (gen-label)) + (restore-edi (gen-label)) + (no-stack-args (gen-label)) + (default-stack-vals (gen-label)) + (count-okay (gen-label))) + (note-this-location vop :unknown-return) + ;; Branch off to the MV case. + (inst jmp-short regs-defaulted) + + ;; Default the register args, and set up the stack as if we entered + ;; the MV return point. + (inst mov ebx-tn esp-tn) + (inst push edx-tn) + (inst mov edi-tn nil-value) + (inst push edi-tn) + (inst mov esi-tn edi-tn) + ;; Compute a pointer to where to put the [defaulted] stack values. + (emit-label no-stack-args) + (inst lea edi-tn + (make-ea :dword :base ebp-tn + :disp (* (- (1+ register-arg-count)) word-bytes))) + ;; Load EAX with NIL so we can quickly store it, and set up stuff + ;; for the loop. + (inst mov eax-tn nil-value) + (inst std) + (inst mov ecx-tn (- nvals register-arg-count)) + ;; Jump into the default loop. + (inst jmp default-stack-vals) + + ;; The regs are defaulted. We need to copy any stack arguments, + ;; and then default the remaining stack arguments. + (emit-label regs-defaulted) + ;; Save EDI. + (storew edi-tn ebx-tn (- (1+ 1))) + ;; Compute the number of stack arguments, and if it's zero or less, + ;; don't copy any stack arguments. + (inst sub ecx-tn (fixnum register-arg-count)) + (inst jmp :le no-stack-args) + + ;; Throw away any unwanted args. + (inst cmp ecx-tn (fixnum (- nvals register-arg-count))) + (inst jmp :be count-okay) + (inst mov ecx-tn (fixnum (- nvals register-arg-count))) + (emit-label count-okay) + ;; Save the number of stack values. + (inst mov eax-tn ecx-tn) + ;; Compute a pointer to where the stack args go. + (inst lea edi-tn + (make-ea :dword :base ebp-tn + :disp (* (- (1+ register-arg-count)) word-bytes))) + ;; Save ESI, and compute a pointer to where the args come from. + (storew esi-tn ebx-tn (- (1+ 2))) + (inst lea esi-tn + (make-ea :dword :base ebx-tn + :disp (* (- (1+ register-arg-count)) word-bytes))) + ;; Do the copy. + (inst shr ecx-tn word-shift) ; make word count + (inst std) + (inst rep) + (inst movs :dword) + ;; Restore ESI. + (loadw esi-tn ebx-tn (- (1+ 2))) + ;; Now we have to default the remaining args. Find out how many. + ;; If none, then just blow out of here. + (inst sub eax-tn (fixnum (- nvals register-arg-count))) + (inst jmp :be restore-edi) + (inst mov ecx-tn eax-tn) + (inst shr ecx-tn word-shift) ; word count + ;; Load EAX with NIL for fast storing. + (inst mov eax-tn nil-value) + ;; Do the store. + (emit-label default-stack-vals) + (inst rep) + (inst stos eax-tn) + ;; Restore EDI, and reset the stack. + (emit-label restore-edi) + (loadw edi-tn ebx-tn (- (1+ 1))) + (inst mov esp-tn ebx-tn)))) + (undefined-value)) + + + +;;;; Unknown values receiving: + +;;; Receive-Unknown-Values -- Internal +;;; +;;; Emit code needed at the return point for an unknown-values call for an +;;; arbitrary number of values. +;;; +;;; We do the single and non-single cases with no shared code: there doesn't +;;; seem to be any potential overlap, and receiving a single value is more +;;; important efficiency-wise. +;;; +;;; When there is a single value, we just push it on the stack, returning +;;; the old SP and 1. +;;; +;;; When there is a variable number of values, we move all of the argument +;;; registers onto the stack, and return Args and Nargs. +;;; +;;; Args and Nargs are TNs wired to the named locations. We must +;;; explicitly allocate these TNs, since their lifetimes overlap with the +;;; results Start and Count (also, it's nice to be able to target them). +;;; +(defun receive-unknown-values (args nargs start count) + (declare (type tn args nargs start count)) + (let ((variable-values (gen-label)) + (done (gen-label))) + (inst jmp-short variable-values) + + (inst mov start esp-tn) + (inst push (first register-arg-tns)) + (inst mov count (fixnum 1)) + (inst jmp done) + + (emit-label variable-values) + (loop + for arg in register-arg-tns + for i downfrom -1 + do (storew arg args i)) ; dtc: this writes the registers onto + ; the stack even if they are not needed, + ; only the number specified in ecx are + ; used and have stack allocated to + ; them. No harm is done. + (move start args) + (move count nargs) + + (emit-label done)) + (undefined-value)) + + +;;; VOP that can be inherited by unknown values receivers. The main thing this +;;; handles is allocation of the result temporaries. +;;; +(define-vop (unknown-values-receiver) + (:temporary (:sc descriptor-reg :offset ebx-offset + :from :eval :to (:result 0)) + values-start) + (:temporary (:sc any-reg :offset ecx-offset + :from :eval :to (:result 1)) + nvals) + (:results (start :scs (any-reg immediate-stack)) + (count :scs (any-reg immediate-stack)))) + + +;;;; Local call with unknown values convention return: + +;;; Non-TR local call for a fixed number of values passed according to the +;;; unknown values convention. +;;; +;;; FP is the frame pointer in install before doing the call. +;;; +;;; NFP would be the number-stack frame pointer if we had a seperate number +;;; stack. +;;; +;;; Args are the argument passing locations, which are specified only to +;;; terminate their lifetimes in the caller. +;;; +;;; Values are the return value locations (wired to the standard passing +;;; locations). +;;; Nvals is the number of values received. +;;; +;;; Save is the save info, which we can ignore since saving has been done. +;;; +;;; Target is a continuation pointing to the start of the called function. +;;; +;;; +(define-vop (call-local) + (:args (fp) + (nfp) + (args :more t)) + (:results (values :more t)) + (:save-p t) + (:move-args :local-call) + (:info arg-locs callee target nvals) + (:vop-var vop) + (:ignore nfp arg-locs args #+nil callee) + (:generator 5 + (trace-table-entry trace-table-call-site) + (move ebp-tn fp) + + (let ((ret-tn (callee-return-pc-tn callee))) + +#+nil (format t "*call-local ~s; tn-kind ~s; tn-save-tn ~s; its tn-kind ~s~%" + ret-tn (c::tn-kind ret-tn) (c::tn-save-tn ret-tn) + (c::tn-kind (c::tn-save-tn ret-tn))) + + ;; Is the return-pc on the stack or in a register? + (sc-case ret-tn + ((immediate-stack) +#+nil (format t "*call-local: ret-tn on stack; offset=~s~%" + (tn-offset ret-tn)) + ;; Stack + (storew (make-fixup nil :code-object return) + ebp-tn (- (1+ (tn-offset ret-tn))))) + + ((any-reg descriptor-reg) + ;; Register + (inst lea ret-tn (make-fixup nil :code-object return))))) + + (note-this-location vop :call-site) + (inst jmp target) + #+x86-lra + (progn + (align lowtag-bits #x90) + (inst lra-header-word) + (inst nop) + (inst nop) + (inst nop)) + RETURN + (default-unknown-values vop values nvals) + (trace-table-entry trace-table-normal))) + +;;; Non-TR local call for a variable number of return values passed according +;;; to the unknown values convention. The results are the start of the values +;;; glob and the number of values received. +;;; +(define-vop (multiple-call-local unknown-values-receiver) + (:args (fp) + (nfp) + (args :more t)) + (:save-p t) + (:move-args :local-call) + (:info save callee target) + (:ignore args save nfp #+nil callee) + (:vop-var vop) + (:generator 20 + (trace-table-entry trace-table-call-site) + (move ebp-tn fp) + + (let ((ret-tn (callee-return-pc-tn callee))) + +#+nil (format t "*multiple-call-local ~s; tn-kind ~s; tn-save-tn ~s; its tn-kind ~s~%" + ret-tn (c::tn-kind ret-tn) (c::tn-save-tn ret-tn) + (c::tn-kind (c::tn-save-tn ret-tn))) + + ;; Is the return-pc on the stack or in a register? + (sc-case ret-tn + ((immediate-stack) +#+nil (format t "*multiple-call-local: ret-tn on stack; offset=~s~%" + (tn-offset ret-tn)) + ;; Stack + (storew (make-fixup nil :code-object return) + ebp-tn (- (1+ (tn-offset ret-tn))))) + + ((any-reg descriptor-reg) + ;; Register + (inst lea ret-tn (make-fixup nil :code-object return))))) + + (note-this-location vop :call-site) + (inst jmp target) + #+x86-lra + (progn + (align lowtag-bits #x90) + (inst lra-header-word) + (inst nop) + (inst nop) + (inst nop)) + RETURN + (note-this-location vop :unknown-return) + (receive-unknown-values values-start nvals start count) + (trace-table-entry trace-table-normal))) + + +;;;; Local call with known values return: + +;;; Non-TR local call with known return locations. Known-value return works +;;; just like argument passing in local call. +;;; +;;; Note: we can't use normal load-tn allocation for the fixed args, since all +;;; registers may be tied up by the more operand. Instead, we use +;;; MAYBE-LOAD-STACK-TN. +;;; +(define-vop (known-call-local) + (:args (fp) + (nfp) + (args :more t)) + (:results (res :more t)) + (:move-args :local-call) + (:save-p t) + (:info save callee target) + (:ignore args res save nfp #+nil callee) + (:vop-var vop) + (:generator 5 + (trace-table-entry trace-table-call-site) + (move ebp-tn fp) + + (let ((ret-tn (callee-return-pc-tn callee))) + +#+nil (format t "*known-call-local ~s; tn-kind ~s; tn-save-tn ~s; its tn-kind ~s~%" + ret-tn (c::tn-kind ret-tn) (c::tn-save-tn ret-tn) + (c::tn-kind (c::tn-save-tn ret-tn))) + + ;; Is the return-pc on the stack or in a register? + (sc-case ret-tn + ((immediate-stack) +#+nil (format t "*known-call-local: ret-tn on stack; offset=~s~%" + (tn-offset ret-tn)) + ;; Stack + (storew (make-fixup nil :code-object return) + ebp-tn (- (1+ (tn-offset ret-tn))))) + + ((any-reg descriptor-reg) + ;; Register + (inst lea ret-tn (make-fixup nil :code-object return))))) + + (note-this-location vop :call-site) + (inst jmp target) + #+x86-lra + (progn + (align lowtag-bits #x90) + (inst lra-header-word) + (inst nop) + (inst nop) + (inst nop)) + RETURN + (note-this-location vop :known-return) + (trace-table-entry trace-table-normal))) + +;;; Return from known values call. We receive the return locations as +;;; arguments to terminate their lifetimes in the returning function. We +;;; restore FP and CSP and jump to the Return-PC. +;;; +;;; We can assume we know exactly where old-fp and return-pc are because +;;; make-old-fp-save-location and make-return-pc-save-location always +;;; return the same place. +;;; +#+nil +(define-vop (known-return) + (:args (old-fp) + (return-pc :scs (any-reg immediate-stack) :target rpc) + (vals :more t)) + (:move-args :known-return) + (:info val-locs) + (:temporary (:sc dword-reg :from (:argument 1)) rpc) + (:ignore val-locs vals) + (:vop-var vop) + (:generator 6 + (trace-table-entry trace-table-function-epilogue) + ;; Save the return-pc in a register 'cause the frame-pointer is going away. + ;; Note this not in the usual stack location so we can't use RET + (move rpc return-pc) + ;; Restore the stack. + (move esp-tn ebp-tn) + ;; Restore the old fp. We know OLD-FP is going to be in it's stack + ;; save slot, which is a different frame that than this one, + ;; so we don't have to worry about having just cleared + ;; most of the stack. + (move ebp-tn old-fp) + (inst jmp rpc) + (trace-table-entry trace-table-normal))) + +;;; From Douglas Crosher +;;; Return from known values call. We receive the return locations as +;;; arguments to terminate their lifetimes in the returning function. We +;;; restore FP and CSP and jump to the Return-PC. +;;; +;;; The old-fp may be either in a register or on the stack in its +;;; standard save locations - slot 0. +;;; +;;; The return-pc may be in a register or on the stack in any slot. +;;; +(define-vop (known-return) + (:args (old-fp) + (return-pc) + (vals :more t)) + (:move-args :known-return) + (:info val-locs) + (:ignore val-locs vals) + (:vop-var vop) + (:generator 6 + (trace-table-entry trace-table-function-epilogue) + +#+nil (format t "*known-return: old-fp ~s, tn-kind ~s; ~s ~s~%" + old-fp (c::tn-kind old-fp) (c::tn-save-tn old-fp) + (c::tn-kind (c::tn-save-tn old-fp))) + +#+nil (format t "*known-return: return-pc ~s, tn-kind ~s; ~s ~s~%" + return-pc (c::tn-kind return-pc) (c::tn-save-tn return-pc) + (c::tn-kind (c::tn-save-tn return-pc))) + + ;; return-pc may be either in a register or on the stack. + (sc-case return-pc + ((any-reg descriptor-reg) + (sc-case old-fp + ((immediate-stack) + +#+nil (format t "*known-return: old-fp ~s on stack; offset=~s~%" + old-fp (tn-offset old-fp)) + + (cond ((zerop (tn-offset old-fp)) + ;; Zot all of the stack except for the old-fp. + (inst lea esp-tn + (make-ea :dword :base ebp-tn + :disp + (- (* (1+ old-fp-save-offset) word-bytes)))) + ;; Restore the old fp from its save location on the stack, + ;; and zot the stack. + (inst pop ebp-tn)) + + (t + (cerror "Continue any-way" + "VOP return-local doesn't work if old-fp (in slot %s) is not in slot 0" + (tn-offset old-fp))))) + + ((any-reg descriptor-reg) + ;; Zot all the stack. + (move esp-tn ebp-tn) + ;; Restore the old-fp. + (move ebp-tn old-fp))) + + ;; Return; return-pc is in a register. + (inst jmp return-pc)) + + ((immediate-stack descriptor-stack) + +#+nil (format t "*known-return: return-pc ~s on stack; offset=~s~%" + return-pc (tn-offset return-pc)) + + ;; Zot all of the stack except for the old-fp and return-pc. + (inst lea esp-tn + (make-ea :dword :base ebp-tn + :disp + (- (* (1+ (tn-offset return-pc)) word-bytes)))) + ;; Restore the old fp. old-fp may be either on the stack in its + ;; save location or in a register, in either case this restores it. + (move ebp-tn old-fp) + ;; The return pops the return address (4 bytes), then we need + ;; to pop all the slots before the return-pc which includes the + ;; 4 bytes for the old-fp. + (inst ret (* (tn-offset return-pc) word-bytes)))) + + (trace-table-entry trace-table-normal))) + + +;;;; Full call: +;;; +;;; There is something of a cross-product effect with full calls. Different +;;; versions are used depending on whether we know the number of arguments or +;;; the name of the called function, and whether we want fixed values, unknown +;;; values, or a tail call. +;;; +;;; In full call, the arguments are passed creating a partial frame on the +;;; stack top and storing stack arguments into that frame. On entry to the +;;; callee, this partial frame is pointed to by FP. + +;;; Define-Full-Call -- Internal +;;; +;;; This macro helps in the definition of full call VOPs by avoiding code +;;; replication in defining the cross-product VOPs. +;;; +;;; Name is the name of the VOP to define. +;;; +;;; Named is true if the first argument is an fdefinition object whose +;;; definition is to be called. +;;; +;;; Return is either :Fixed, :Unknown or :Tail: +;;; -- If :Fixed, then the call is for a fixed number of values, returned in +;;; the standard passing locations (passed as result operands). +;;; -- If :Unknown, then the result values are pushed on the stack, and the +;;; result values are specified by the Start and Count as in the +;;; unknown-values continuation representation. +;;; -- If :Tail, then do a tail-recursive call. No values are returned. +;;; The Old-Fp and Return-PC are passed as the second and third arguments. +;;; +;;; In non-tail calls, the pointer to the stack arguments is passed as the last +;;; fixed argument. If Variable is false, then the passing locations are +;;; passed as a more arg. Variable is true if there are a variable number of +;;; arguments passed on the stack. Variable cannot be specified with :Tail +;;; return. TR variable argument call is implemented separately. +;;; +;;; In tail call with fixed arguments, the passing locations are passed as a +;;; more arg, but there is no new-FP, since the arguments have been set up in +;;; the current frame. +;;; +(defmacro define-full-call (name named return variable) + (assert (not (and variable (eq return :tail)))) + `(define-vop (,name + ,@(when (eq return :unknown) + '(unknown-values-receiver))) + (:args + ,@(unless (eq return :tail) + '((new-fp :scs (any-reg) :to (:argument 1)))) + + (fun :scs (descriptor-reg descriptor-stack) + :target eax :to (:argument 0)) + + ,@(when (eq return :tail) + '((old-fp) + (return-pc))) + + ,@(unless variable '((args :more t :scs (descriptor-reg))))) + + ,@(when (eq return :fixed) + '((:results (values :more t)))) + + (:save-p ,(if (eq return :tail) :compute-only t)) + + ,@(unless (or (eq return :tail) variable) + '((:move-args :full-call))) + + (:vop-var vop) + (:info + ,@(unless (or variable (eq return :tail)) '(arg-locs)) + ,@(unless variable '(nargs)) + ,@(when (eq return :fixed) '(nvals))) + + (:ignore + ,@(unless (or variable (eq return :tail)) '(arg-locs)) + ,@(unless variable '(args))) + + ;; We pass either the fdefn object (for named call) or the actual + ;; function object (for unnamed call) in EAX. With named call, + ;; closure-tramp will replace it with the real function and invoke + ;; the real function for closures. Non-closures do not need this + ;; value, so don't care what shows up in it. + (:temporary + (:sc descriptor-reg :offset eax-offset :from (:argument 0) :to :eval) + eax) + + ;; We pass the number of arguments in ECX. + (:temporary (:sc dword-reg :offset ecx-offset :to :eval) ecx) + + ;; With variable call, we have to load the register-args out + ;; of the (new) stack frame before doing the call. Therefore, + ;; we have to tell the lifetime stuff that we need to use them. + ,@(when variable + (mapcar #'(lambda (name offset) + `(:temporary (:sc descriptor-reg + :offset ,offset + :from (:argument 0) + :to :eval) + ,name)) + register-arg-names register-arg-offsets)) + + ,@(when (eq return :tail) + '((:temporary (:sc dword-reg :from (:argument 1) :to (:argument 2)) + old-fp-tmp) + #+x86-lra + (:temporary (:sc dword-reg :from (:argument 2) :to (:argument 3)) + ret-pc-tmp) + )) + + (:generator ,(+ (if named 5 0) + (if variable 19 1) + (if (eq return :tail) 0 10) + 15 + (if (eq return :unknown) 25 0)) + (trace-table-entry trace-table-call-site) + + ;; This has to be done before the frame pointer is changed! + ;; eax stores the 'lexical environment' needed for closures + (move eax fun) + + + ,@(if variable + ;; For variable call, compute the number of arguments and + ;; move some of the arguments to registers. + (collect ((noise)) + ;; Compute the number of arguments. + (noise '(inst mov ecx new-fp)) + (noise '(inst sub ecx esp-tn)) + ;; Move the necessary args to registers, this + ;; moves them all even if they are not all needed. + (loop + for name in register-arg-names + for index downfrom -1 + do (noise `(loadw ,name new-fp ,index))) + (noise)) + '((if (zerop nargs) + (inst xor ecx ecx) + (inst mov ecx (fixnum nargs))))) + ,@(cond ((eq return :tail) + '(;; Python has figured out what frame we should return + ;; to so might as well use that clue. This seems + ;; really important to the implementation of things + ;; like (without-interrupts ...) + + ;; dtc; Could be doing a tail call from a + ;; known-local-call etc in which the old-fp or ret-pc + ;; are in regs or in non-standard places. If the + ;; passing location were wired to the stack in + ;; standard locations then these moves will be + ;; un-necessary; this is probably best for the x86. + (sc-case old-fp + ((immediate-stack descriptor-stack) + (unless (= old-fp-save-offset (tn-offset old-fp)) + (format t "** tail-call old-fp not S0~%") + (move old-fp-tmp old-fp) + (storew old-fp-tmp ebp-tn (- (1+ old-fp-save-offset))))) + ((any-reg descriptor-reg) + (format t "** tail-call old-fp in reg not S0~%") + (storew old-fp ebp-tn (- (1+ old-fp-save-offset))))) + + #+x86-lra + (sc-case return-pc + ((immediate-stack descriptor-stack) + (unless (= return-pc-save-offset (tn-offset return-pc)) + (format t "** tail-call ret-pc not S1~%") + (move ret-pc-tmp return-pc) + (storew ret-pc-tmp ebp-tn (- (1+ return-pc-save-offset))))) + ((any-reg descriptor-reg) + (format t "** tail-call ret-pc in reg not S1~%") + (storew return-pc ebp-tn (- (1+ return-pc-save-offset))))) + + ;; For tail call, we have to push the return-pc so + ;; that it looks like we CALLed despite the fact that + ;; we are going to JMP. + (inst push return-pc) + )) + (t + ;; For non-tail call, we have to save our frame pointer + ;; and install the new frame pointer. We can't load stack + ;; tns after this point. + `( + ;; Python doesn't seem to allocate a frame here which + ;; doesn't leave room for the ofp/ret stuff. + + ;; The variable args are on the stack and become the + ;; frame, but there may be <3 args and 3 stack slots + ;; are assumed allocate on the call. So need to ensure + ;; there are at least 3 slots. This hack justs adds 3 + ;; more. + ,(if variable + '(inst sub esp-tn (fixnum 3))) + + ;; Save the fp + (storew ebp-tn new-fp (- (1+ old-fp-save-offset))) + + ;; Save the return address. + #+x86-lra + (storew (make-fixup nil :code-object return) + new-fp (- (1+ return-pc-save-offset))) + + (move ebp-tn new-fp) ; NB - now on new stack frame. + + ;; Push the return address for backward compatability. + #+x86-lra + (inst push (make-ea :dword :base new-fp :disp -8)) + )) + ) + + (note-this-location vop :call-site) + + #-x86-lra + (inst ,(if (eq return :tail) 'jmp 'call) + (make-ea :dword :base eax + :disp ,(if named + '(- (* fdefn-raw-addr-slot word-bytes) + other-pointer-type) + '(- (* closure-function-slot word-bytes) + function-pointer-type)))) + + #+x86-lra + (inst jmp (make-ea :dword :base eax + :disp ,(if named + '(- (* fdefn-raw-addr-slot word-bytes) + other-pointer-type) + '(- (* closure-function-slot word-bytes) + function-pointer-type)))) + + ,@(ecase return + (:fixed + #+x86-lra + '((align lowtag-bits #x90) + (inst lra-header-word) + (inst nop) + (inst nop) + (inst nop) + RETURN + (default-unknown-values vop values nvals)) + #-x86-lra + '((default-unknown-values vop values nvals)) + ) + (:unknown + #+x86-lra + '((align lowtag-bits #x90) + (inst lra-header-word) + (inst nop) + (inst nop) + (inst nop) + RETURN + (note-this-location vop :unknown-return) + (receive-unknown-values values-start nvals start count)) + #-x86-lra + '((note-this-location vop :unknown-return) + (receive-unknown-values values-start nvals start count)) + ) + (:tail)) + (trace-table-entry trace-table-normal)))) + + +(define-full-call call nil :fixed nil) +(define-full-call call-named t :fixed nil) +(define-full-call multiple-call nil :unknown nil) +(define-full-call multiple-call-named t :unknown nil) +(define-full-call tail-call nil :tail nil) +(define-full-call tail-call-named t :tail nil) + +(define-full-call call-variable nil :fixed t) +(define-full-call multiple-call-variable nil :unknown t) + + +;;; Defined separately, since needs special code that BLT's the arguments +;;; down. All the real work is done in the assembly routine. We just +;;; set things up so that it can find what it needs. +;;; +(define-vop (tail-call-variable) + (:args (args :scs (any-reg immediate-stack) :target esi) + (function :scs (descriptor-reg descriptor-stack) :target eax) + (old-fp) + (ret-addr)) + (:temporary (:sc dword-reg :offset esi-offset :from (:argument 0)) esi) + (:temporary (:sc dword-reg :offset eax-offset :from (:argument 1)) eax) +; (:ignore ret-addr old-fp) + (:generator 75 + ;; Move these into the passing locations if they are not already there. + (move esi args) + (move eax function) + + ;; The following assumes that the return-pc and old-fp are on the + ;; stack in their standard save locations - Check this. + (unless (and (sc-is old-fp immediate-stack descriptor-stack) + (= (tn-offset old-fp) old-fp-save-offset)) + (error "tail-call-variable: old-fp not on stack in standard save location?")) + (unless (and (sc-is ret-addr immediate-stack descriptor-stack) + (= (tn-offset ret-addr) return-pc-save-offset)) + (error "tail-call-variable: ret-addr not on stack in standard save location?")) + + + ;; And jump to the assembly routine. + (inst jmp (make-fixup 'tail-call-variable :assembly-routine)))) + + +;;;; Unknown values return: + +;;; Return a single-value using the Unknown-Values convention. Specifically, +;;; we jump to clear the stack and jump to return-pc+2. +;;; +;;; We require old-fp to be in a register, because we want to reset ESP before +;;; restoring EBP. If old-fp were still on the stack, it could get clobbered +;;; by a signal. +;;; +;;; pfw--get wired-tn conflicts sometimes if register sc specd for args +;;; having problems targeting args to regs -- using temps instead. +(define-vop (return-single) + (:args (old-fp) + (return-pc) + (value)) + (:temporary (:sc dword-reg) ofp) + (:temporary (:sc dword-reg) ret) + (:ignore value) + (:node-var node) + (:generator 6 + (trace-table-entry trace-table-function-epilogue) + (move ret return-pc) + ;; Clear the control stack + (move ofp old-fp) + ;; Adjust the return address for the single value return. + (cond ((policy node (> speed space)) + ;; This takes 2 cycles, and 5 or 6 bytes. + (inst add ret 2)) + (t + ;; This takes 4 cycles and 2 bytes. + (inst inc ret) + (inst inc ret))) + ;; Restore the frame pointer. + (move esp-tn ebp-tn) + (move ebp-tn ofp) + ;; Out of here. + (inst jmp ret))) + +;;; Do unknown-values return of a fixed (other than 1) number of values. The +;;; Values are required to be set up in the standard passing locations. Nvals +;;; is the number of values returned. +;;; +;;; Basically, we just load ECX with the number of values returned and EBX +;;; with a pointer to the values, set ESP to point to the end of the values, +;;; and jump directly to return-pc. +;;; +(define-vop (return) + (:args (old-fp) + (return-pc :to (:eval 1)) + (values :more t)) + (:ignore values) + (:info nvals) + + ;; In the case of other than one value, we need these registers to tell + ;; the caller where they are and how many there are. + (:temporary (:sc dword-reg :offset ebx-offset) ebx) + (:temporary (:sc dword-reg :offset ecx-offset) ecx) + + ;; We need to stretch the lifetime of return-pc past the argument + ;; registers so that we can default the argument registers without + ;; trashing return-pc. + (:temporary (:sc dword-reg :offset (first register-arg-offsets) :from :eval) + a0) + (:temporary (:sc dword-reg :offset (second register-arg-offsets) :from :eval) + a1) + (:temporary (:sc dword-reg :offset (third register-arg-offsets) :from :eval) + a2) + + (:generator 6 + (trace-table-entry trace-table-function-epilogue) + ;; Establish the values pointer and values count. + (move ebx ebp-tn) + (if (zerop nvals) + (inst xor ecx ecx) ; smaller + (inst mov ecx (fixnum nvals))) + ;; restore the frame pointer and clear as much of the stack as possible. + (move ebp-tn old-fp) + (inst lea esp-tn (make-ea :dword :base ebx :disp (- (* nvals word-bytes)))) + ;; pre-default any argument register that need it. + (when (< nvals register-arg-count) + (let* ((arg-tns (nthcdr nvals (list a0 a1 a2))) + (first (first arg-tns))) + (inst mov first nil-value) + (dolist (tn (cdr arg-tns)) + (inst mov tn first)))) + ;; And away we go. Except that return-pc is still on the + ;; stack and we've changed the stack pointer. So we have to + ;; tell it to index off of EBX instead of EBP. + (inst jmp + (make-ea :dword :base ebx + :disp + (- (* (1+ (tn-offset return-pc)) word-bytes)))) + + (trace-table-entry trace-table-normal))) + +;;; Do unknown-values return of an arbitrary number of values (passed on the +;;; stack.) We check for the common case of a single return value, and do that +;;; inline using the normal single value return convention. Otherwise, we +;;; branch off to code that calls an assembly-routine. +;;; +;;; The assembly routine takes the following args: +;;; EAX -- the return-pc to finally jump to. +;;; EBX -- pointer to where to put the values. +;;; ECX -- number of values to find there. +;;; ESI -- pointer to where to find the values. +;;; +(define-vop (return-multiple) + (:args (old-fp :to (:eval 1) :target old-fp-temp) + (return-pc :target eax) + (vals :scs (any-reg) :target esi) + (nvals :scs (any-reg) :target ecx)) + + (:temporary (:sc dword-reg :offset eax-offset :from (:argument 1)) eax) + (:temporary (:sc dword-reg :offset esi-offset :from (:argument 2)) esi) + (:temporary (:sc dword-reg :offset ecx-offset :from (:argument 3)) ecx) + (:temporary (:sc dword-reg :offset ebx-offset :from (:eval 0)) ebx) + (:temporary (:sc descriptor-reg :offset (first register-arg-offsets) + :from (:eval 0)) a0) + (:temporary (:sc dword-reg :from (:eval 1)) old-fp-temp) + (:node-var node) + + (:generator 13 + (trace-table-entry trace-table-function-epilogue) + ;; Load the return-pc. + (move eax return-pc) + (unless (policy node (> space speed)) + ;; Check for the single case. + (let ((not-single (gen-label))) + (inst cmp nvals (fixnum 1)) + (inst jmp :ne not-single) + + ;; Return with one value. + (loadw a0 vals -1) + ;; Clear the stack. We load old-fp into a register before clearing + ;; the stack. + (move old-fp-temp old-fp) + (move esp-tn ebp-tn) + (move ebp-tn old-fp-temp) + ;; Fix the return-pc to point at the single-value entry point. + (cond ((policy node (> speed space)) + ;; This takes 2 cycles, and 5 bytes. + (inst add eax 2)) + (t + ;; This takes 4 cycles and 2 bytes. + (inst inc eax) + (inst inc eax))) + ;; Out of here. + (inst jmp eax) + + ;; Nope, not the single case. Jump to the assembly routine. + (emit-label not-single))) + (move esi vals) + (move ecx nvals) + (move ebx ebp-tn) + (move ebp-tn old-fp) + (inst jmp (make-fixup 'return-multiple :assembly-routine)) + (trace-table-entry trace-table-normal))) + + +;;;; XEP hackery: + +;;; We don't need to do anything special for regular functions. +;;; +(define-vop (setup-environment) + (:info label) + (:ignore label) + (:generator 0 + ;; Don't bother doing anything. + nil)) + +;;; Get the lexical environment from it's passing location. +;;; +(define-vop (setup-closure-environment) + (:results (closure :scs (descriptor-reg))) + (:info label) + (:ignore label) + (:generator 6 + ;; Get result. + (move closure eax-tn))) + +;;; Copy a more arg from the argument area to the end of the current frame. +;;; Fixed is the number of non-more arguments. +;;; +;;; The tricky part is doing this without trashing any of the calling +;;; convention registers that are still needed. This vop is emitted directly +;;; after the xep-allocate frame. That means the registers are in use as +;;; follows: +;;; +;;; EAX -- The lexenv. +;;; EBX -- Available. +;;; ECX -- The total number of arguments. +;;; EDX -- The first arg. +;;; EDI -- The second arg. +;;; ESI -- The third arg. +;;; +;;; So basically, we have one register available for our use: EBX. +;;; +;;; What we can do is push the other regs onto the stack, and then restore +;;; their values by looking directly below where we put the more-args. +;;; +(define-vop (copy-more-arg) + (:info fixed) + (:generator 20 + ;; Avoid the copy if there are no more args. + (cond ((zerop fixed) + (inst jecxz just-alloc-frame)) + (t + (inst cmp ecx-tn (fixnum fixed)) + (inst jmp :be just-alloc-frame))) + + ;; Allocate the space on the stack. + ;; stack = ebp - (max 3 frame-size) - (nargs - fixed) + (inst lea ebx-tn + (make-ea :dword :base ebp-tn + :disp (- (fixnum fixed) + (* vm:word-bytes + (max 3 (sb-allocated-size 'stack)))))) + (inst sub ebx-tn ecx-tn) ; Got the new stack in ebx + (inst mov esp-tn ebx-tn) + + ;; Now: nargs>=1 && nargs>fixed + + ;; Save the original count of args. + (inst mov ebx-tn ecx-tn) + + (if (< fixed register-arg-count) + (progn + ;; We must stop when we run out of stack args, not when we + ;; run out of more args. + ;; Number to copy = nargs-3 + (inst sub ecx-tn (fixnum register-arg-count)) + ;; Everything of interest in registers. + (inst jmp :be do-regs) + ) + ;; Number to copy = nargs-fixed + (inst sub ecx-tn (fixnum fixed)) + ) + + ;; Save edi and esi register args. + (inst push edi-tn) + (inst push esi-tn) + ;; Okay, we have pushed the register args. We can trash them + ;; now. + + ;; Initialize dst to be end of stack; skiping the values pushed + ;; above. + (inst lea edi-tn (make-ea :dword :base esp-tn :disp 8)) + + ;; Initialize src to be end of args. + (inst mov esi-tn ebp-tn) + (inst sub esi-tn ebx-tn) + + (inst shr ecx-tn word-shift) ; make word count + ;; And copy the args. + (inst cld) ; auto-inc ESI and EDI. + (inst rep) + (inst movs :dword) + + ;; So now we need to restore EDI and ESI. + (inst pop esi-tn) + (inst pop edi-tn) + + DO-REGS + + ;; Restore ECX + (inst mov ecx-tn ebx-tn) + + ;; Here: nargs>=1 && nargs>fixed + (when (< fixed register-arg-count) + ;; Now we have to deposit any more args that showed up in + ;; registers. + (do ((i fixed)) + ( nil ) + ;; Store it relative to ebp + (inst mov (make-ea :dword :base ebp-tn + :disp (- (* 4 + (+ 1 (- i fixed) + (max 3 (sb-allocated-size 'stack)))))) + (nth i register-arg-tns)) + + (incf i) + (when (>= i register-arg-count) + (return)) + + ;; Don't deposit any more than there are. + (if (zerop i) + (inst test ecx-tn ecx-tn) + (inst cmp ecx-tn (fixnum i))) + (inst jmp :eq done))) + + (inst jmp done) + + JUST-ALLOC-FRAME + (inst lea esp-tn + (make-ea :dword :base ebp-tn + :disp (- (* vm:word-bytes + (max 3 (sb-allocated-size 'stack)))))) + + DONE)) + +;;; More args are stored contiguously on the stack, starting immediately at +;;; the context pointer. The context pointer is not typed, so the lowtag is 0. +;;; +;(define-full-reffer more-arg * 0 0 (any-reg descriptor-reg) * %more-arg) + +(DEFINE-VOP (MORE-ARG) + (:TRANSLATE %MORE-ARG) + (:POLICY :FAST-SAFE) + (:ARGS (OBJECT :SCS (DESCRIPTOR-REG) :to :result ) + (INDEX :SCS (ANY-REG) :target temp)) + (:ARG-TYPES * TAGGED-NUM) + (:temporary (:sc dword-reg :from (:argument 1)) temp) + (:RESULTS (VALUE :SCS (ANY-REG DESCRIPTOR-REG))) + (:RESULT-TYPES *) + (:GENERATOR 5 + (move temp index) + (inst neg temp) + (INST MOV VALUE (MAKE-EA :DWORD :BASE OBJECT :INDEX temp)))) + +(DEFINE-VOP (MORE-ARG-C) + (:TRANSLATE %MORE-ARG) + (:POLICY :FAST-SAFE) + (:ARGS (OBJECT :SCS (DESCRIPTOR-REG))) + (:INFO INDEX) ; Note this is raw number. + (:ARG-TYPES * (:CONSTANT (SIGNED-BYTE 30))) + (:RESULTS (VALUE :SCS (ANY-REG DESCRIPTOR-REG))) + (:RESULT-TYPES *) + (:GENERATOR 5 + (INST MOV VALUE + (make-ea :dword :base object :disp (- (* index word-bytes)))))) + + +;;; Turn more arg (context, count) into a list. +;;; +(define-vop (listify-rest-args) + (:translate %listify-rest-args) + (:policy :safe) + (:args (context :scs (descriptor-reg) :target src) + (count :scs (any-reg) :target ecx)) + (:arg-types * tagged-num) + (:temporary (:sc dword-reg :offset esi-offset :from (:argument 0)) src) + (:temporary (:sc dword-reg :offset ecx-offset :from (:argument 1)) ecx) + (:temporary (:sc dword-reg :offset eax-offset) eax) + (:temporary (:sc dword-reg) dst) + (:results (result :scs (descriptor-reg))) + (:generator 20 + (move src context) + (move ecx count) + ;; Check to see if there are no arguments, and just return NIL if so. + (inst mov result nil-value) + (inst jecxz done) + #-cgc + (with-allocation (eax) + (inst lea dst (make-ea :byte :base eax :disp list-pointer-type)) + (inst lea eax (make-ea :dword :base eax :index ecx :scale 2))) + #+cgc + (progn + (inst lea eax (make-ea :dword :index ecx :scale 2)) + (with-cgc-allocation (eax eax) + (inst lea dst (make-ea :byte :base eax :disp list-pointer-type)))) + ;; Convert the count into a raw value, so we can use the LOOP inst. + (inst shr ecx 2) + ;; Set decrement mode (successive args at lower addresses) + (inst std) + ;; Set up the result. + (move result dst) + ;; Jump into the middle of the loop, 'cause that's were we want to start. + (inst jmp enter) + LOOP + ;; Compute a pointer to the next cons. + (inst add dst (* cons-size word-bytes)) + ;; Store a pointer to this cons in the CDR of the previous cons. + (storew dst dst -1 list-pointer-type) + ENTER + ;; Grab one value and stash it in the car of this cons. + (inst lods eax) + (storew eax dst 0 list-pointer-type) + ;; Go back for more. + (inst loop loop) + ;; NIL out the last cons. + (storew nil-value dst 1 vm:list-pointer-type) + DONE)) + +;;; Return the location and size of the more arg glob created by Copy-More-Arg. +;;; Supplied is the total number of arguments supplied (originally passed in +;;; ECX.) Fixed is the number of non-rest arguments. +;;; +;;; We must duplicate some of the work done by Copy-More-Arg, since at that +;;; time the environment is in a pretty brain-damaged state, preventing this +;;; info from being returned as values. What we do is compute +;;; supplied - fixed, and return a pointer that many words below the current +;;; stack top. +;;; +(define-vop (more-arg-context) + (:policy :fast-safe) + (:translate c::%more-arg-context) + (:args (supplied :target count)) + (:arg-types positive-fixnum (:constant fixnum)) + (:info fixed) + (:results (context :scs (descriptor-reg)) + (count :scs (any-reg))) + (:result-types t tagged-num) + (:generator 5 + (move count supplied) + ;; SP at this point points at the last arg pushed. + ;; Point to the first more-arg, not above it. + (inst lea context (make-ea :dword :base esp-tn + :index count :scale 1 + :disp (- (+ (fixnum fixed) 4)))) + (unless (zerop fixed) + (inst sub count (fixnum fixed))) + )) + +;;; Signal wrong argument count error if Nargs isn't = to Count. +;;; +#| +(define-vop (verify-argument-count) + (:policy :fast-safe) + (:translate c::%verify-argument-count) + (:args (nargs :scs (unsigned-reg))) + (:arg-types positive-fixnum (:constant t)) + (:info count) + (:vop-var vop) + (:save-p :compute-only) + (:generator 3 + (let ((err-lab + (generate-error-code vop invalid-argument-count-error nargs))) + (inst shl nargs 2) + (inst cmp nargs (fixnum count)) + (inst jmp :ne err-lab)))) +|# + +(define-vop (verify-argument-count) + (:policy :fast-safe) + (:translate c::%verify-argument-count) + (:args (nargs :scs (any-reg))) + (:arg-types positive-fixnum (:constant t)) + (:info count) + (:vop-var vop) + (:save-p :compute-only) + (:generator 3 + (let ((err-lab + (generate-error-code vop invalid-argument-count-error nargs))) + (if (zerop count) + (inst test nargs nargs) ; smaller instruction + (inst cmp nargs (fixnum count))) + (inst jmp :ne err-lab)))) + +;;; Signal various errors. +;;; +#+old +(macrolet ((frob (name error &rest args) + `(define-vop (,name) + (:args ,@(mapcar #'(lambda (arg) + `(,arg :scs (any-reg descriptor-reg))) + args)) + (:vop-var vop) + (:save-p :compute-only) + (:generator 1000 + (error-call vop ,error ,@args))))) + (frob argument-count-error invalid-argument-count-error nargs) + (frob type-check-error object-not-type-error object type) + (frob odd-keyword-arguments-error odd-keyword-arguments-error) + (frob unknown-keyword-argument-error unknown-keyword-argument-error key) + (frob nil-function-returned-error nil-function-returned-error fun)) + +(macrolet ((frob (name error translate &rest args) + `(define-vop (,name) + ,@(when translate + `((:policy :fast-safe) + (:translate ,translate))) + (:args ,@(mapcar #'(lambda (arg) + `(,arg :scs (any-reg descriptor-reg))) + args)) + (:vop-var vop) + (:save-p :compute-only) + (:generator 1000 + (error-call vop ,error ,@args))))) + (frob argument-count-error invalid-argument-count-error + c::%argument-count-error nargs) + (frob type-check-error object-not-type-error + c::%type-check-error + object type) + (frob layout-invalid-error layout-invalid-error + c::%layout-invalid-error + object layout) + (frob odd-keyword-arguments-error odd-keyword-arguments-error + c::%odd-keyword-arguments-error) + (frob unknown-keyword-argument-error unknown-keyword-argument-error + c::%unknown-keyword-argument-error key) + (frob nil-function-returned-error nil-function-returned-error nil fun)) diff --git a/compiler/x86/cell.lisp b/compiler/x86/cell.lisp new file mode 100644 index 000000000..d2a1a7298 --- /dev/null +++ b/compiler/x86/cell.lisp @@ -0,0 +1,305 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/cell.lisp,v 1.1 1997/01/18 14:31:23 ram Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the VM definition of various primitive memory access +;;; VOPs for the x86. +;;; +;;; Written by William Lott. +;;; +;;; Debugged by Paul F. Werkowski Spring/Summer 1995. +;;; + +(in-package :x86) + + + +;;;; Data object ref/set stuff. + +(define-vop (slot) + (:args (object :scs (descriptor-reg))) + (:info name offset lowtag) + (:ignore name) + (:results (result :scs (descriptor-reg any-reg))) + (:generator 1 + (loadw result object offset lowtag))) + +(define-vop (set-slot) + (:args (object :scs (descriptor-reg)) + (value :scs (descriptor-reg any-reg immediate))) + (:info name offset lowtag) + (:ignore name) + (:results) + (:generator 1 + (if (sc-is value immediate) + (let ((val (tn-value value))) + (etypecase val + (integer + (inst mov + (make-ea :dword :base object + :disp (- (* offset word-bytes) lowtag)) + (fixnum val))) + (symbol + (inst mov + (make-ea :dword :base object + :disp (- (* offset word-bytes) lowtag)) + (+ nil-value (static-symbol-offset val)))) + (character + (inst mov + (make-ea :dword :base object + :disp (- (* offset word-bytes) lowtag)) + (logior (ash (char-code val) type-bits) + base-char-type))))) + ;; Else, value not immediate. + (storew value object offset lowtag)))) + + + +;;;; Symbol hacking VOPs: + +;;; these next two cf the sparc version, by jrd. + +;;; The compiler likes to be able to directly SET symbols. +;;; +(define-vop (set cell-set) + (:variant symbol-value-slot other-pointer-type)) + +;;; Do a cell ref with an error check for being unbound. +;;; +(define-vop (checked-cell-ref) + (:args (object :scs (descriptor-reg) :target obj-temp)) + (:results (value :scs (descriptor-reg any-reg))) + (:policy :fast-safe) + (:vop-var vop) + (:save-p :compute-only) + (:temporary (:sc descriptor-reg :from (:argument 0)) obj-temp)) + + + +;;; With Symbol-Value, we check that the value isn't the trap object. So +;;; Symbol-Value of NIL is NIL. +;;; +(define-vop (symbol-value) + (:translate symbol-value) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to (:result 1))) + (:results (value :scs (descriptor-reg any-reg))) + (:vop-var vop) + (:save-p :compute-only) + (:generator 9 + (let ((err-lab (generate-error-code vop unbound-symbol-error object))) + (loadw value object symbol-value-slot other-pointer-type) + (inst cmp value unbound-marker-type) + (inst jmp :e err-lab)))) + +(define-vop (fast-symbol-value cell-ref) + (:variant symbol-value-slot other-pointer-type) + (:policy :fast) + (:translate symbol-value)) + + +(define-vop (boundp) + (:translate boundp) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:conditional) + (:info target not-p) + (:temporary (:sc descriptor-reg :from (:argument 0)) value) + (:generator 9 + (loadw value object symbol-value-slot other-pointer-type) + (inst cmp value unbound-marker-type) + (inst jmp (if not-p :e :ne) target))) + + +;;;; Fdefinition (fdefn) objects. + +(define-vop (fdefn-function cell-ref) ; /pfw - alpha + (:variant fdefn-function-slot other-pointer-type)) + +(define-vop (safe-fdefn-function) + (:args (object :scs (descriptor-reg) :to (:result 1))) + (:results (value :scs (descriptor-reg any-reg))) + (:vop-var vop) + (:save-p :compute-only) + (:generator 10 + (loadw value object fdefn-function-slot other-pointer-type) + (inst cmp value nil-value) + (let ((err-lab (generate-error-code vop undefined-symbol-error object))) + (inst jmp :e err-lab)))) + +(define-vop (set-fdefn-function) + (:policy :fast-safe) + (:translate (setf fdefn-function)) + (:args (function :scs (descriptor-reg) :target result) + (fdefn :scs (descriptor-reg))) + (:temporary (:sc dword-reg) raw) + (:temporary (:sc byte-reg) type) + (:results (result :scs (descriptor-reg))) + (:generator 38 + (load-type type function (- function-pointer-type)) + (inst lea raw + (make-ea :byte :base function + :disp (- (* function-code-offset word-bytes) + function-pointer-type))) + (inst cmp type function-header-type) + (inst jmp :e normal-fn) + (inst lea raw (make-fixup (extern-alien-name "closure_tramp") :foreign)) + NORMAL-FN + (storew function fdefn fdefn-function-slot other-pointer-type) + (storew raw fdefn fdefn-raw-addr-slot other-pointer-type) + (move result function))) + +(define-vop (fdefn-makunbound) + (:policy :fast-safe) + (:translate fdefn-makunbound) + (:args (fdefn :scs (descriptor-reg) :target result)) + (:results (result :scs (descriptor-reg))) + (:generator 38 + (storew nil-value fdefn fdefn-function-slot other-pointer-type) + (storew (make-fixup (extern-alien-name "undefined_tramp") :foreign) + fdefn fdefn-raw-addr-slot other-pointer-type) + (move result fdefn))) + + + +;;;; Binding and Unbinding. + +;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and +;;; the symbol on the binding stack and stuff the new value into the +;;; symbol. + +(define-vop (bind) + (:args (val :scs (any-reg descriptor-reg)) + (symbol :scs (descriptor-reg))) + (:temporary (:sc dword-reg) temp bsp) + (:generator 5 + (load-symbol-value bsp lisp::*binding-stack-pointer*) + (loadw temp symbol symbol-value-slot other-pointer-type) + (inst add bsp (* binding-size word-bytes)) + (store-symbol-value bsp lisp::*binding-stack-pointer*) + (storew temp bsp (- binding-value-slot binding-size)) + (storew symbol bsp (- binding-symbol-slot binding-size)) + (storew val symbol symbol-value-slot other-pointer-type))) + +(define-vop (unbind) + (:temporary (:sc dword-reg) symbol value bsp) + (:generator 0 + (load-symbol-value bsp lisp::*binding-stack-pointer*) + (loadw symbol bsp (- binding-symbol-slot binding-size)) + (loadw value bsp (- binding-value-slot binding-size)) + (storew value symbol symbol-value-slot other-pointer-type) + (storew 0 bsp (- binding-symbol-slot binding-size)) + (inst sub bsp (* binding-size word-bytes)) + (store-symbol-value bsp lisp::*binding-stack-pointer*))) + + +(define-vop (unbind-to-here) + (:args (where :scs (descriptor-reg any-reg))) + (:temporary (:sc dword-reg) symbol value bsp) + (:generator 0 + (load-symbol-value bsp lisp::*binding-stack-pointer*) + (inst cmp where bsp) + (inst jmp :e done) + + LOOP + (loadw symbol bsp (- binding-symbol-slot binding-size)) + (inst or symbol symbol) + (inst jmp :z skip) + (loadw value bsp (- binding-value-slot binding-size)) + (storew value symbol symbol-value-slot other-pointer-type) + (storew 0 bsp (- binding-symbol-slot binding-size)) + + SKIP + (inst sub bsp (* binding-size word-bytes)) + (inst cmp where bsp) + (inst jmp :ne loop) + (store-symbol-value bsp lisp::*binding-stack-pointer*) + + DONE)) + + + +;;;; Closure indexing. + +(define-full-reffer closure-index-ref * + closure-info-offset function-pointer-type + (any-reg descriptor-reg) * %closure-index-ref) + +(define-full-setter set-funcallable-instance-info * + funcallable-instance-info-offset function-pointer-type + (any-reg descriptor-reg) * %set-funcallable-instance-info) + +(define-full-reffer funcallable-instance-info * + funcallable-instance-info-offset function-pointer-type + (descriptor-reg any-reg) * %funcallable-instance-info) + +(define-vop (funcallable-instance-lexenv cell-ref) + (:variant funcallable-instance-lexenv-slot function-pointer-type)) + +(define-vop (closure-ref slot-ref) + (:variant closure-info-offset function-pointer-type)) + +(define-vop (closure-init slot-set) + (:variant closure-info-offset function-pointer-type)) + + +;;;; Value Cell hackery. + +(define-vop (value-cell-ref cell-ref) + (:variant value-cell-value-slot other-pointer-type)) + +(define-vop (value-cell-set cell-set) + (:variant value-cell-value-slot other-pointer-type)) + + +;;;; Structure hackery: + +(define-vop (instance-length) + (:policy :fast-safe) + (:translate %instance-length) + (:args (struct :scs (descriptor-reg))) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 4 + (loadw res struct 0 instance-pointer-type) + (inst shr res type-bits))) + +(define-vop (instance-ref slot-ref) + (:variant instance-slots-offset instance-pointer-type) + (:policy :fast-safe) + (:translate %instance-ref) + (:arg-types instance (:constant index))) + +(define-vop (instance-set slot-set) + (:policy :fast-safe) + (:translate %instance-set) + (:variant instance-slots-offset instance-pointer-type) + (:arg-types instance (:constant index) *)) + +(define-full-reffer instance-index-ref * instance-slots-offset + instance-pointer-type (any-reg descriptor-reg) * %instance-ref) + +(define-full-setter instance-index-set * instance-slots-offset + instance-pointer-type (any-reg descriptor-reg) * %instance-set) + + + +;;;; Code object frobbing. + +(define-full-reffer code-header-ref * 0 other-pointer-type + (any-reg descriptor-reg) * code-header-ref) + +(define-full-setter code-header-set * 0 other-pointer-type + (any-reg descriptor-reg) * code-header-set) + + + diff --git a/compiler/x86/char.lisp b/compiler/x86/char.lisp new file mode 100644 index 000000000..6fdf6bd3d --- /dev/null +++ b/compiler/x86/char.lisp @@ -0,0 +1,171 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/char.lisp,v 1.1 1997/01/18 14:31:20 ram Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the x86 VM definition of character operations. +;;; +;;; Written by Rob MacLachlan +;;; Converted for the MIPS R2000 by Christopher Hoover. +;;; And then to the SPARC by William Lott. +;;; And then to the x86, again by William. +;;; +;;; Debugged by Paul F. Werkowski, June-95. +;;; +(in-package :x86) + + + +;;;; Moves and coercions: + +;;; Move a tagged char to an untagged representation. +;;; +(define-vop (move-to-base-char) + (:args (x :scs (any-reg immediate-stack) :target al)) + (:temporary (:sc byte-reg :offset al-offset + :from (:argument 0) :to (:eval 0)) al) + (:ignore al) + (:temporary (:sc byte-reg :offset ah-offset :target y + :from (:argument 0) :to (:result 0)) ah) + (:results (y :scs (base-char-reg base-char-stack))) + (:note "character untagging") + (:generator 1 + (move eax-tn x) + (move y ah))) +;;; +(define-move-vop move-to-base-char :move + (any-reg immediate-stack) (base-char-reg base-char-stack)) + + +;;; Move an untagged char to a tagged representation. +;;; +(define-vop (move-from-base-char) + (:args (x :scs (base-char-reg base-char-stack) :target ah)) + (:temporary (:sc byte-reg :offset al-offset :target y + :from (:argument 0) :to (:result 0)) al) + (:temporary (:sc byte-reg :offset ah-offset + :from (:argument 0) :to (:result 0)) ah) + (:results (y :scs (any-reg descriptor-reg immediate-stack))) + (:note "character tagging") + (:generator 1 + (move ah x) ; maybe move char byte + (inst mov al base-char-type) ; #x86 to type bits + (inst and eax-tn #xffff) ; remove any junk bits + (move y eax-tn))) + +;;; +(define-move-vop move-from-base-char :move + (base-char-reg base-char-stack) (any-reg descriptor-reg immediate-stack)) + +;;; Move untagged base-char values. +;;; +(define-vop (base-char-move) + (:args (x :target y + :scs (base-char-reg) + :load-if (not (location= x y)))) + (:results (y :scs (base-char-reg base-char-stack) + :load-if (not (location= x y)))) + (:note "character move") + (:effects) + (:affected) + (:generator 0 + (move y x))) +;;; +(define-move-vop base-char-move :move + (base-char-reg) (base-char-reg base-char-stack)) + + +;;; Move untagged base-char arguments/return-values. +;;; +(define-vop (move-base-char-argument) + (:args (x :target y + :scs (base-char-reg)) + (fp :scs (any-reg) + :load-if (not (sc-is y base-char-reg)))) + (:results (y)) + (:note "character arg move") + (:generator 0 + (sc-case y + (base-char-reg + (move y x)) + (base-char-stack + (inst mov + (make-ea :byte :base fp :disp (- (* (1+ (tn-offset y)) 4))) + x))))) +;;; +(define-move-vop move-base-char-argument :move-argument + (any-reg base-char-reg) (base-char-reg)) + + +;;; Use standard MOVE-ARGUMENT + coercion to move an untagged base-char +;;; to a descriptor passing location. +;;; +(define-move-vop move-argument :move-argument + (base-char-reg) (any-reg descriptor-reg)) + + + +;;;; Other operations: + +(define-vop (char-code) + (:translate char-code) + (:policy :fast-safe) + (:args (ch :scs (base-char-reg base-char-stack))) + (:arg-types base-char) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 1 + (inst movzx res ch))) + +(define-vop (code-char) + (:translate code-char) + (:policy :fast-safe) + (:args (code :scs (unsigned-reg unsigned-stack) :target eax)) + (:arg-types positive-fixnum) + (:temporary (:sc dword-reg :offset eax-offset :target res + :from (:argument 0) :to (:result 0)) + eax) + (:results (res :scs (base-char-reg))) + (:result-types base-char) + (:generator 1 + (move eax code) + (move res al-tn))) + + +;;; Comparison of base-chars. +;;; +(define-vop (base-char-compare) + (:args (x :scs (base-char-reg base-char-stack)) + (y :scs (base-char-reg) + :load-if (not (and (sc-is x base-char-reg) + (sc-is y base-char-stack))))) + (:arg-types base-char base-char) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:note "inline comparison") + (:variant-vars condition not-condition) + (:generator 3 + (inst cmp x y) + (inst jmp (if not-p not-condition condition) target))) + +(define-vop (fast-char=/base-char base-char-compare) + (:translate char=) + (:variant :e :ne)) + +(define-vop (fast-char</base-char base-char-compare) + (:translate char<) + (:variant :b :nb)) + +(define-vop (fast-char>/base-char base-char-compare) + (:translate char>) + (:variant :a :na)) + diff --git a/compiler/x86/debug.lisp b/compiler/x86/debug.lisp new file mode 100644 index 000000000..741804fec --- /dev/null +++ b/compiler/x86/debug.lisp @@ -0,0 +1,181 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/debug.lisp,v 1.1 1997/01/18 14:31:21 ram Exp $") +;;; +;;; ********************************************************************** +;;; +;;; Compiler support for the new whizzy debugger. +;;; +;;; Written by William Lott. +;;; +;;; Debugged by Paul F. Werkowski Spring/Summer 1995. +;;; Debugged by Douglas Crosher 1996. +;;; +(in-package :x86) + +(defknown di::stack-ref (system-area-pointer index) + #-x86 t #+x86 (unsigned-byte 32) (flushable)) +(define-vop (debug-cur-sp) + (:translate current-sp) + (:policy :fast-safe) + (:results (res :scs (sap-reg sap-stack))) + (:result-types system-area-pointer) + (:generator 1 + (move res esp-tn))) + +(define-vop (debug-cur-fp) + (:translate current-fp) + (:policy :fast-safe) + (:results (res :scs (sap-reg sap-stack))) + (:result-types system-area-pointer) + (:generator 1 + (move res ebp-tn))) + +#+nil +(define-vop (read-control-stack) + (:translate kernel:stack-ref) + (:policy :fast-safe) + (:args (sap :scs (sap-reg) :to (:argument 1)) + (offset :scs (any-reg) :to (:argument 0) :target temp)) + (:arg-types system-area-pointer tagged-num) + (:temporary (:sc dword-reg :from (:argument 0)) temp) + (:results (result :scs (descriptor-reg))) + (:result-types *) + (:generator 9 + (move temp offset) + (inst neg temp) + (inst sub temp (fixnum 1)) + (inst mov result (make-ea :dword :base sap :index temp)))) + +;;; Unlike the RISC implementations, the control stack also is a number +;;; stack and not just descriptors live there. + +(define-vop (read-control-stack) + (:translate kernel:stack-ref) + (:policy :fast-safe) + (:args (sap :scs (sap-reg) :to :eval) ; NOTE lifetime stuff IMPORTANT (why?) + (offset :scs (any-reg) :target temp)) + (:arg-types system-area-pointer positive-fixnum) + (:temporary (:sc dword-reg :from (:argument 1)) temp) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 9 + (move temp offset) + (inst neg temp) + (inst mov result + (make-ea :dword :base sap :disp (- word-bytes) :index temp)))) + +(define-vop (read-control-stack-c) + (:translate kernel:stack-ref) + (:policy :fast-safe) + (:args (sap :scs (sap-reg))) + (:info index) + (:arg-types system-area-pointer (:constant (signed-byte 32))) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 5 + (inst mov result (make-ea :dword :base sap + :disp (- (* (1+ index) word-bytes)))))) + +(define-vop (write-control-stack) + (:translate %set-stack-ref) + (:policy :fast-safe) + (:args (sap :scs (sap-reg) :to :eval) + (offset :scs (any-reg) :target temp) + (value :scs (descriptor-reg) :to :result :target result)) + (:arg-types system-area-pointer positive-fixnum *) + (:temporary (:sc dword-reg :from (:argument 1) :to :result) temp) + (:results (result :scs (descriptor-reg))) + (:result-types *) + (:generator 9 + (move temp offset) + (inst neg temp) + (inst mov + (make-ea :dword :base sap :disp (- word-bytes) :index temp) value) + (move result value))) + +(define-vop (write-control-stack-c) + (:translate %set-stack-ref) + (:policy :fast-safe) + (:args (sap :scs (sap-reg)) + (value :scs (descriptor-reg) :target result)) + (:info index) + (:arg-types system-area-pointer (:constant (signed-byte 30)) *) + (:results (result :scs (descriptor-reg))) + (:result-types *) + (:generator 5 + (inst mov (make-ea :dword :base sap + :disp (- (* (1+ index) word-bytes))) + value) + (move result value))) + +(define-vop (code-from-mumble) + (:policy :fast-safe) + (:args (thing :scs (descriptor-reg))) + (:results (code :scs (descriptor-reg))) + (:temporary (:sc dword-reg) temp) + (:variant-vars lowtag) + (:generator 5 + (let ((bogus (gen-label)) + (done (gen-label))) + (loadw temp thing 0 lowtag) + (inst shr temp type-bits) + (inst jmp :z bogus) + (inst shl temp (1- (integer-length word-bytes))) + (unless (= lowtag other-pointer-type) + (inst add temp (- lowtag other-pointer-type))) + (move code thing) + (inst sub code temp) + (emit-label done) + (assemble (*elsewhere*) + (emit-label bogus) + (inst mov code nil-value) + (inst jmp done))))) + +(define-vop (code-from-lra code-from-mumble) + (:translate di::lra-code-header) + (:variant other-pointer-type)) + +(define-vop (code-from-function code-from-mumble) + (:translate di::function-code-header) + (:variant function-pointer-type)) + +(define-vop (make-lisp-obj) + (:policy :fast-safe) + (:translate di::make-lisp-obj) + (:args (value :scs (unsigned-reg unsigned-stack) :target result)) + (:arg-types unsigned-num) + (:results (result :scs (descriptor-reg) + :load-if (not (sc-is value unsigned-reg)) + )) + (:generator 1 + (move result value))) + +(define-vop (get-lisp-obj-address) + (:policy :fast-safe) + (:translate di::get-lisp-obj-address) + (:args (thing :scs (descriptor-reg descriptor-stack) :target result)) + (:results (result :scs (unsigned-reg) + :load-if (not (and (sc-is thing descriptor-reg) + (sc-is result unsigned-stack))))) + (:result-types unsigned-num) + (:generator 1 + (move result thing))) + + +(define-vop (function-word-offset) + (:policy :fast-safe) + (:translate di::function-word-offset) + (:args (fun :scs (descriptor-reg))) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 5 + (loadw res fun 0 function-pointer-type) + (inst shr res type-bits))) diff --git a/compiler/x86/float.lisp b/compiler/x86/float.lisp new file mode 100644 index 000000000..17394037e --- /dev/null +++ b/compiler/x86/float.lisp @@ -0,0 +1,2252 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/float.lisp,v 1.1 1997/01/18 14:31:17 ram Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains floating point support for the x86. +;;; +;;; Written by William Lott. +;;; +;;; Debugged by Paul F. Werkowski Spring/Summer 1995. +;;; +;;; Re-written and enhanced by Douglas Crosher, 1996. +;;; +(in-package :x86) + + + + +(defmacro ea-for-xf-desc(tn slot) + `(make-ea + :dword :base ,tn :disp (- (* ,slot vm:word-bytes) vm:other-pointer-type))) + +(defun ea-for-sf-desc(tn) + (ea-for-xf-desc tn vm:single-float-value-slot)) + +(defun ea-for-df-desc(tn) + (ea-for-xf-desc tn vm:double-float-value-slot)) + +(defmacro ea-for-xf-stack(tn kind) + `(make-ea + :dword :base ebp-tn + :disp (- (* (+ (tn-offset ,tn) (case ,kind (:single 1) (:double 2))) + vm:word-bytes)))) + +(defun ea-for-sf-stack(tn) + (ea-for-xf-stack tn :single)) + +(defun ea-for-df-stack(tn) + (ea-for-xf-stack tn :double)) + +;;;; Move functions: + +;;; x is source, y is destination +(define-move-function (load-single 6) (vop x y) + ((single-stack) (single-reg)) + (with-empty-tn@fp-top(y) + (inst fld (ea-for-sf-stack x)))) + +(define-move-function (store-single 6) (vop x y) + ((single-reg) (single-stack)) + (if (zerop (tn-offset x)) + (inst fst (ea-for-sf-stack y)) + (progn + (inst fxch x) + (inst fst (ea-for-sf-stack y)) + ;; This may not be necessary as ST0 is likely invalid now. + (inst fxch x)))) + +(define-move-function (load-double 6) (vop x y) + ((double-stack) (double-reg)) + (with-empty-tn@fp-top(y) + (inst fldd (ea-for-df-stack x)))) + +(define-move-function (store-double 6) (vop x y) + ((double-reg) (double-stack)) + (if (zerop (tn-offset x)) + (inst fstd (ea-for-df-stack y)) + (progn + (inst fxch x) + (inst fstd (ea-for-df-stack y)) + ;; This may not be necessary as ST0 is likely invalid now. + (inst fxch x)))) + +;;; The i387 has instructions to load some useful constants. +;;; This doesn't save much time but might cut down on memory +;;; access and reduce the size of the constant vector (CV). +;;; Intel claims they are stored in a more precise form on chip. +;;; Anyhow, might as well use the feature. It can be turned +;;; off by hacking the "immediate-constant-sc" in vm.lisp. +(define-move-function (load-fp-constant 6) (vop x y) + ((fp-single-constant)(single-reg) + (fp-double-constant)(double-reg)) + + (let ((value (c::constant-value (c::tn-leaf x)))) + (with-empty-tn@fp-top(y) + (cond ((zerop value) + (inst fldz)) + ((or (= value 1s0)(= value 1d0)) + (inst fld1)) + ((= value #.pi) + (inst fldpi)) + ((= value #.i387-l2t) + (inst fldl2t)) + ((= value #.i387-l2e) + (inst fldl2e)) + ((= value #.i387-lg2) + (inst fldlg2)) + ((= value #.i387-ln2) + (inst fldln2)) + (t (warn "Ignoring bogus i387 Constant ~a" value)))))) + + +;;;; Move VOPs: + +;;; +;;; Float register to register moves. +;;; +(define-vop (single-move) + (:args (x :scs (single-reg) :target y + :load-if (not (and (sc-is x single-stack) + (sc-is y single-stack) + (location= x y))))) + (:results (y :scs (single-reg) + :load-if (not (and (sc-is x single-stack) + (sc-is y single-stack) + (location= x y))))) + (:note "float move") + (:generator 0 + (unless (location= x y) + (cond ((zerop (tn-offset y)) + (inst fxch x) + (inst fst x)) + ((zerop (tn-offset x)) + (inst fst y)) + (t + (inst fxch x) + (inst fst y) + (inst fxch x)))))) +(define-move-vop single-move :move (single-reg) (single-reg)) + +(define-vop (double-move) + (:args (x :scs (double-reg) :target y + :load-if (not (and (sc-is x double-stack) + (sc-is y double-stack) + (location= x y))))) + (:results (y :scs (double-reg) + :load-if (not (and (sc-is x double-stack) + (sc-is y double-stack) + (location= x y))))) + (:note "float move") + (:generator 0 + (unless (location= x y) + (cond ((zerop (tn-offset y)) + (inst fxch x) + (inst fstd x)) + ((zerop (tn-offset x)) + (inst fstd y)) + (t + (inst fxch x) + (inst fstd y) + (inst fxch x)))))) +(define-move-vop double-move :move (double-reg) (double-reg)) + + +;;; +;;; Move from float to a descriptor reg. allocating a new float +;;; object in the process. +;;; +(define-vop (move-from-single) + (:args (x :scs (single-reg) :to :save + :load-if (not (sc-is x fp-single-constant)) + )) + (:results (y :scs (descriptor-reg))) + (:temporary (:sc dword-reg) ndescr) + (:note "float to pointer coercion") + (:generator 13 + (if (sc-is x fp-single-constant) + (ecase (c::constant-value (c::tn-leaf x)) + (0s0 + (load-symbol-value y *fp-constant-0s0*)) + (1s0 + (load-symbol-value y *fp-constant-1s0*))) + (with-fixed-allocation (y ndescr vm:single-float-type + vm:single-float-size) + (with-tn@fp-top(x) + (inst fst (make-ea :dword :base y + :disp (- (* vm:single-float-value-slot + vm:word-bytes) + vm:other-pointer-type)))))))) +(define-move-vop move-from-single :move + (single-reg) (descriptor-reg)) + +(define-vop (move-from-double) + (:args (x :scs (double-reg) :to :save + :load-if (not (sc-is x fp-double-constant)) + )) + (:results (y :scs (descriptor-reg))) + (:temporary (:sc dword-reg) ndescr) + (:note "float to pointer coercion") + (:generator 13 + (if (sc-is x fp-double-constant) + (ecase (c::constant-value (c::tn-leaf x)) + (0d0 + (load-symbol-value y *fp-constant-0d0*)) + (1d0 + (load-symbol-value y *fp-constant-1d0*))) + (with-fixed-allocation (y ndescr vm:double-float-type + vm:double-float-size) + (with-tn@fp-top(x) + (inst fstd (make-ea :dword :base y + :disp (- (* vm:double-float-value-slot + vm:word-bytes) + vm:other-pointer-type)))))))) +(define-move-vop move-from-double :move + (double-reg) (descriptor-reg)) + +;;; +;;; Move from a descriptor to a float register +;;; +(macrolet ((frob (name sc double-p) + `(progn + (define-vop (,name) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (,sc))) + (:note "pointer to float coercion") + (:generator 2 + (with-empty-tn@fp-top(y) + ,@(if double-p + '((inst fldd (ea-for-df-desc x))) + '((inst fld (ea-for-sf-desc x))))))) + (define-move-vop ,name :move (descriptor-reg) (,sc))))) + (frob move-to-single single-reg nil) + (frob move-to-double double-reg t)) + +;;; +;;; The move argument vops. +;;; +;;; Note these are also used to stuffs fp numbers onto the c-call +;;; stack so the order is different than the lisp-stack. + +;;; The general move-argument vop +(macrolet ((frob (name sc stack-sc double-p) + `(progn + (define-vop (,name) + (:args (x :scs (,sc) :target y) + (fp :scs (any-reg) + :load-if (not (sc-is y ,sc)))) + (:results (y)) + (:note "float argument move") + (:generator ,(if double-p 3 2) + (sc-case y + (,sc + (unless (location= x y) + (cond ((zerop (tn-offset y)) + (inst fxch x) + (inst fstd x)) + ((zerop (tn-offset x)) + (inst fstd y)) + (t + (inst fxch x) + (inst fstd y) + (inst fxch x))))) + (,stack-sc + (if (= (tn-offset fp) esp-offset) + (let* ((offset (* (tn-offset y) word-bytes)) + (ea (make-ea :dword :base fp :disp offset))) + (with-tn@fp-top(x) + ,@(if double-p + '((inst fstd ea)) + '((inst fst ea))))) + (let ((ea (make-ea + :dword :base fp + :disp (- (* (+ (tn-offset y) + ,(if double-p 2 1)) + vm:word-bytes))))) + (with-tn@fp-top(x) + ,@(if double-p + '((inst fstd ea)) + '((inst fst ea)))))))))) + (define-move-vop ,name :move-argument + (,sc descriptor-reg) (,sc))))) + (frob move-single-float-argument single-reg single-stack nil) + (frob move-double-float-argument double-reg double-stack t)) + + +;;; +(define-move-vop move-argument :move-argument + (single-reg double-reg) (descriptor-reg any-reg)) + + +;;;; Arithmetic VOPs: + +;;; dtc: The floating point arithmetic vops. +;;; +;;; Note: Although these can accept x and y on the stack or pointed to +;;; from a descriptor register, they will work with register loading +;;; without these. Same deal with the result - it need only be a +;;; register. When load-tns are needed they will probably be in ST0 +;;; and the code below should be able to correctly handle all cases. +;;; +;;; However it seems to produce better code if all arg. and result +;;; options are used; on the P86 there is no extra cost in using a +;;; memory operand to the FP instructions - not so on the PPro. +;;; +;;; It may also be useful to handle constant args? +(macrolet + ((frob (op fop-sti fopr-sti + fop fopr sname scost + fopd foprd dname dcost) + `(progn + (define-vop (,sname) + (:translate ,op) + (:args (x :scs (single-reg single-stack descriptor-reg) + :to :eval) + (y :scs (single-reg single-stack descriptor-reg) + :to :eval)) + (:temporary (:sc single-reg :offset fr0-offset + :from :eval :to :result) fr0) + (:results (r :scs (single-reg single-stack))) + (:arg-types single-float single-float) + (:result-types single-float) + (:policy :fast-safe) + (:note "inline float arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:node-var node) + (:generator ,scost + ;; Handle a few special cases + (cond + ;; x, y, and r are the same register. + ((and (sc-is x single-reg) (location= x r) (location= y r)) + (cond ((zerop (tn-offset r)) + (inst ,fop fr0)) + (t + (inst fxch r) + ;; XX the source register will not be valid + (note-next-instruction vop :internal-error) + (inst ,fop fr0) + (inst fxch r)))) + + ;; x and r are the same register. + ((and (sc-is x single-reg) (location= x r)) + (if (zerop (tn-offset r)) + (sc-case y + (single-reg + ;; ST(0) = ST(0) op ST(y) + (inst ,fop y)) + ((single-stack descriptor-reg) + ;; ST(0) = ST(0) op Mem + (if (sc-is y single-stack) + (inst ,fop (ea-for-sf-stack y)) + (inst ,fop (ea-for-sf-desc y))))) + (progn + ;; y to ST0 + (sc-case y + (single-reg + (unless (zerop (tn-offset y)) + (inst fxch y) + (inst fst y))) ; save in original slot + ((single-stack descriptor-reg) + (inst fstp fr0) + (if (sc-is y single-stack) + (inst fld (ea-for-sf-stack y)) + (inst fld (ea-for-sf-desc y))) + ;; ST(i) = ST(i) op ST0 + (inst ,fop-sti r))))) + (when (policy node (or (= debug 3) (> safety speed))) + (note-next-instruction vop :internal-error) + (inst wait))) + ;; y and r are the same register. + ((and (sc-is y single-reg) (location= y r)) + (if (zerop (tn-offset r)) + (sc-case x + (single-reg + ;; ST(0) = ST(x) op ST(0) + (inst ,fopr x)) + ((single-stack descriptor-reg) + ;; ST(0) = Mem op ST(0) + (if (sc-is x single-stack) + (inst ,fopr (ea-for-sf-stack x)) + (inst ,fopr (ea-for-sf-desc x))))) + (progn + ;; x to ST0 + (sc-case x + (single-reg + (unless (zerop (tn-offset x)) + (inst fxch x) ; x to top + (inst fst x))) ; save in original slot + ((single-stack descriptor-reg) + (inst fstp fr0) + (if (sc-is x single-stack) + (inst fld (ea-for-sf-stack x)) + (inst fld (ea-for-sf-desc x))))) + ;; ST(i) = ST(0) op ST(i) + (inst ,fopr-sti r))) + (when (policy node (or (= debug 3) (> safety speed))) + (note-next-instruction vop :internal-error) + (inst wait))) + ;; The default case + (t + ;; Get the result to ST0. + + ;; Special handling is needed if x or y are in ST0, and + ;; simpler code is generated. + (cond + ;; x is in ST0 + ((and (sc-is x single-reg) (zerop (tn-offset x))) + ;; ST0 = ST0 op y + (sc-case y + (single-reg + (inst ,fop y)) + (single-stack + (inst ,fop (ea-for-sf-stack y))) + (descriptor-reg + (inst ,fop (ea-for-sf-desc y))))) + ;; y is in ST0 + ((and (sc-is y single-reg) (zerop (tn-offset y))) + ;; ST0 = x op ST0 + (sc-case x + (single-reg + (inst ,fopr x)) + (single-stack + (inst ,fopr (ea-for-sf-stack x))) + (descriptor-reg + (inst ,fopr (ea-for-sf-desc x))))) + (t + ;; x to ST0 + (sc-case x + (single-reg + (inst fxch x) ; x to top + (inst fst x)) ; save in original slot + ((single-stack descriptor-reg) + (inst fstp fr0) + (if (sc-is x single-stack) + (inst fld (ea-for-sf-stack x)) + (inst fld (ea-for-sf-desc x))))) + ;; ST0 = ST0 op y + (sc-case y + (single-reg + (inst ,fop y)) + (single-stack + (inst ,fop (ea-for-sf-stack y))) + (descriptor-reg + (inst ,fop (ea-for-sf-desc y)))))) + + (note-next-instruction vop :internal-error) + + ;; Finally save the result + (sc-case r + (single-reg + (cond ((zerop (tn-offset r)) + (when (policy node (or (= debug 3) (> safety speed))) + (inst wait))) + (t + (inst fst r)))) + (single-stack + (inst fst (ea-for-sf-stack r)))))))) + + (define-vop (,dname) + (:translate ,op) + (:args (x :scs (double-reg double-stack descriptor-reg) + :to :eval) + (y :scs (double-reg double-stack descriptor-reg) + :to :eval)) + (:temporary (:sc double-reg :offset fr0-offset + :from :eval :to :result) fr0) + (:results (r :scs (double-reg double-stack))) + (:arg-types double-float double-float) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline float arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:node-var node) + (:generator ,dcost + ;; Handle a few special cases + (cond + ;; x, y, and r are the same register. + ((and (sc-is x double-reg) (location= x r) (location= y r)) + (cond ((zerop (tn-offset r)) + (inst ,fop fr0)) + (t + (inst fxch x) + (inst ,fopd fr0) + ;; XX the source register will not be valid. + (note-next-instruction vop :internal-error) + (inst fxch r)))) + + ;; x and r are the same register. + ((and (sc-is x double-reg) (location= x r)) + (if (zerop (tn-offset r)) + (sc-case y + (double-reg + ;; ST(0) = ST(0) op ST(y) + (inst ,fopd y)) + ((double-stack descriptor-reg) + ;; ST(0) = ST(0) op Mem + (if (sc-is y double-stack) + (inst ,fopd (ea-for-df-stack y)) + (inst ,fopd (ea-for-df-desc y))))) + (progn + ;; y to ST0 + (sc-case y + (double-reg + (unless (zerop (tn-offset y)) + (inst fxch y) + (inst fstd y))) ; save in original slot + ((double-stack descriptor-reg) + (inst fstp fr0) + (if (sc-is y double-stack) + (inst fldd (ea-for-df-stack y)) + (inst fldd (ea-for-df-desc y))))) + ;; ST(i) = ST(i) op ST0 + (inst ,fop-sti r))) + (when (policy node (or (= debug 3) (> safety speed))) + (note-next-instruction vop :internal-error) + (inst wait))) + + ;; y and r are the same register. + ((and (sc-is y double-reg) (location= y r)) + (if (zerop (tn-offset r)) + (sc-case x + (double-reg + ;; ST(0) = ST(x) op ST(0) + (inst ,foprd x)) + ((double-stack descriptor-reg) + ;; ST(0) = Mem op ST(0) + (if (sc-is x double-stack) + (inst ,foprd (ea-for-df-stack x)) + (inst ,foprd (ea-for-df-desc x))))) + (progn + ;; x to ST0 + (sc-case x + (double-reg + (unless (zerop (tn-offset x)) + (inst fxch x) ; x to top + (inst fst x))) ; save in original slot + ((double-stack descriptor-reg) + (inst fstp fr0) + (if (sc-is x double-stack) + (inst fldd (ea-for-df-stack x)) + (inst fldd (ea-for-df-desc x))))) + ;; ST(i) = ST(0) op ST(i) + (inst ,fopr-sti r))) + (when (policy node (or (= debug 3) (> safety speed))) + (note-next-instruction vop :internal-error) + (inst wait))) + ;; The default case + (t + ;; Get the result to ST0. + + ;; Special handling is needed if x or y are in ST0, and + ;; simpler code is generated. + (cond + ;; x is in ST0 + ((and (sc-is x double-reg) (zerop (tn-offset x))) + ;; ST0 = ST0 op y + (sc-case y + (double-reg + (inst ,fopd y)) + (double-stack + (inst ,fopd (ea-for-df-stack y))) + (descriptor-reg + (inst ,fopd (ea-for-df-desc y))))) + ;; y is in ST0 + ((and (sc-is y double-reg) (zerop (tn-offset y))) + ;; ST0 = x op ST0 + (sc-case x + (double-reg + (inst ,foprd x)) + (double-stack + (inst ,foprd (ea-for-df-stack x))) + (descriptor-reg + (inst ,foprd (ea-for-df-desc x))))) + (t + ;; x to ST0 + (sc-case x + (double-reg + (inst fxch x) ; x to top + (inst fst x)) ; save in original slot + ((double-stack descriptor-reg) + (inst fstp fr0) + (if (sc-is x double-stack) + (inst fldd (ea-for-df-stack x)) + (inst fldd (ea-for-df-desc x))))) + ;; ST0 = ST0 op y + (sc-case y + (double-reg + (inst ,fopd y)) + (double-stack + (inst ,fopd (ea-for-df-stack y))) + (descriptor-reg + (inst ,fopd (ea-for-df-desc y)))))) + + (note-next-instruction vop :internal-error) + + ;; Finally save the result + (sc-case r + (double-reg + (cond ((zerop (tn-offset r)) + (when (policy node (or (= debug 3) (> safety speed))) + (inst wait))) + (t + (inst fst r)))) + (double-stack + (inst fstd (ea-for-df-stack r))))))))))) + + (frob + fadd-sti fadd-sti + fadd fadd +/single-float 2 + faddd faddd +/double-float 2) + (frob - fsub-sti fsubr-sti + fsub fsubr -/single-float 2 + fsubd fsubrd -/double-float 2) + (frob * fmul-sti fmul-sti + fmul fmul */single-float 3 + fmuld fmuld */double-float 3) + (frob / fdiv-sti fdivr-sti + fdiv fdivr //single-float 12 + fdivd fdivrd //double-float 12)) + + +(macrolet ((frob (name inst translate sc type) + `(define-vop (,name) + (:args (x :scs (,sc) :target fr0)) + (:results (y :scs (,sc))) + (:translate ,translate) + (:policy :fast-safe) + (:arg-types ,type) + (:result-types ,type) + (:temporary (:sc double-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:ignore fr0) + (:note "inline float arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:generator 1 + (note-this-location vop :internal-error) + (unless (zerop (tn-offset x)) + (inst fxch x) ; x to top of stack + (unless (location= x y) + (inst fst x))) ; maybe save it + (inst ,inst) ; clobber st0 + (unless (zerop (tn-offset y)) + (inst fst y)))))) + + (frob abs/single-float fabs abs single-reg single-float) + (frob abs/double-float fabs abs double-reg double-float) + (frob %negate/single-float fchs %negate single-reg single-float) + (frob %negate/double-float fchs %negate double-reg double-float)) + + +;;;; Comparison: + +(define-vop (=/float) + (:args (x) (y)) + (:temporary (:sc word-reg :offset eax-offset :from :eval) temp) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:vop-var vop) + (:save-p :compute-only) + (:note "inline float comparison") + (:ignore temp) + (:generator 3 + (note-this-location vop :internal-error) + (cond + ;; x is in ST0; y is in any reg. + ((zerop (tn-offset x)) + (inst fucom y)) + ;; y is in ST0; x is in another reg. + ((zerop (tn-offset y)) + (inst fucom x)) + ;; x and y are the same register, not ST0 + ((location= x y) + (inst fxch x) + (inst fucom fr0-tn) + (inst fxch x)) + ;; x and y are different registers, neither ST0. + (t + (inst fxch x) + (inst fucom y) + (inst fxch x))) + (inst fnstsw) ; status word to %ea + (inst and ah-tn #x45) ; C3 C2 C0 + (inst cmp ah-tn #x40) + (inst jmp (if not-p :ne :e) target))) + +(define-vop (=/single-float =/float) + (:translate =) + (:args (x :scs (single-reg)) + (y :scs (single-reg))) + (:arg-types single-float single-float)) + +(define-vop (=/double-float =/float) + (:translate =) + (:args (x :scs (double-reg)) + (y :scs (double-reg))) + (:arg-types double-float double-float)) + + +(define-vop (<single-float) + (:translate <) + (:args (x :scs (single-reg single-stack descriptor-reg)) + (y :scs (single-reg single-stack descriptor-reg))) + (:arg-types single-float single-float) + (:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0) + (:temporary (:sc word-reg :offset eax-offset :from :eval) temp) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:vop-var vop) + (:save-p :compute-only) + (:note "inline float comparison") + (:ignore temp) + (:generator 3 + ;; Handle a few special cases + (cond + ;; y is ST0. + ((and (sc-is y single-reg) (zerop (tn-offset y))) + (sc-case x + (single-reg + (inst fcom x)) + ((single-stack descriptor-reg) + (if (sc-is x single-stack) + (inst fcom (ea-for-sf-stack x)) + (inst fcom (ea-for-sf-desc x))))) + (inst fnstsw) ; status word to %ea + (inst and ah-tn #x45)) + + ;; General case when y is not in ST0. + (t + ;; x to ST0 + (sc-case x + (single-reg + (unless (zerop (tn-offset x)) + (inst fxch x) ; x to top + (inst fst x))) ; save in original slot + ((single-stack descriptor-reg) + (inst fstp fr0) + (if (sc-is x single-stack) + (inst fld (ea-for-sf-stack x)) + (inst fld (ea-for-sf-desc x))))) + (sc-case y + (single-reg + (inst fcom y)) + ((single-stack descriptor-reg) + (if (sc-is y single-stack) + (inst fcom (ea-for-sf-stack y)) + (inst fcom (ea-for-sf-desc y))))) + (inst fnstsw) ; status word to %ea + (inst and ah-tn #x45) ; C3 C2 C0 + (inst cmp ah-tn #x01))) + (inst jmp (if not-p :ne :e) target))) + +(define-vop (<double-float) + (:translate <) + (:args (x :scs (double-reg double-stack descriptor-reg)) + (y :scs (double-reg double-stack descriptor-reg))) + (:arg-types double-float double-float) + (:temporary (:sc double-reg :offset fr0-offset :from :eval) fr0) + (:temporary (:sc word-reg :offset eax-offset :from :eval) temp) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:vop-var vop) + (:save-p :compute-only) + (:note "inline float comparison") + (:ignore temp) + (:generator 3 + ;; Handle a few special cases + (cond + ;; y is ST0. + ((and (sc-is y double-reg) (zerop (tn-offset y))) + (sc-case x + (double-reg + (inst fcomd x)) + ((double-stack descriptor-reg) + (if (sc-is x double-stack) + (inst fcomd (ea-for-df-stack x)) + (inst fcomd (ea-for-df-desc x))))) + (inst fnstsw) ; status word to %ea + (inst and ah-tn #x45)) + + ;; General case when y is not in ST0. + (t + ;; x to ST0 + (sc-case x + (double-reg + (unless (zerop (tn-offset x)) + (inst fxch x) ; x to top + (inst fstd x))) ; save in original slot + ((double-stack descriptor-reg) + (inst fstp fr0) + (if (sc-is x double-stack) + (inst fldd (ea-for-df-stack x)) + (inst fldd (ea-for-df-desc x))))) + (sc-case y + (double-reg + (inst fcomd y)) + ((double-stack descriptor-reg) + (if (sc-is y double-stack) + (inst fcomd (ea-for-df-stack y)) + (inst fcomd (ea-for-df-desc y))))) + (inst fnstsw) ; status word to %ea + (inst and ah-tn #x45) ; C3 C2 C0 + (inst cmp ah-tn #x01))) + (inst jmp (if not-p :ne :e) target))) + + +(define-vop (>single-float) + (:translate >) + (:args (x :scs (single-reg single-stack descriptor-reg)) + (y :scs (single-reg single-stack descriptor-reg))) + (:arg-types single-float single-float) + (:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0) + (:temporary (:sc word-reg :offset eax-offset :from :eval) temp) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:vop-var vop) + (:save-p :compute-only) + (:note "inline float comparison") + (:ignore temp) + (:generator 3 + ;; Handle a few special cases + (cond + ;; y is ST0. + ((and (sc-is y single-reg) (zerop (tn-offset y))) + (sc-case x + (single-reg + (inst fcom x)) + ((single-stack descriptor-reg) + (if (sc-is x single-stack) + (inst fcom (ea-for-sf-stack x)) + (inst fcom (ea-for-sf-desc x))))) + (inst fnstsw) ; status word to %ea + (inst and ah-tn #x45) + (inst cmp ah-tn #x01)) + + ;; General case when y is not in ST0. + (t + ;; x to ST0 + (sc-case x + (single-reg + (unless (zerop (tn-offset x)) + (inst fxch x) ; x to top + (inst fst x))) ; save in original slot + ((single-stack descriptor-reg) + (inst fstp fr0) + (if (sc-is x single-stack) + (inst fld (ea-for-sf-stack x)) + (inst fld (ea-for-sf-desc x))))) + (sc-case y + (single-reg + (inst fcom y)) + ((single-stack descriptor-reg) + (if (sc-is y single-stack) + (inst fcom (ea-for-sf-stack y)) + (inst fcom (ea-for-sf-desc y))))) + (inst fnstsw) ; status word to %ea + (inst and ah-tn #x45))) + (inst jmp (if not-p :ne :e) target))) + +(define-vop (>double-float) + (:translate >) + (:args (x :scs (double-reg double-stack descriptor-reg)) + (y :scs (double-reg double-stack descriptor-reg))) + (:arg-types double-float double-float) + (:temporary (:sc double-reg :offset fr0-offset :from :eval) fr0) + (:temporary (:sc word-reg :offset eax-offset :from :eval) temp) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:vop-var vop) + (:save-p :compute-only) + (:note "inline float comparison") + (:ignore temp) + (:generator 3 + ;; Handle a few special cases + (cond + ;; y is ST0. + ((and (sc-is y double-reg) (zerop (tn-offset y))) + (sc-case x + (double-reg + (inst fcomd x)) + ((double-stack descriptor-reg) + (if (sc-is x double-stack) + (inst fcomd (ea-for-df-stack x)) + (inst fcomd (ea-for-df-desc x))))) + (inst fnstsw) ; status word to %ea + (inst and ah-tn #x45) + (inst cmp ah-tn #x01)) + + ;; General case when y is not in ST0. + (t + ;; x to ST0 + (sc-case x + (double-reg + (unless (zerop (tn-offset x)) + (inst fxch x) ; x to top + (inst fstd x))) ; save in original slot + ((double-stack descriptor-reg) + (inst fstp fr0) + (if (sc-is x double-stack) + (inst fldd (ea-for-df-stack x)) + (inst fldd (ea-for-df-desc x))))) + (sc-case y + (double-reg + (inst fcomd y)) + ((double-stack descriptor-reg) + (if (sc-is y double-stack) + (inst fcomd (ea-for-df-stack y)) + (inst fcomd (ea-for-df-desc y))))) + (inst fnstsw) ; status word to %ea + (inst and ah-tn #x45))) + (inst jmp (if not-p :ne :e) target))) + +;;; Comparisons with 0 can use the FTST instruction. + +(define-vop (float-test) + (:args (x)) + (:temporary (:sc word-reg :offset eax-offset :from :eval) temp) + (:conditional) + (:info target not-p y) + (:variant-vars code) + (:policy :fast-safe) + (:vop-var vop) + (:save-p :compute-only) + (:note "inline float comparison") + (:ignore temp y) + (:generator 2 + (note-this-location vop :internal-error) + (cond + ;; x is in ST0 + ((zerop (tn-offset x)) + (inst ftst)) + ;; x not ST0 + (t + (inst fxch x) + (inst ftst) + (inst fxch x))) + (inst fnstsw) ; status word to %ea + (inst and ah-tn #x45) ; C3 C2 C0 + (unless (zerop code) + (inst cmp ah-tn code)) + (inst jmp (if not-p :ne :e) target))) + +(define-vop (=0/single-float float-test) + (:translate =) + (:args (x :scs (single-reg))) + (:arg-types single-float (:constant (single-float 0s0 0s0))) + (:variant #x40)) +(define-vop (=0/double-float float-test) + (:translate =) + (:args (x :scs (double-reg))) + (:arg-types double-float (:constant (double-float 0d0 0d0))) + (:variant #x40)) + +(define-vop (<0/single-float float-test) + (:translate <) + (:args (x :scs (single-reg))) + (:arg-types single-float (:constant (single-float 0s0 0s0))) + (:variant #x01)) +(define-vop (<0/double-float float-test) + (:translate <) + (:args (x :scs (double-reg))) + (:arg-types double-float (:constant (double-float 0d0 0d0))) + (:variant #x01)) + +(define-vop (>0/single-float float-test) + (:translate >) + (:args (x :scs (single-reg))) + (:arg-types single-float (:constant (single-float 0s0 0s0))) + (:variant #x00)) +(define-vop (>0/double-float float-test) + (:translate >) + (:args (x :scs (double-reg))) + (:arg-types double-float (:constant (double-float 0d0 0d0))) + (:variant #x00)) + + +;;;; Conversion: + +(macrolet ((frob (name translate to-sc to-type) + `(define-vop (,name) + (:args (x :scs (signed-stack signed-reg) :target temp)) + (:temporary (:sc signed-stack) temp) + (:results (y :scs (,to-sc))) + (:arg-types signed-num) + (:result-types ,to-type) + (:policy :fast-safe) + (:note "inline float coercion") + (:translate ,translate) + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (sc-case x + (signed-reg + (inst mov temp x) + (with-empty-tn@fp-top(y) + (note-this-location vop :internal-error) + (inst fild temp))) + (signed-stack + (with-empty-tn@fp-top(y) + (note-this-location vop :internal-error) + (inst fild x)))))))) + + (frob %single-float/signed %single-float single-reg single-float) + (frob %double-float/signed %double-float double-reg double-float)) + + + +;;; These should be no-ops but the compiler might want to move +;;; some things around +(macrolet ((frob (name translate from-sc from-type to-sc to-type) + `(define-vop (,name) + (:args (x :scs (,from-sc) :target y)) + (:results (y :scs (,to-sc))) + (:arg-types ,from-type) + (:result-types ,to-type) + (:policy :fast-safe) + (:note "inline float coercion") + (:translate ,translate) + (:vop-var vop) + (:save-p :compute-only) + (:generator 2 + (note-this-location vop :internal-error) + (unless (location= x y) + (cond + ((zerop (tn-offset x)) + ;; x is in ST0, y is in another reg. not ST0 + (inst fst y)) + ((zerop (tn-offset y)) + ;; y is in ST0, x is in another reg. not ST0 + (inst fxch x) + (inst fst x)) ; Restore x + (t + ;; Neither x or y are in ST0, and they are not in + ;; the same reg. + (inst fxch x) + (inst fst y) + (inst fxch x)))))))) + + (frob %single-float/double-float %single-float double-reg + double-float single-reg single-float) + (frob %double-float/single-float %double-float single-reg single-float + double-reg double-float)) + + + +(macrolet ((frob (trans from-sc from-type round-p) + `(define-vop (,(symbolicate trans "/" from-type)) + (:args (x :scs (,from-sc))) + (:temporary (:sc signed-stack) stack-temp) + ,@(unless round-p + '((:temporary (:sc unsigned-stack) scw) + (:temporary (:sc any-reg) rcw))) + (:results (y :scs (signed-reg))) + (:arg-types ,from-type) + (:result-types signed-num) + (:translate ,trans) + (:policy :fast-safe) + (:note "inline float truncate") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + (inst wait) ; Catch any pending FPE exceptions + ;; normal mode (for now) is "round to best" + (with-tn@fp-top(x) + ,@(unless round-p + '((inst fnstcw scw) ; save current control word + (move rcw scw) ; into 16-bit register + (inst or rcw (ash #b11 10)) ; CHOP + (move stack-temp rcw) + (inst fldcw stack-temp))) + (sc-case y + (signed-stack + (inst fist y)) + (signed-reg + (inst fist stack-temp) + (inst mov y stack-temp))) + ,@(unless round-p + '((inst fldcw scw)))))))) + + (frob %unary-truncate single-reg single-float nil) + (frob %unary-truncate double-reg double-float nil) + + #-sun4 + (frob %unary-round single-reg single-float t) + #-sun4 + (frob %unary-round double-reg double-float t)) + +#+sun4 +(deftransform %unary-round ((x) (float) (signed-byte 32)) + '(let* ((trunc (truly-the (signed-byte 32) (%unary-truncate x))) + (extra (- x trunc)) + (absx (abs extra)) + (one-half (float 1/2 x))) + (if (if (oddp trunc) + (>= absx one-half) + (> absx one-half)) + (truly-the (signed-byte 32) (%unary-truncate (+ x extra))) + trunc))) + +(define-vop (make-single-float) + (:args (bits :scs (signed-reg) :target res + :load-if (not (or (and (sc-is bits signed-stack) + (sc-is res single-reg)) + (and (sc-is bits signed-stack) + (sc-is res single-stack) + (location= bits res)))))) + (:results (res :scs (single-reg single-stack))) + (:temporary (:sc signed-stack) stack-temp) + (:arg-types signed-num) + (:result-types single-float) + (:translate make-single-float) + (:policy :fast-safe) + (:vop-var vop) + (:generator 4 + (sc-case res + (single-stack + (sc-case bits + (signed-reg + (inst mov res bits)) + (signed-stack + (assert (location= bits res))))) + (single-reg + (sc-case bits + (signed-reg + ;; source must be in memory + (inst mov stack-temp bits) + (with-empty-tn@fp-top(res) + (inst fld stack-temp))) + (signed-stack + (with-empty-tn@fp-top(res) + (inst fld bits)))))))) + +(define-vop (make-double-float) + (:args (hi-bits :scs (signed-reg)) + (lo-bits :scs (unsigned-reg))) + (:results (res :scs (double-reg))) + (:temporary (:sc double-stack) temp) + (:arg-types signed-num unsigned-num) + (:result-types double-float) + (:translate make-double-float) + (:policy :fast-safe) + (:vop-var vop) + (:generator 2 + (let ((offset (1+ (tn-offset temp)))) + (storew hi-bits ebp-tn (- offset)) + (storew lo-bits ebp-tn (- (1+ offset))) + (with-empty-tn@fp-top(res) + (inst fldd (make-ea :dword :base ebp-tn + :disp (- (* (1+ offset) word-bytes)))))))) + +(define-vop (single-float-bits) + (:args (float :scs (single-reg descriptor-reg))) + (:results (bits :scs (signed-reg))) + (:temporary (:sc signed-stack :from :argument :to :result) stack-temp) + (:arg-types single-float) + (:result-types signed-num) + (:translate single-float-bits) + (:policy :fast-safe) + (:vop-var vop) + (:generator 4 + (sc-case bits + (signed-reg + (sc-case float + (single-reg + (with-tn@fp-top(float) + (inst fst stack-temp) + (inst mov bits stack-temp))) + (single-stack + (inst mov bits float)) + (descriptor-reg + (loadw + bits float vm:single-float-value-slot vm:other-pointer-type)))) + (signed-stack + (sc-case float + (single-reg + (with-tn@fp-top(float) + (inst fst bits)))))))) + +;; must test +(define-vop (double-float-high-bits) + (:args (float :scs (double-reg descriptor-reg))) + (:results (hi-bits :scs (signed-reg))) + (:temporary (:sc double-stack) temp) + (:arg-types double-float) + (:result-types signed-num) + (:translate double-float-high-bits) + (:policy :fast-safe) + (:vop-var vop) + (:generator 5 + (sc-case hi-bits + (signed-reg + (sc-case float + (double-reg + (with-tn@fp-top(float) + (let ((where (make-ea :dword :base ebp-tn + :disp (- (* (+ 2 (tn-offset temp)) + word-bytes))))) + (inst fstd where))) + (loadw hi-bits ebp-tn (- (1+ (tn-offset temp))))) + (double-stack + (loadw hi-bits ebp-tn (- (1+ (tn-offset float))))) + (descriptor-reg + (loadw hi-bits float (1+ vm:double-float-value-slot) + vm:other-pointer-type)))) + #+nil ;; should not happen + (signed-stack + (sc-case float + (double-reg + (inst stf float (current-nfp-tn vop) + (* (tn-offset hi-bits) vm:word-bytes)))))))) + +;;needs testing +(define-vop (double-float-low-bits) + (:args (float :scs (double-reg descriptor-reg))) + (:results (lo-bits :scs (unsigned-reg))) + (:temporary (:sc double-stack) temp) + (:arg-types double-float) + (:result-types unsigned-num) + (:translate double-float-low-bits) + (:policy :fast-safe) + (:vop-var vop) + (:generator 5 + (sc-case lo-bits + (unsigned-reg + (sc-case float + (double-reg + (with-tn@fp-top(float) + (let ((where (make-ea :dword :base ebp-tn + :disp (- (* (+ 2 (tn-offset temp)) + word-bytes))))) + (inst fstd where))) + (loadw lo-bits ebp-tn (- (+ 2 (tn-offset temp))))) + (double-stack + (loadw lo-bits ebp-tn (- (+ 2 (tn-offset float))))) + (descriptor-reg + (loadw lo-bits float vm:double-float-value-slot + vm:other-pointer-type)))) + #+nil ;; should not happen + (unsigned-stack + (sc-case float + (double-reg + (inst stf-odd float (current-nfp-tn vop) + (* (tn-offset lo-bits) vm:word-bytes)))))))) + + +;;;; Float mode hackery: + +(deftype float-modes () '(unsigned-byte 32)) ; really only 16 +(defknown floating-point-modes () float-modes (flushable)) +(defknown ((setf floating-point-modes)) (float-modes) + float-modes) + +(defconstant npx-env-size (* 7 vm:word-bytes)) +(defconstant npx-cw-offset 0) +(defconstant npx-sw-offset 4) + +(define-vop (floating-point-modes) + (:results (res :scs (unsigned-reg))) + (:result-types unsigned-num) + (:translate floating-point-modes) + (:policy :fast-safe) + (:vop-var vop) + (:temporary (:sc dword-reg :offset eax-offset :target res) eax) + (:temporary (:sc dword-reg) tmp) + (:generator 8 + (inst mov tmp esp-tn) ; save stack pointer + (inst sub esp-tn npx-env-size) ; make space on stack + (inst wait) ; Catch any pending FPE exceptions + (inst fstenv (make-ea :dword :base esp-tn)) ; masks all exceptions + (inst fldenv (make-ea :dword :base esp-tn)) ; restore previous state + (inst mov ax-tn (make-ea :word :base esp-tn :disp npx-sw-offset)) + (inst shl eax 16) ; current status to high word + (inst mov ax-tn (make-ea :word :base esp-tn :disp npx-cw-offset)) + (inst xor ax-tn #x3f) ; turn exception mask to trap enable bits + (inst mov esp-tn tmp) ; reset stack + (move res eax))) + +(define-vop (set-floating-point-modes) + (:args (new :scs (unsigned-reg) :target res)) + (:results (res :scs (unsigned-reg))) + (:arg-types unsigned-num) + (:result-types unsigned-num) + (:translate (setf floating-point-modes)) + (:policy :fast-safe) + (:vop-var vop) + (:temporary (:sc dword-reg :offset eax-offset) eax) + (:temporary (:sc dword-reg) stmp) + (:temporary (:sc dword-reg) wtmp) + (:generator 3 + (inst mov stmp esp-tn) ; save stack pointer + (inst sub esp-tn npx-env-size) ; make space on stack + (inst wait) ; Catch any pending FPE exceptions + (inst fstenv (make-ea :dword :base esp-tn)) + (inst mov ax-tn (make-ea :word :base esp-tn :disp npx-sw-offset)) + (move wtmp new) + (inst shr wtmp 16) ; position sticky bits + (inst and wtmp #x3f) + (inst and eax wtmp) ; maybe new sticky bits + (inst mov (make-ea :word :base esp-tn :disp npx-sw-offset) ax-tn) + (move eax new) + (inst xor eax #x3f) ; turn trap enable bits into exception mask + (inst mov (make-ea :word :base esp-tn :disp npx-cw-offset) ax-tn) + (inst fldenv (make-ea :dword :base esp-tn)) + (move esp-tn stmp) ; reset stack + (move res new))) + + + +;;; Lets use some of the 80387 special functions. +;;; +;;; These defs will not take effect unless code/irrat.lisp is modified +;;; to remove the inlined alien routine def. + +(macrolet ((frob (func trans op) + `(define-vop (,func) + (:args (x :scs (double-reg) :target fr0)) + (:temporary (:sc double-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:ignore fr0) + (:results (y :scs (double-reg))) + (:arg-types double-float) + (:result-types double-float) + (:translate ,trans) + (:policy :fast-safe) + (:note "inline NPX function") + (:vop-var vop) + (:save-p :compute-only) + (:node-var node) + (:generator 5 + (note-this-location vop :internal-error) + (unless (zerop (tn-offset x)) + (inst fxch x) ; x to top of stack + (unless (location= x y) + (inst fst x))) ; maybe save it + (inst ,op) ; clobber st0 + (cond ((zerop (tn-offset y)) + (when (policy node (or (= debug 3) (> safety speed))) + (inst wait))) + (t + (inst fst y))))))) + + (frob fsin-quick %sin-quick fsin) ; arg range is 2^63 + (frob fcos-quick %cos-quick fcos) ; so may need frem1 + (frob fsqrt %sqrt fsqrt)) + +;;; Versions of fsin and fcos which handle a larger arg. range. +(macrolet ((frob (func trans op) + `(define-vop (,func) + (:translate ,trans) + (:args (x :scs (double-reg) :target fr0)) + #+nil(:temporary (:sc word-reg :offset eax-offset + :from :eval :to :result) temp) + (:temporary (:sc double-reg :offset fr0-offset + :from :argument :to :result) fr0) + #+nil(:temporary (:sc double-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:results (y :scs (double-reg))) + (:arg-types double-float) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline sin/cos function") + (:vop-var vop) + (:save-p :compute-only) + #+nil(:ignore temp) + (:generator 5 + (note-this-location vop :internal-error) + (unless (zerop (tn-offset x)) + (inst fxch x) ; x to top of stack + (unless (location= x y) + (inst fst x))) ; maybe save it + (inst ,op) + (inst fnstsw) ; status word to %ea + (inst and ah-tn #x04) ; C2 + (inst jmp :z DONE) + ;; Else x was out of range so reduce it; ST0 is unchanged. + #+nil ; @@@ + (progn ; Arg reduction is errorful + (inst fstp fr1) ; Load 2*PI + (inst fldpi) + (inst fadd fr0) + (inst fxch fr1) + LOOP + (inst fprem1) + (inst fnstsw) ; status word to %ea + (inst and ah-tn #x04) ; C2 + (inst jmp :nz LOOP) + (inst ,op)) + (progn ; @@@ + (inst fstp fr0) ; Else Load 0.0 + (inst fldz)) ; on too big args + DONE + (unless (zerop (tn-offset y)) + (inst fstd y)))))) + (frob fsin %sin fsin) + (frob fcos %cos fcos)) + +(define-vop (ftan) + (:translate %tan) + (:args (x :scs (double-reg) :target fr0)) + #+nil(:temporary (:sc word-reg :offset eax-offset + :from :eval :to :result) temp) + (:temporary (:sc double-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc double-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:results (y :scs (double-reg))) + (:arg-types double-float) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline tan function") + (:vop-var vop) + (:save-p :compute-only) + #+nil(:ignore temp) + (:generator 5 + (note-this-location vop :internal-error) + (case (tn-offset x) + (0 + (inst fstp fr1)) + (1 + (inst fstp fr0)) + (t + (inst fstp fr0) + (inst fstp fr0) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset x) 2))))) + (inst fptan) + (inst fnstsw) ; status word to %ea + (inst and ah-tn #x04) ; C2 + (inst jmp :z DONE) + ;; Else x was out of range so reduce it; ST0 is unchanged. + #+nil + (progn ; @@@ Reduction doesn't work well. + (inst fldpi) ; Load 2*PI + (inst fadd fr0) + (inst fxch fr1) + LOOP + (inst fprem1) + (inst fnstsw) ; status word to %ea + (inst and ah-tn #x04) ; C2 + (inst jmp :nz LOOP) + (inst fstp fr1) + (inst fptan)) + (progn ; @@@ just load 0.0 + (inst fldz) + (inst fxch fr1)) + DONE + ;; Result is in fr1 + (case (tn-offset y) + (0 + (inst fxch fr1)) + (1) + (t + (inst fxch fr1) + (inst fstd y))))) + +(define-vop (ftan-quick) + (:translate %tan-quick) + (:args (x :scs (double-reg) :target fr0)) + (:temporary (:sc double-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc double-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:results (y :scs (double-reg))) + (:arg-types double-float) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline tan function") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + (case (tn-offset x) + (0 + (inst fstp fr1)) + (1 + (inst fstp fr0)) + (t + (inst fstp fr0) + (inst fstp fr0) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset x) 2))))) + (inst fptan) + ;; Result is in fr1 + (case (tn-offset y) + (0 + (inst fxch fr1)) + (1) + (t + (inst fxch fr1) + (inst fstd y))))) + +#+nil +(define-vop (fexp) + (:translate %exp) + (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)) + (:temporary (:sc double-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc double-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:temporary (:sc double-reg :offset fr2-offset + :from :argument :to :result) fr2) + (:results (y :scs (double-reg))) + (:arg-types double-float) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline exp function") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + (sc-case x + (double-reg + (cond ((zerop (tn-offset x)) + ;; x is in fr0 + (inst fstp fr1) + (inst fldl2e) + (inst fmul fr1)) + (t + ;; x is in a FP reg, not fr0 + (inst fstp fr0) + (inst fldl2e) + (inst fmul x)))) + ((double-stack descriptor-reg) + (inst fstp fr0) + (inst fldl2e) + (if (sc-is x double-stack) + (inst fmuld (ea-for-df-stack x)) + (inst fmuld (ea-for-df-desc x))))) + ;; Now fr0=x log2(e) + (inst fst fr1) + (inst frndint) + (inst fst fr2) + (inst fsubp-sti fr1) + (inst f2xm1) + (inst fld1) + (inst faddp-sti fr1) + (inst fscale) + (inst fld fr0) + (case (tn-offset y) + ((0 1)) + (t (inst fstd y))))) + +;;; Modified exp that handles the following special cases: +;;; exp(+Inf) is +Inf; exp(-Inf) is 0; exp(NaN) is NaN. +(define-vop (fexp) + (:translate %exp) + (:args (x :scs (double-reg) :target fr0)) + (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp) + (:temporary (:sc double-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc double-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:temporary (:sc double-reg :offset fr2-offset + :from :argument :to :result) fr2) + (:results (y :scs (double-reg))) + (:arg-types double-float) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline exp function") + (:vop-var vop) + (:save-p :compute-only) + (:ignore temp) + (:generator 5 + (note-this-location vop :internal-error) + (unless (zerop (tn-offset x)) + (inst fxch x) ; x to top of stack + (unless (location= x y) + (inst fst x))) ; maybe save it + ;; Check for Inf or NaN + (inst fxam) + (inst fnstsw) + (inst sahf) + (inst jmp :nc NOINFNAN) ; Neither Inf or NaN. + (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue. + (inst and ah-tn #x02) ; Test sign of Inf. + (inst jmp :z DONE) ; +Inf gives +Inf. + (inst fstp fr0) ; -Inf gives 0 + (inst fldz) + (inst jmp-short DONE) + NOINFNAN + (inst fstp fr1) + (inst fldl2e) + (inst fmul fr1) + ;; Now fr0=x log2(e) + (inst fst fr1) + (inst frndint) + (inst fst fr2) + (inst fsubp-sti fr1) + (inst f2xm1) + (inst fld1) + (inst faddp-sti fr1) + (inst fscale) + (inst fld fr0) + DONE + (unless (zerop (tn-offset y)) + (inst fstd y)))) + +(define-vop (flog) + (:translate %log) + (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)) + (:temporary (:sc double-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc double-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:results (y :scs (double-reg))) + (:arg-types double-float) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline log function") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + (sc-case x + (double-reg + (case (tn-offset x) + (0 + ;; x is in fr0 + (inst fstp fr1) + (inst fldln2) + (inst fxch fr1)) + (1 + ;; x is in fr1 + (inst fstp fr0) + (inst fldln2) + (inst fxch fr1)) + (t + ;; x is in a FP reg, not fr0 or fr1 + (inst fstp fr0) + (inst fstp fr0) + (inst fldln2) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset x)))))) + (inst fyl2x)) + ((double-stack descriptor-reg) + (inst fstp fr0) + (inst fstp fr0) + (inst fldln2) + (if (sc-is x double-stack) + (inst fldd (ea-for-df-stack x)) + (inst fldd (ea-for-df-desc x))) + (inst fyl2x))) + (inst fld fr0) + (case (tn-offset y) + ((0 1)) + (t (inst fstd y))))) + +(define-vop (flog10) + (:translate %log10) + (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)) + (:temporary (:sc double-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc double-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:results (y :scs (double-reg))) + (:arg-types double-float) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline log10 function") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + (sc-case x + (double-reg + (case (tn-offset x) + (0 + ;; x is in fr0 + (inst fstp fr1) + (inst fldlg2) + (inst fxch fr1)) + (1 + ;; x is in fr1 + (inst fstp fr0) + (inst fldlg2) + (inst fxch fr1)) + (t + ;; x is in a FP reg, not fr0 or fr1 + (inst fstp fr0) + (inst fstp fr0) + (inst fldlg2) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset x)))))) + (inst fyl2x)) + ((double-stack descriptor-reg) + (inst fstp fr0) + (inst fstp fr0) + (inst fldlg2) + (if (sc-is x double-stack) + (inst fldd (ea-for-df-stack x)) + (inst fldd (ea-for-df-desc x))) + (inst fyl2x))) + (inst fld fr0) + (case (tn-offset y) + ((0 1)) + (t (inst fstd y))))) + +(define-vop (fpow) + (:translate %pow) + (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0) + (y :scs (double-reg double-stack descriptor-reg) :target fr1)) + (:temporary (:sc double-reg :offset fr0-offset + :from (:argument 0) :to :result) fr0) + (:temporary (:sc double-reg :offset fr1-offset + :from (:argument 1) :to :result) fr1) + (:temporary (:sc double-reg :offset fr2-offset + :from :load :to :result) fr2) + (:results (r :scs (double-reg))) + (:arg-types double-float double-float) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline pow function") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + ;; Setup x in fr0 and y in fr1 + (cond + ;; x in fr0; y in fr1 + ((and (sc-is x double-reg) (zerop (tn-offset x)) + (sc-is y double-reg) (= 1 (tn-offset y)))) + ;; y in fr1; x not in fr0 + ((and (sc-is y double-reg) (= 1 (tn-offset y))) + ;; Load x to fr0 + (inst fstp fr0) + (sc-case x + (double-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset x))))) + (double-stack + (inst fldd (ea-for-df-stack x))) + (descriptor-reg + (inst fldd (ea-for-df-desc x))))) + ;; x in fr0; y not in fr1 + ((and (sc-is x double-reg) (zerop (tn-offset x))) + (inst fxch fr1) + ;; Now load y to fr0 + (inst fstp fr0) + (sc-case y + (double-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset y))))) + (double-stack + (inst fldd (ea-for-df-stack y))) + (descriptor-reg + (inst fldd (ea-for-df-desc y)))) + (inst fxch fr1)) + ;; x in fr1; y not in fr1 + ((and (sc-is x double-reg) (= 1 (tn-offset x))) + ;; Load y to fr0 + (inst fstp fr0) + (sc-case y + (double-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset y))))) + (double-stack + (inst fldd (ea-for-df-stack y))) + (descriptor-reg + (inst fldd (ea-for-df-desc y)))) + (inst fxch fr1)) + ;; y in fr0; + ((and (sc-is y double-reg) (zerop (tn-offset y))) + (inst fxch fr1) + ;; Now load x to fr0 + (inst fstp fr0) + (sc-case x + (double-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset x))))) + (double-stack + (inst fldd (ea-for-df-stack x))) + (descriptor-reg + (inst fldd (ea-for-df-desc x))))) + ;; Neither x or y are in either fr0 or fr1 + (t + ;; Load y then x + (inst fstp fr0) + (inst fstp fr0) + (sc-case y + (double-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset y) 2)))) + (double-stack + (inst fldd (ea-for-df-stack y))) + (descriptor-reg + (inst fldd (ea-for-df-desc y)))) + ;; Load x to fr0 + (sc-case x + (double-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset x))))) + (double-stack + (inst fldd (ea-for-df-stack x))) + (descriptor-reg + (inst fldd (ea-for-df-desc x)))))) + + ;; Now have x at fr0; and y at fr1 + (inst fyl2x) + ;; Now fr0=y log2(x) + (inst fld fr0) + (inst frndint) + (inst fst fr2) + (inst fsubp-sti fr1) + (inst f2xm1) + (inst fld1) + (inst faddp-sti fr1) + (inst fscale) + (inst fld fr0) + (case (tn-offset r) + ((0 1)) + (t (inst fstd r))))) + +(define-vop (fscalen) + (:translate %scalbn) + (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0) + (y :scs (signed-stack signed-reg) :target temp)) + (:temporary (:sc double-reg :offset fr0-offset + :from (:argument 0) :to :result) fr0) + (:temporary (:sc double-reg :offset fr1-offset :from :eval :to :result) fr1) + (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp) + (:results (r :scs (double-reg))) + (:arg-types double-float signed-num) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline scalbn function") + (:generator 5 + ;; Setup x in fr0 and y in fr1 + (sc-case x + (double-reg + (case (tn-offset x) + (0 + (inst fstp fr1) + (sc-case y + (signed-reg + (inst mov temp y) + (inst fild temp)) + (signed-stack + (inst fild y))) + (inst fxch fr1)) + (1 + (inst fstp fr0) + (sc-case y + (signed-reg + (inst mov temp y) + (inst fild temp)) + (signed-stack + (inst fild y))) + (inst fxch fr1)) + (t + (inst fstp fr0) + (inst fstp fr0) + (sc-case y + (signed-reg + (inst mov temp y) + (inst fild temp)) + (signed-stack + (inst fild y))) + (inst fld (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset x))))))) + ((double-stack descriptor-reg) + (inst fstp fr0) + (inst fstp fr0) + (sc-case y + (signed-reg + (inst mov temp y) + (inst fild temp)) + (signed-stack + (inst fild y))) + (if (sc-is x double-stack) + (inst fldd (ea-for-df-stack x)) + (inst fldd (ea-for-df-desc x))))) + (inst fscale) + (unless (zerop (tn-offset r)) + (inst fstd r)))) + +(define-vop (fscale) + (:translate %scalb) + (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0) + (y :scs (double-reg double-stack descriptor-reg) :target fr1)) + (:temporary (:sc double-reg :offset fr0-offset + :from (:argument 0) :to :result) fr0) + (:temporary (:sc double-reg :offset fr1-offset + :from (:argument 1) :to :result) fr1) + (:results (r :scs (double-reg))) + (:arg-types double-float double-float) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline scalb function") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + ;; Setup x in fr0 and y in fr1 + (cond + ;; x in fr0; y in fr1 + ((and (sc-is x double-reg) (zerop (tn-offset x)) + (sc-is y double-reg) (= 1 (tn-offset y)))) + ;; y in fr1; x not in fr0 + ((and (sc-is y double-reg) (= 1 (tn-offset y))) + ;; Load x to fr0 + (inst fstp fr0) + (sc-case x + (double-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset x))))) + (double-stack + (inst fldd (ea-for-df-stack x))) + (descriptor-reg + (inst fldd (ea-for-df-desc x))))) + ;; x in fr0; y not in fr1 + ((and (sc-is x double-reg) (zerop (tn-offset x))) + (inst fxch fr1) + ;; Now load y to fr0 + (inst fstp fr0) + (sc-case y + (double-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset y))))) + (double-stack + (inst fldd (ea-for-df-stack y))) + (descriptor-reg + (inst fldd (ea-for-df-desc y)))) + (inst fxch fr1)) + ;; x in fr1; y not in fr1 + ((and (sc-is x double-reg) (= 1 (tn-offset x))) + ;; Load y to fr0 + (inst fstp fr0) + (sc-case y + (double-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset y))))) + (double-stack + (inst fldd (ea-for-df-stack y))) + (descriptor-reg + (inst fldd (ea-for-df-desc y)))) + (inst fxch fr1)) + ;; y in fr0; + ((and (sc-is y double-reg) (zerop (tn-offset y))) + (inst fxch fr1) + ;; Now load x to fr0 + (inst fstp fr0) + (sc-case x + (double-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset x))))) + (double-stack + (inst fldd (ea-for-df-stack x))) + (descriptor-reg + (inst fldd (ea-for-df-desc x))))) + ;; Neither x or y are in either fr0 or fr1 + (t + ;; Load y then x + (inst fstp fr0) + (inst fstp fr0) + (sc-case y + (double-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset y) 2)))) + (double-stack + (inst fldd (ea-for-df-stack y))) + (descriptor-reg + (inst fldd (ea-for-df-desc y)))) + ;; Load x to fr0 + (sc-case x + (double-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset x))))) + (double-stack + (inst fldd (ea-for-df-stack x))) + (descriptor-reg + (inst fldd (ea-for-df-desc x)))))) + + ;; Now have x at fr0; and y at fr1 + (inst fscale) + (unless (zerop (tn-offset r)) + (inst fstd r)))) + +;;; Seems to work fine on a Pentium, but the range of the x argument +;;; is limited on a 386/486. +(define-vop (flog1p-limited) + (:translate %log1p-limited) + (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)) + (:temporary (:sc double-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc double-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:results (y :scs (double-reg))) + (:arg-types double-float) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline log1p with limited x range function") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + (sc-case x + (double-reg + (case (tn-offset x) + (0 + ;; x is in fr0 + (inst fstp fr1) + (inst fldln2) + (inst fxch fr1)) + (1 + ;; x is in fr1 + (inst fstp fr0) + (inst fldln2) + (inst fxch fr1)) + (t + ;; x is in a FP reg, not fr0 or fr1 + (inst fstp fr0) + (inst fstp fr0) + (inst fldln2) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset x) 2))))) + (inst fyl2xp1)) + ((double-stack descriptor-reg) + (inst fstp fr0) + (inst fstp fr0) + (inst fldln2) + (if (sc-is x double-stack) + (inst fldd (ea-for-df-stack x)) + (inst fldd (ea-for-df-desc x))) + (inst fyl2xp1))) + (inst fld fr0) + (case (tn-offset y) + ((0 1)) + (t (inst fstd y))))) + +(define-vop (flogb) + (:translate %logb) + (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)) + (:temporary (:sc double-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc double-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:results (y :scs (double-reg))) + (:arg-types double-float) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline logb function") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + (sc-case x + (double-reg + (case (tn-offset x) + (0 + ;; x is in fr0 + (inst fstp fr1)) + (1 + ;; x is in fr1 + (inst fstp fr0)) + (t + ;; x is in a FP reg, not fr0 or fr1 + (inst fstp fr0) + (inst fstp fr0) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset x) 2)))))) + ((double-stack descriptor-reg) + (inst fstp fr0) + (inst fstp fr0) + (if (sc-is x double-stack) + (inst fldd (ea-for-df-stack x)) + (inst fldd (ea-for-df-desc x))))) + (inst fxtract) + (case (tn-offset y) + (0 + (inst fxch fr1)) + (1) + (t (inst fxch fr1) + (inst fstd y))))) + +(define-vop (fatan) + (:translate %atan) + (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)) + (:temporary (:sc double-reg :offset fr0-offset + :from (:argument 0) :to :result) fr0) + (:temporary (:sc double-reg :offset fr1-offset + :from (:argument 0) :to :result) fr1) + (:results (r :scs (double-reg))) + (:arg-types double-float) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline atan function") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + ;; Setup x in fr1 and 1.0 in fr0 + (cond + ;; x in fr0 + ((and (sc-is x double-reg) (zerop (tn-offset x))) + (inst fstp fr1)) + ;; x in fr1 + ((and (sc-is x double-reg) (= 1 (tn-offset x))) + (inst fstp fr0)) + ;; x not in fr0 or fr1 + (t + ;; Load x then 1.0 + (inst fstp fr0) + (inst fstp fr0) + (sc-case x + (double-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset x) 2)))) + (double-stack + (inst fldd (ea-for-df-stack x))) + (descriptor-reg + (inst fldd (ea-for-df-desc x)))))) + (inst fld1) + ;; Now have x at fr1; and 1.0 at fr0 + (inst fpatan) + (inst fld fr0) + (case (tn-offset r) + ((0 1)) + (t (inst fstd r))))) + +(define-vop (fatan2) + (:translate %atan2) + (:args (x :scs (double-reg double-stack descriptor-reg) :target fr1) + (y :scs (double-reg double-stack descriptor-reg) :target fr0)) + (:temporary (:sc double-reg :offset fr0-offset + :from (:argument 1) :to :result) fr0) + (:temporary (:sc double-reg :offset fr1-offset + :from (:argument 0) :to :result) fr1) + (:results (r :scs (double-reg))) + (:arg-types double-float double-float) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline atan2 function") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + ;; Setup x in fr1 and y in fr0 + (cond + ;; y in fr0; x in fr1 + ((and (sc-is y double-reg) (zerop (tn-offset y)) + (sc-is x double-reg) (= 1 (tn-offset x)))) + ;; x in fr1; y not in fr0 + ((and (sc-is x double-reg) (= 1 (tn-offset x))) + ;; Load y to fr0 + (inst fstp fr0) + (sc-case y + (double-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset y))))) + (double-stack + (inst fldd (ea-for-df-stack y))) + (descriptor-reg + (inst fldd (ea-for-df-desc y))))) + ;; y in fr0; x not in fr1 + ((and (sc-is y double-reg) (zerop (tn-offset y))) + (inst fxch fr1) + ;; Now load x to fr0 + (inst fstp fr0) + (sc-case x + (double-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset x))))) + (double-stack + (inst fldd (ea-for-df-stack x))) + (descriptor-reg + (inst fldd (ea-for-df-desc x)))) + (inst fxch fr1)) + ;; y in fr1; x not in fr1 + ((and (sc-is y double-reg) (= 1 (tn-offset y))) + ;; Load x to fr0 + (inst fstp fr0) + (sc-case x + (double-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset x))))) + (double-stack + (inst fldd (ea-for-df-stack x))) + (descriptor-reg + (inst fldd (ea-for-df-desc x)))) + (inst fxch fr1)) + ;; x in fr0; + ((and (sc-is x double-reg) (zerop (tn-offset x))) + (inst fxch fr1) + ;; Now load y to fr0 + (inst fstp fr0) + (sc-case y + (double-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset y))))) + (double-stack + (inst fldd (ea-for-df-stack y))) + (descriptor-reg + (inst fldd (ea-for-df-desc y))))) + ;; Neither y or x are in either fr0 or fr1 + (t + ;; Load x then y + (inst fstp fr0) + (inst fstp fr0) + (sc-case x + (double-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset x) 2)))) + (double-stack + (inst fldd (ea-for-df-stack x))) + (descriptor-reg + (inst fldd (ea-for-df-desc x)))) + ;; Load y to fr0 + (sc-case y + (double-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset y))))) + (double-stack + (inst fldd (ea-for-df-stack y))) + (descriptor-reg + (inst fldd (ea-for-df-desc y)))))) + + ;; Now have y at fr0; and x at fr1 + (inst fpatan) + (inst fld fr0) + (case (tn-offset r) + ((0 1)) + (t (inst fstd r))))) diff --git a/compiler/x86/insts.lisp b/compiler/x86/insts.lisp new file mode 100644 index 000000000..4d87cc0c5 --- /dev/null +++ b/compiler/x86/insts.lisp @@ -0,0 +1,2695 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/insts.lisp,v 1.1 1997/01/18 14:31:19 ram Exp $") +;;; +;;; ********************************************************************** +;;; +;;; Description of the x86 instruction set, for 80386 and above. +;;; +;;; Written by William Lott +;;; +;;; Debugged by Paul F. Werkowski Spring/Summer 1995. +;;; +;;; Debugging and enhancements by Douglas Crosher 1996. +;;; + +(in-package :x86) + +(use-package :new-assem) + +(def-assembler-params + :scheduler-p nil) + +(disassem:set-disassem-params :instruction-alignment 8) + + + +;;;; Primitive emitters. + +(define-emitter emit-word 16 + (byte 16 0)) + +(define-emitter emit-dword 32 + (byte 32 0)) + +(define-emitter emit-byte-with-reg 8 + (byte 5 3) (byte 3 0)) + +(define-emitter emit-mod-reg-r/m-byte 8 + (byte 2 6) (byte 3 3) (byte 3 0)) + +(define-emitter emit-sib-byte 8 + (byte 2 6) (byte 3 3) (byte 3 0)) + + + +;;;; Fixup emitters. + +(defun emit-absolute-fixup (segment fixup) + (note-fixup segment :absolute fixup) + (let ((offset (fixup-offset fixup))) + (if (label-p offset) + (emit-back-patch segment 4 + #'(lambda (segment posn) + (declare (ignore posn)) + (emit-dword segment + (- (+ (component-header-length) + (or (label-position offset) 0) ) + other-pointer-type)))) + (emit-dword segment (or offset 0))))) + +(defun emit-relative-fixup (segment fixup) + (note-fixup segment :relative fixup) + (emit-dword segment (or (fixup-offset fixup) 0))) + + + +;;;; The effective-address (ea) structure. + +(defun reg-tn-encoding (tn) + (declare (type tn tn)) + (assert (eq (sb-name (sc-sb (tn-sc tn))) 'registers)) + (let ((offset (tn-offset tn))) + (logior (ash (logand offset 1) 2) + (ash offset -1)))) + +(defstruct (ea + (:constructor make-ea (size &key base index scale disp)) + (:print-function %print-ea)) + (size nil :type (member :byte :word :dword)) + (base nil :type (or tn null)) + (index nil :type (or tn null)) + (scale 1 :type (member 1 2 4 8)) + (disp 0 :type (or (signed-byte 32) fixup))) + +(defun %print-ea (ea stream depth) + (declare (ignore depth)) + (cond ((or *print-escape* *print-readably*) + (print-unreadable-object (ea stream :type t) + (format stream + "~S~@[ base=~S~]~@[ index=~S~]~@[ scale=~S~]~@[ disp=~S~]" + (ea-size ea) + (ea-base ea) + (ea-index ea) + (let ((scale (ea-scale ea))) + (if (= scale 1) nil scale)) + (ea-disp ea)))) + (t + (format stream "~A PTR [" (symbol-name (ea-size ea))) + (when (ea-base ea) + (write-string (x86-location-print-name (ea-base ea)) stream) + (when (ea-index ea) + (write-string "+" stream))) + (when (ea-index ea) + (write-string (x86-location-print-name (ea-index ea)) stream)) + (unless (= (ea-scale ea) 1) + (format stream "*~A" (ea-scale ea))) + (typecase (ea-disp ea) + (null) + (integer + (format stream "~@D" (ea-disp ea))) + (t + (format stream "+~A" (ea-disp ea)))) + (write-char #\] stream)))) + +(defun emit-ea (segment thing reg &optional allow-constants) + (etypecase thing + (tn + (ecase (sb-name (sc-sb (tn-sc thing))) + (registers + (emit-mod-reg-r/m-byte segment #b11 reg (reg-tn-encoding thing))) + (stack + ;; Convert stack tns into an index off of EBP. + (let ((disp (- (* (1+ (tn-offset thing)) word-bytes)))) + (cond ((< -128 disp 127) + (emit-mod-reg-r/m-byte segment #b01 reg #b101) + (emit-byte segment disp)) + (t + (emit-mod-reg-r/m-byte segment #b10 reg #b101) + (emit-dword segment disp))))) + (constant + (unless allow-constants + (error + "Constant TNs can only be directly used in MOV, PUSH, and CMP.")) + (emit-mod-reg-r/m-byte segment #b00 reg #b101) + (emit-absolute-fixup segment + (make-fixup nil + :code-object + (- (* (tn-offset thing) word-bytes) + other-pointer-type)))))) + (ea + (let* ((base (ea-base thing)) + (index (ea-index thing)) + (scale (ea-scale thing)) + (disp (ea-disp thing)) + (mod (cond ((or (null base) + (and (eql disp 0) + (not (= (reg-tn-encoding base) #b101)))) + #b00) + ((and (fixnump disp) (<= -128 disp 127)) + #b01) + (t + #b10))) + (r/m (cond (index #b100) + ((null base) #b101) + (t (reg-tn-encoding base))))) + (emit-mod-reg-r/m-byte segment mod reg r/m) + (when (= r/m #b100) + (let ((ss (1- (integer-length scale))) + (index (if (null index) + #b100 + (let ((index (reg-tn-encoding index))) + (if (= index #b100) + (error "Can't index off of ESP") + index)))) + (base (if (null base) + #b101 + (reg-tn-encoding base)))) + (emit-sib-byte segment ss index base))) + (cond ((= mod #b01) + (emit-byte segment disp)) + ((or (= mod #b10) (null base)) + (if (fixup-p disp) + (emit-absolute-fixup segment disp) + (emit-dword segment disp)))))) + (fixup + (emit-mod-reg-r/m-byte segment #b00 reg #b101) + (emit-absolute-fixup segment thing)))) + +(defun fp-reg-tn-p (thing) + (and (tn-p thing) + (eq (sb-name (sc-sb (tn-sc thing))) 'float-registers))) + +;;; +;;; like the above, but for fp-instructions--jrd +;;; +(defun emit-fp-op (segment thing op) + (if (fp-reg-tn-p thing) + (emit-byte segment (dpb op (byte 3 3) (dpb (tn-offset thing) + (byte 3 0) + #b11000000))) + (emit-ea segment thing op))) + +(defun byte-reg-p (thing) + (and (tn-p thing) + (eq (sb-name (sc-sb (tn-sc thing))) 'registers) + (member (sc-name (tn-sc thing)) byte-sc-names) + t)) + +(defun byte-ea-p (thing) + (typecase thing + (ea (eq (ea-size thing) :byte)) + (tn + (and (member (sc-name (tn-sc thing)) byte-sc-names) t)) + (t nil))) + +(defun word-reg-p (thing) + (and (tn-p thing) + (eq (sb-name (sc-sb (tn-sc thing))) 'registers) + (member (sc-name (tn-sc thing)) word-sc-names) + t)) + +(defun word-ea-p (thing) + (typecase thing + (ea (eq (ea-size thing) :word)) + (tn (and (member (sc-name (tn-sc thing)) word-sc-names) t)) + (t nil))) + +(defun dword-reg-p (thing) + (and (tn-p thing) + (eq (sb-name (sc-sb (tn-sc thing))) 'registers) + (member (sc-name (tn-sc thing)) dword-sc-names) + t)) + +(defun dword-ea-p (thing) + (typecase thing + (ea (eq (ea-size thing) :dword)) + (tn + (and (member (sc-name (tn-sc thing)) dword-sc-names) t)) + (t nil))) + +(defun register-p (thing) + (and (tn-p thing) + (eq (sb-name (sc-sb (tn-sc thing))) 'registers))) + +(defun accumulator-p (thing) + (and (register-p thing) + (= (tn-offset thing) 0))) + +(eval-when (compile load eval) +(defconstant conditions + '((:o . 0) + (:no . 1) + (:b . 2) (:nae . 2) (:c . 2) + (:nb . 3) (:ae . 3) (:nc . 3) + (:eq . 4) (:e . 4) (:z . 4) + (:ne . 5) (:nz . 5) + (:be . 6) (:na . 6) + (:nbe . 7) (:a . 7) + (:s . 8) + (:ns . 9) + (:p . 10) (:pe . 10) + (:np . 11) (:po . 11) + (:l . 12) (:nge . 12) + (:nl . 13) (:ge . 13) + (:le . 14) (:ng . 14) + (:nle . 15) (:g . 15))) + +(defun conditional-opcode (condition) + (cdr (assoc condition conditions :test #'eq)))) + + + +;;;; Utilities. + +#-lispworks3 +(defconstant operand-size-prefix-byte #b01100110) + +#+lispworks3 +(eval-when (compile load eval) + (defconstant operand-size-prefix-byte #b01100110)) + +(defparameter *default-operand-size* :dword) + +(defun maybe-emit-operand-size-prefix (segment size) + (unless (or (eq size :byte) (eq size *default-operand-size*)) + (emit-byte segment operand-size-prefix-byte))) + +(defun operand-size (thing) + (typecase thing + (tn + (case (sc-name (tn-sc thing)) + (#.dword-sc-names + :dword) + (#.word-sc-names + :word) + (#.byte-sc-names + :byte) + ;; added by jrd. float-registers is a separate size (?) + (#.float-sc-names + :float) + (#.double-sc-names + :double) + (t + (error "Can't tell the size of ~S ~S" thing (sc-name (tn-sc thing)))))) + (ea + (ea-size thing)) + (t + nil))) + +(defun matching-operand-size (dst src) + (let ((dst-size (operand-size dst)) + (src-size (operand-size src))) + (if dst-size + (if src-size + (if (eq dst-size src-size) + dst-size + (error "Size mismatch: ~S is a ~S and ~S is a ~S" + dst dst-size src src-size)) + dst-size) + (if src-size + src-size + (error "Can't tell the size of either ~S or ~S." + dst src))))) + +(defun emit-sized-immediate (segment size value) + (ecase size + (:byte + (emit-byte segment value)) + (:word + (emit-word segment value)) + (:dword + (emit-dword segment value)))) + + + +;;;; Disassembler support stuff. + +(deftype reg () '(unsigned-byte 3)) +#+cross-compiler +(lisp:deftype reg () '(unsigned-byte 3)) + +(eval-when (compile eval load) + +(defparameter *default-address-size* + ;; Actually, :dword is the only one really supported. + :dword) + +(defparameter byte-reg-names + #(al cl dl bl ah ch dh bh)) +(defparameter word-reg-names + #(ax cx dx bx sp bp si di)) +(defparameter dword-reg-names + #(eax ecx edx ebx esp ebp esi edi)) + +(defun print-reg-with-width (value width stream dstate) + (declare (ignore dstate)) + (princ (aref (ecase width + (:byte byte-reg-names) + (:word word-reg-names) + (:dword dword-reg-names)) + value) + stream) + ;; plus should do some source-var notes + ) + +(defun print-reg (value stream dstate) + (declare (type reg value) + (type stream stream) + (type disassem:disassem-state dstate)) + (print-reg-with-width value + (disassem:dstate-get-prop dstate 'width) + stream + dstate)) + +(defun print-word-reg (value stream dstate) + (declare (type reg value) + (type stream stream) + (type disassem:disassem-state dstate)) + (print-reg-with-width value + (or (disassem:dstate-get-prop dstate 'word-width) + *default-operand-size*) + stream + dstate)) + +(defun print-byte-reg (value stream dstate) + (declare (type reg value) + (type stream stream) + (type disassem:disassem-state dstate)) + (print-reg-with-width value :byte stream dstate)) + +(defun print-addr-reg (value stream dstate) + (declare (type reg value) + (type stream stream) + (type disassem:disassem-state dstate)) + (print-reg-with-width value *default-address-size* stream dstate)) + +;;; Value is a list of (BASE-REG OFFSET INDEX-REG INDEX-SCALE) +(defun print-mem-access (value stream print-size-p dstate) + (declare (type list value) + (type stream stream) + (type (member t nil) print-size-p) + (type disassem:disassem-state dstate)) + (when print-size-p + (princ (disassem:dstate-get-prop dstate 'width) stream) + (princ '| PTR | stream)) + (write-char #\[ stream) + (let ((firstp t)) + (macrolet ((pel ((var val) &body body) + ;; Print an element of the address, maybe with + ;; a leading separator. + `(let ((,var ,val)) + (when ,var + (unless firstp + (write-char #\+ stream)) + ,@body + (setq firstp nil))))) + (pel (base-reg (first value)) + (print-addr-reg base-reg stream dstate)) + (pel (index-reg (third value)) + (print-addr-reg index-reg stream dstate) + (let ((index-scale (fourth value))) + (when (and index-scale (not (= index-scale 1))) + (write-char #\* stream) + (princ index-scale stream)))) + (let ((offset (second value))) + (when (and offset (or firstp (not (zerop offset)))) + (unless (or firstp (minusp offset)) + (write-char #\+ stream)) + (if firstp + (disassem:princ16 offset stream) + (princ offset stream)))))) + (write-char #\] stream)) + +(defun print-reg/mem (value stream dstate) + (declare (type (or list reg) value) + (type stream stream) + (type disassem:disassem-state dstate)) + (if (typep value 'reg) + (print-reg value stream dstate) + (print-mem-access value stream nil dstate))) + +;; Same as print-reg/mem, but prints an explicit size indicator for +;; memory references. +(defun print-sized-reg/mem (value stream dstate) + (declare (type (or list reg) value) + (type stream stream) + (type disassem:disassem-state dstate)) + (if (typep value 'reg) + (print-reg value stream dstate) + (print-mem-access value stream t dstate))) + +(defun print-byte-reg/mem (value stream dstate) + (declare (type (or list reg) value) + (type stream stream) + (type disassem:disassem-state dstate)) + (if (typep value 'reg) + (print-byte-reg value stream dstate) + (print-mem-access value stream t dstate))) + +(defun print-label (value stream dstate) + (declare (ignore dstate)) + (disassem:princ16 value stream)) + +;;; Returns either an integer, meaning a register, or a list of +;;; (BASE-REG OFFSET INDEX-REG INDEX-SCALE), where any component +;;; may be missing or nil to indicate that it's not used or has the +;;; obvious default value (e.g., 1 for the index-scale). +(defun prefilter-reg/mem (value dstate) + (declare (type list value) + (type disassem:disassem-state dstate)) + (let ((mod (car value)) + (r/m (cadr value))) + (declare (type (unsigned-byte 2) mod) + (type (unsigned-byte 3) r/m)) + (cond ((= mod #b11) + ;; registers + r/m) + ((= r/m #b100) + ;; sib byte + (let ((sib (disassem:read-suffix 8 dstate))) + (declare (type (unsigned-byte 8) sib)) + (let ((base-reg (ldb (byte 3 0) sib)) + (index-reg (ldb (byte 3 3) sib)) + (index-scale (ldb (byte 2 6) sib))) + (declare (type (unsigned-byte 3) base-reg index-reg) + (type (unsigned-byte 2) index-scale)) + (let* ((offset + (case mod + (#b00 + (if (= base-reg #b101) + (disassem:read-suffix 32 dstate) + nil)) + (#b01 + (disassem:read-signed-suffix 8 dstate)) + (#b10 + (disassem:read-suffix 32 dstate))))) + (list (if (and (= mod #b00) (= base-reg #b101)) nil base-reg) + offset + (if (= index-reg #b100) nil index-reg) + (ash 1 index-scale)))))) + ((and (= mod #b00) (= r/m #b101)) + (list nil (disassem:read-suffix 32 dstate)) ) + ((= mod #b00) + (list r/m)) + ((= mod #b01) + (list r/m (disassem:read-signed-suffix 8 dstate))) + (t ; (= mod #b10) + (list r/m (disassem:read-suffix 32 dstate)))))) + + +;;; This is a sort of bogus prefilter that just +;;; stores the info globally for other people to use; it +;;; probably never gets printed. +(defun prefilter-width (value dstate) + (setf (disassem:dstate-get-prop dstate 'width) + (if (zerop value) + :byte + (let ((word-width + ;; set by a prefix instruction + (or (disassem:dstate-get-prop dstate 'word-width) + *default-operand-size*))) + (when (not (eql word-width *default-operand-size*)) + ;; reset it + (setf (disassem:dstate-get-prop dstate 'word-width) + *default-operand-size*)) + word-width)))) + +(defun offset-next (value dstate) + (declare #|(type integer value)|# + (type disassem:disassem-state dstate)) + ;; XXX dtc; a hack to stop the disassembler causing a fatal error; + ;; probably caused by out of bounds offsets? + (if (or (null value) + (and (listp value) (null (car value)))) + 0 + (+ (disassem:dstate-next-addr dstate) (if (listp value) (car value) value)))) + +(defun read-address (value dstate) + (declare (ignore value)) ; always nil anyway + (disassem:read-suffix (width-bits *default-address-size*) dstate)) + +(defun read-signed-imm-dword (value dstate) + (declare (ignore value)) ; always nil anyway + (disassem:read-signed-suffix 32 dstate)) + +(defun width-bits (width) + (ecase width + (:byte 8) + (:word 16) + (:dword 32) + (:float 32) + (:double 64))) + +); eval-when + + +;;;; Disassembler argument types. + +(disassem:define-argument-type accum + :printer #'(lambda (value stream dstate) + (declare (ignore value) + (type stream stream) + (type disassem:disassem-state dstate)) + (print-reg 0 stream dstate)) + ) + +(disassem:define-argument-type word-accum + :printer #'(lambda (value stream dstate) + (declare (ignore value) + (type stream stream) + (type disassem:disassem-state dstate)) + (print-word-reg 0 stream dstate)) + ) + +(disassem:define-argument-type reg + :printer #'print-reg) + +(disassem:define-argument-type addr-reg + :printer #'print-addr-reg) + +(disassem:define-argument-type word-reg + :printer #'print-word-reg) + +(disassem:define-argument-type imm-addr + :prefilter #'read-address + :printer #'print-label) + +(disassem:define-argument-type imm-data + :prefilter #'(lambda (value dstate) + (declare (ignore value)) ; always nil anyway + (disassem:read-suffix + (width-bits (disassem:dstate-get-prop dstate 'width)) + dstate)) + ) + +(disassem:define-argument-type signed-imm-data + :prefilter #'(lambda (value dstate) + (declare (ignore value)) ; always nil anyway + (let ((width (disassem:dstate-get-prop dstate 'width))) + (disassem:read-signed-suffix (width-bits width) dstate))) + ) + +(disassem:define-argument-type signed-imm-byte + :prefilter #'(lambda (value dstate) + (declare (ignore value)) ; always nil anyway + (disassem:read-signed-suffix 8 dstate))) + +(disassem:define-argument-type signed-imm-dword + :prefilter #'read-signed-imm-dword) + +(disassem:define-argument-type imm-word + :prefilter #'(lambda (value dstate) + (declare (ignore value)) ; always nil anyway + (let ((width + (or (disassem:dstate-get-prop dstate 'word-width) + *default-operand-size*))) + (disassem:read-suffix (width-bits width) dstate)))) + +;;; Needed for the ret imm16 instruction +(disassem:define-argument-type imm-word-16 + :prefilter #'(lambda (value dstate) + (declare (ignore value)) ; always nil anyway + (disassem:read-suffix 16 dstate))) + +(disassem:define-argument-type reg/mem + :prefilter #'prefilter-reg/mem + :printer #'print-reg/mem) +(disassem:define-argument-type sized-reg/mem + ;; Same as reg/mem, but prints an explicit size indicator for + ;; memory references. + :prefilter #'prefilter-reg/mem + :printer #'print-sized-reg/mem) +(disassem:define-argument-type byte-reg/mem + :prefilter #'prefilter-reg/mem + :printer #'print-byte-reg/mem) + +;;; +;;; added by jrd +;;; +(eval-when (compile load eval) +(defun print-fp-reg (value stream dstate) + (declare (ignore dstate)) + (format stream "FR~D" value)) + +(defun prefilter-fp-reg (value dstate) + ;; just return it + (declare (ignore dstate)) + value) +) +(disassem:define-argument-type fp-reg + :prefilter #'prefilter-fp-reg + :printer #'print-fp-reg) + +(disassem:define-argument-type width + :prefilter #'prefilter-width + :printer #'(lambda (value stream dstate) + (if ;; (zerop value) + (or (null value) (and (numberp value) (zerop value))) ; zzz jrd + (princ 'b stream) + (let ((word-width + ;; set by a prefix instruction + (or (disassem:dstate-get-prop dstate 'word-width) + *default-operand-size*))) + (princ (schar (symbol-name word-width) 0) stream))))) + + +;;;; Disassembler instruction formats. + +(eval-when (compile eval) + (defun swap-if (direction field1 separator field2) + `(:if (,direction :constant 0) + (,field1 ,separator ,field2) + (,field2 ,separator ,field1)))) + +(disassem:define-instruction-format (byte 8 :default-printer '(:name)) + (op :field (byte 8 0)) + ;; optional fields + (accum :type 'accum) + (imm)) + +(disassem:define-instruction-format (simple 8) + (op :field (byte 7 1)) + (width :field (byte 1 0) :type 'width) + ;; optional fields + (accum :type 'accum) + (imm)) + +;;; Same as simple, but with direction bit +(disassem:define-instruction-format (simple-dir 8 :include 'simple) + (op :field (byte 6 2)) + (dir :field (byte 1 1))) + +;;; Same as simple, but with the immediate value occuring by default, +;;; and with an appropiate printer. +(disassem:define-instruction-format (accum-imm 8 + :include 'simple + :default-printer '(:name + :tab accum ", " imm)) + (imm :type 'imm-data)) + +(disassem:define-instruction-format (reg-no-width 8 + :default-printer '(:name :tab reg)) + (op :field (byte 5 3)) + (reg :field (byte 3 0) :type 'word-reg) + ;; optional fields + (accum :type 'word-accum) + (imm)) + +;;; adds a width field to reg-no-width +(disassem:define-instruction-format (reg 8 :default-printer '(:name :tab reg)) + (op :field (byte 4 4)) + (width :field (byte 1 3) :type 'width) + (reg :field (byte 3 0) :type 'reg) + ;; optional fields + (accum :type 'accum) + (imm) + ) + +;;; Same as reg, but with direction bit +(disassem:define-instruction-format (reg-dir 8 :include 'reg) + (op :field (byte 3 5)) + (dir :field (byte 1 4))) + +(disassem:define-instruction-format (two-bytes 16 + :default-printer '(:name)) + (op :fields (list (byte 8 0) (byte 8 8)))) + +(disassem:define-instruction-format (reg-reg/mem 16 + :default-printer + `(:name :tab reg ", " reg/mem)) + (op :field (byte 7 1)) + (width :field (byte 1 0) :type 'width) + (reg/mem :fields (list (byte 2 14) (byte 3 8)) + :type 'reg/mem) + (reg :field (byte 3 11) :type 'reg) + ;; optional fields + (imm)) + +;;; same as reg-reg/mem, but with direction bit +(disassem:define-instruction-format (reg-reg/mem-dir 16 + :include 'reg-reg/mem + :default-printer + `(:name + :tab + ,(swap-if 'dir 'reg/mem ", " 'reg))) + (op :field (byte 6 2)) + (dir :field (byte 1 1))) + +;;; Same as reg-rem/mem, but uses the reg field as a second op code. +(disassem:define-instruction-format (reg/mem 16 + :default-printer '(:name :tab reg/mem)) + (op :fields (list (byte 7 1) (byte 3 11))) + (width :field (byte 1 0) :type 'width) + (reg/mem :fields (list (byte 2 14) (byte 3 8)) + :type 'sized-reg/mem) + ;; optional fields + (imm)) + +;;; Same as reg/mem, but with the immediate value occuring by default, +;;; and with an appropiate printer. +(disassem:define-instruction-format (reg/mem-imm 16 + :include 'reg/mem + :default-printer + '(:name :tab reg/mem ", " imm)) + (reg/mem :type 'sized-reg/mem) + (imm :type 'imm-data)) + +;;; Same as reg/mem, but with using the accumulator in the default printer +(disassem:define-instruction-format + (accum-reg/mem 16 + :include 'reg/mem :default-printer '(:name :tab accum ", " reg/mem)) + (reg/mem :type 'reg/mem) ; don't need a size + (accum :type 'accum)) + +;;; Same as reg-reg/mem, but with a prefix of #b00001111 +(disassem:define-instruction-format (ext-reg-reg/mem 24 + :default-printer + `(:name :tab reg ", " reg/mem)) + (prefix :field (byte 8 0) :value #b00001111) + (op :field (byte 7 9)) + (width :field (byte 1 8) :type 'width) + (reg/mem :fields (list (byte 2 22) (byte 3 16)) + :type 'reg/mem) + (reg :field (byte 3 19) :type 'reg) + ;; optional fields + (imm)) + +;;; Same as reg/mem, but with a prefix of #b00001111 +(disassem:define-instruction-format (ext-reg/mem 24 + :default-printer '(:name :tab reg/mem)) + (prefix :field (byte 8 0) :value #b00001111) + (op :fields (list (byte 7 9) (byte 3 19))) + (width :field (byte 1 8) :type 'width) + (reg/mem :fields (list (byte 2 22) (byte 3 16)) + :type 'sized-reg/mem) + ;; optional fields + (imm)) + +;;; ---------------------------------------------------------------- +;;; this section added by jrd, for fp instructions. + +;;; +;;; regular fp inst to/from registers/memory +;;; +(disassem:define-instruction-format (floating-point 16 + :default-printer `(:name :tab reg/mem)) + (prefix :field (byte 5 3) :value #b11011) + (op :fields (list (byte 3 0) (byte 3 11))) + (reg/mem :fields (list (byte 2 14) (byte 3 8)) :type 'reg/mem) + ) + +;;; +;;; fp insn to/from fp reg +;;; +(disassem:define-instruction-format (floating-point-fp 16 + :default-printer `(:name :tab fp-reg)) + (prefix :field (byte 5 3) :value #b11011) + (suffix :field (byte 2 14) :value #b11) + (op :fields (list (byte 3 0) (byte 3 11))) + (fp-reg :field (byte 3 8) :type 'fp-reg) + ) + +;;; +;;; fp insn to/from fp reg, with the reversed source/destination flag. +;;; +(disassem:define-instruction-format + (floating-point-fp-d 16 + :default-printer `(:name :tab ,(swap-if 'd "ST0" ", " 'fp-reg))) + (prefix :field (byte 5 3) :value #b11011) + (suffix :field (byte 2 14) :value #b11) + (op :fields (list (byte 2 0) (byte 3 11))) + (d :field (byte 1 2)) + (fp-reg :field (byte 3 8) :type 'fp-reg) + ) + + +;;; pfw +;;; fp no operand isns +;;; +(disassem:define-instruction-format (floating-point-no 16 + :default-printer '(:name)) + (prefix :field (byte 8 0) :value #b11011001) + (suffix :field (byte 3 13) :value #b111) + (op :field (byte 5 8))) + +(disassem:define-instruction-format (floating-point-5 16 + :default-printer '(:name)) + (prefix :field (byte 8 0) :value #b11011011) + (suffix :field (byte 3 13) :value #b111) + (op :field (byte 5 8))) + +(disassem:define-instruction-format (floating-point-st 16 + :default-printer '(:name)) + (prefix :field (byte 8 0) :value #b11011111) + (suffix :field (byte 3 13) :value #b111) + (op :field (byte 5 8))) + + +;;; ---------------------------------------------------------------- + + +;;;; General Data Transfer + +(eval-when (eval compile load) + (defun toggle-word-width (chunk inst stream dstate) + (declare (ignore chunk inst stream)) + (let ((ww (or (disassem:dstate-get-prop dstate 'word-width) + *default-operand-size*))) + (setf (disassem:dstate-get-prop dstate 'word-width) + (ecase ww + (:word :dword) + (:dword :word)))))) + +;;; This isn't a really an instruction, but it's easier to deal with it this +;;; way. We assume that it's actually used. +(define-instruction toggle-data-size (segment) + (:printer byte ((op operand-size-prefix-byte)) + nil ; don't actually print it + :control #'toggle-word-width)) + + +(define-instruction mov (segment dst src) + ;; immediate to register + (:printer reg ((op #b1011) (imm nil :type 'imm-data)) + '(:name :tab reg ", " imm)) + ;; absolute mem to/from accumulator + (:printer simple-dir ((op #b101000) (imm nil :type 'imm-addr)) + `(:name :tab ,(swap-if 'dir 'accum ", " '("[" imm "]")))) + ;; register to/from register/memory + (:printer reg-reg/mem-dir ((op #b100010))) + ;; immediate to register/memory + (:printer reg/mem-imm ((op '(#b1100011 #b000)))) + + (:emitter + (let ((size (matching-operand-size dst src))) + (maybe-emit-operand-size-prefix segment size) + (cond ((register-p dst) + (cond ((integerp src) + (emit-byte-with-reg segment + (if (eq size :byte) + #b10110 + #b10111) + (reg-tn-encoding dst)) + (emit-sized-immediate segment size src)) + ((and (fixup-p src) (accumulator-p dst)) + (emit-byte segment + (if (eq size :byte) + #b10100000 + #b10100001)) + (emit-absolute-fixup segment src)) + (t + (emit-byte segment + (if (eq size :byte) + #b10001010 + #b10001011)) + (emit-ea segment src (reg-tn-encoding dst) t)))) + ((and (fixup-p dst) (accumulator-p src)) + (emit-byte segment (if (eq size :byte) #b10100010 #b10100011)) + (emit-absolute-fixup segment dst)) + ((integerp src) + (emit-byte segment (if (eq size :byte) #b11000110 #b11000111)) + (emit-ea segment dst #b000) + (emit-sized-immediate segment size src)) + ((register-p src) + (emit-byte segment (if (eq size :byte) #b10001000 #b10001001)) + (emit-ea segment dst (reg-tn-encoding src))) + ((fixup-p src) + (assert (eq size :dword)) + (emit-byte segment #b11000111) + (emit-ea segment dst #b000) + (emit-absolute-fixup segment src)) + (t + (error "Bogus arguments to MOV: ~S ~S" dst src)))))) + +(defun emit-move-with-extension (segment dst src opcode) + (assert (register-p dst)) + (let ((dst-size (operand-size dst)) + (src-size (operand-size src))) + (ecase dst-size + (:word + (assert (eq src-size :byte)) + (maybe-emit-operand-size-prefix segment :word) + (emit-byte segment #b00001111) + (emit-byte segment opcode) + (emit-ea segment src (reg-tn-encoding dst))) + (:dword + (ecase src-size + (:byte + (maybe-emit-operand-size-prefix segment :dword) + (emit-byte segment #b00001111) + (emit-byte segment opcode) + (emit-ea segment src (reg-tn-encoding dst))) + (:word + (emit-byte segment #b00001111) + (emit-byte segment (logior opcode 1)) + (emit-ea segment src (reg-tn-encoding dst)))))))) + +(define-instruction movsx (segment dst src) + (:printer ext-reg-reg/mem ((op #b1011111) (reg nil :type 'word-reg))) + (:emitter + (emit-move-with-extension segment dst src #b10111110))) + +(define-instruction movzx (segment dst src) + (:printer ext-reg-reg/mem ((op #b1011011) (reg nil :type 'word-reg))) + (:emitter + (emit-move-with-extension segment dst src #b10110110))) + +(define-instruction push (segment src) + ;; Register. + (:printer reg-no-width ((op #b01010))) + ;; Register/Memory. + (:printer reg/mem ((op '(#b1111111 #b110)) (width 1))) + ;; Immediate. + (:printer byte ((op #b01101010) (imm nil :type 'signed-imm-byte)) + '(:name :tab imm)) + (:printer byte ((op #b01101000) (imm nil :type 'imm-word)) + '(:name :tab imm)) + ;; ### Segment registers? + + (:emitter + (cond ((integerp src) + (cond ((<= -128 src 127) + (emit-byte segment #b01101010) + (emit-byte segment src)) + (t + (emit-byte segment #b01101000) + (emit-dword segment src)))) + ((fixup-p src) + ;; Interpret the fixup as an immediate dword to push + (emit-byte segment #b01101000) + (emit-absolute-fixup segment src)) + (t + (let ((size (operand-size src))) + (assert (not (eq size :byte))) + (maybe-emit-operand-size-prefix segment size) + (cond ((register-p src) + (emit-byte-with-reg segment #b01010 (reg-tn-encoding src))) + (t + (emit-byte segment #b11111111) + (emit-ea segment src #b110 t)))))))) + +(define-instruction pusha (segment) + (:printer byte ((op #b01100000))) + (:emitter + (emit-byte segment #b01100000))) + +(define-instruction pop (segment dst) + (:printer reg-no-width ((op #b01011))) + (:printer reg/mem ((op '(#b1000111 #b000)) (width 1))) + (:emitter + (let ((size (operand-size dst))) + (assert (not (eq size :byte))) + (maybe-emit-operand-size-prefix segment size) + (cond ((register-p dst) + (emit-byte-with-reg segment #b01011 (reg-tn-encoding dst))) + (t + (emit-byte segment #b10001111) + (emit-ea segment dst #b000)))))) + +(define-instruction popa (segment) + (:printer byte ((op #b01100001))) + (:emitter + (emit-byte segment #b01100001))) + +(define-instruction xchg (segment operand1 operand2) + ;; Register with accumulator. + (:printer reg-no-width ((op #b10010)) '(:name :tab accum ", " reg)) + ;; Register/Memory with Register. + (:printer reg-reg/mem ((op #b1000011))) + (:emitter + (let ((size (matching-operand-size operand1 operand2))) + (maybe-emit-operand-size-prefix segment size) + (labels ((xchg-acc-with-something (acc something) + (if (and (not (eq size :byte)) (register-p something)) + (emit-byte-with-reg segment + #b10010 + (reg-tn-encoding something)) + (xchg-reg-with-something acc something))) + (xchg-reg-with-something (reg something) + (emit-byte segment (if (eq size :byte) #b10000110 #b10000111)) + (emit-ea segment something (reg-tn-encoding reg)))) + (cond ((accumulator-p operand1) + (xchg-acc-with-something operand1 operand2)) + ((accumulator-p operand2) + (xchg-acc-with-something operand2 operand1)) + ((register-p operand1) + (xchg-reg-with-something operand1 operand2)) + ((register-p operand2) + (xchg-reg-with-something operand2 operand1)) + (t + (error "Bogus args to XCHG: ~S ~S" operand1 operand2))))))) + +(define-instruction lea (segment dst src) + (:printer reg-reg/mem ((op #b1000110) (width 1))) + (:emitter + (assert (dword-reg-p dst)) + (emit-byte segment #b10001101) + (emit-ea segment src (reg-tn-encoding dst)))) + + + +;;;; Flag control instructions. + +;;; CLC -- Clear Carry Flag. +;;; +(define-instruction clc (segment) + (:printer byte ((op #b11111000))) + (:emitter + (emit-byte segment #b11111000))) + +;;; CLD -- Clear Direction Flag. +;;; +(define-instruction cld (segment) + (:printer byte ((op #b11111100))) + (:emitter + (emit-byte segment #b11111100))) + +;;; CLI -- Clear Iterrupt Enable Flag. +;;; +(define-instruction cli (segment) + (:printer byte ((op #b11111010))) + (:emitter + (emit-byte segment #b11111010))) + +;;; CMC -- Complement Carry Flag. +;;; +(define-instruction cmc (segment) + (:printer byte ((op #b11110101))) + (:emitter + (emit-byte segment #b11110101))) + +;;; LAHF -- Load AH into flags. +;;; +(define-instruction lahf (segment) + (:printer byte ((op #b10011111))) + (:emitter + (emit-byte segment #b10011111))) + +;;; POPF -- Pop flags. +;;; +(define-instruction popf (segment) + (:printer byte ((op #b10011101))) + (:emitter + (emit-byte segment #b10011101))) + +;;; PUSHF -- push flags. +;;; +(define-instruction pushf (segment) + (:printer byte ((op #b10011100))) + (:emitter + (emit-byte segment #b10011100))) + +;;; SAHF -- Store AH into flags. +;;; +(define-instruction sahf (segment) + (:printer byte ((op #b10011110))) + (:emitter + (emit-byte segment #b10011110))) + +;;; STC -- Set Carry Flag. +;;; +(define-instruction stc (segment) + (:printer byte ((op #b11111001))) + (:emitter + (emit-byte segment #b11111001))) + +;;; STD -- Set Direction Flag. +;;; +(define-instruction std (segment) + (:printer byte ((op #b11111101))) + (:emitter + (emit-byte segment #b11111101))) + +;;; STI -- Set Interrupt Enable Flag. +;;; +(define-instruction sti (segment) + (:printer byte ((op #b11111011))) + (:emitter + (emit-byte segment #b11111011))) + + + +;;;; Arithmetic + +(defun emit-random-arith-inst (name segment dst src opcode + &optional allow-constants) + (let ((size (matching-operand-size dst src))) + (maybe-emit-operand-size-prefix segment size) + (cond + ((integerp src) + (cond ((and (not (eq size :byte)) (<= -128 src 127)) + (emit-byte segment #b10000011) + (emit-ea segment dst opcode) + (emit-byte segment src)) + ((accumulator-p dst) + (emit-byte segment + (dpb opcode + (byte 3 3) + (if (eq size :byte) + #b00000100 + #b00000101))) + (emit-sized-immediate segment size src)) + (t + (emit-byte segment (if (eq size :byte) #b10000000 #b10000001)) + (emit-ea segment dst opcode) + (emit-sized-immediate segment size src)))) + ((register-p src) + (emit-byte segment + (dpb opcode + (byte 3 3) + (if (eq size :byte) #b00000000 #b00000001))) + (emit-ea segment dst (reg-tn-encoding src) allow-constants)) + ((register-p dst) + (emit-byte segment + (dpb opcode + (byte 3 3) + (if (eq size :byte) #b00000010 #b00000011))) + (emit-ea segment src (reg-tn-encoding dst) allow-constants)) + (t + (error "Bogus operands to ~A" name))))) + +(eval-when (compile eval) + (defun arith-inst-printer-list (subop) + `((accum-imm ((op ,(dpb subop (byte 3 2) #b0000010)))) + (reg/mem-imm ((op (#b1000000 ,subop)))) + (reg/mem-imm ((op (#b1000001 ,subop)) + (imm nil :type signed-imm-byte))) + (reg-reg/mem-dir ((op ,(dpb subop (byte 3 1) #b000000)))))) + ) + +(define-instruction add (segment dst src) + (:printer-list + (arith-inst-printer-list #b000)) + (:emitter + (emit-random-arith-inst "ADD" segment dst src #b000))) + +(define-instruction adc (segment dst src) + (:printer-list + (arith-inst-printer-list #b010)) + (:emitter + (emit-random-arith-inst "ADC" segment dst src #b010))) + +(define-instruction sub (segment dst src) + (:printer-list + (arith-inst-printer-list #b101)) + (:emitter + (emit-random-arith-inst "SUB" segment dst src #b101))) + +(define-instruction sbb (segment dst src) + (:printer-list + (arith-inst-printer-list #b011)) + (:emitter + (emit-random-arith-inst "SBB" segment dst src #b011))) + +(define-instruction cmp (segment dst src) + (:printer-list + (arith-inst-printer-list #b111)) + (:emitter + (emit-random-arith-inst "CMP" segment dst src #b111 t))) + +(define-instruction inc (segment dst) + ;; Register. + (:printer reg-no-width ((op #b01000))) + ;; Register/Memory + (:printer reg/mem ((op '(#b1111111 #b000)))) + (:emitter + (let ((size (operand-size dst))) + (maybe-emit-operand-size-prefix segment size) + (cond ((and (not (eq size :byte)) (register-p dst)) + (emit-byte-with-reg segment #b01000 (reg-tn-encoding dst))) + (t + (emit-byte segment (if (eq size :byte) #b11111110 #b11111111)) + (emit-ea segment dst #b000)))))) + +(define-instruction dec (segment dst) + ;; Register. + (:printer reg-no-width ((op #b01001))) + ;; Register/Memory + (:printer reg/mem ((op '(#b1111111 #b001)))) + (:emitter + (let ((size (operand-size dst))) + (maybe-emit-operand-size-prefix segment size) + (cond ((and (not (eq size :byte)) (register-p dst)) + (emit-byte-with-reg segment #b01001 (reg-tn-encoding dst))) + (t + (emit-byte segment (if (eq size :byte) #b11111110 #b11111111)) + (emit-ea segment dst #b001)))))) + +(define-instruction neg (segment dst) + (:printer reg/mem ((op '(#b1111011 #b011)))) + (:emitter + (let ((size (operand-size dst))) + (maybe-emit-operand-size-prefix segment size) + (emit-byte segment (if (eq size :byte) #b11110110 #b11110111)) + (emit-ea segment dst #b011)))) + +(define-instruction aaa (segment) + (:printer byte ((op #b00110111))) + (:emitter + (emit-byte segment #b00110111))) + +(define-instruction aas (segment) + (:printer byte ((op #b00111111))) + (:emitter + (emit-byte segment #b00111111))) + +(define-instruction daa (segment) + (:printer byte ((op #b00100111))) + (:emitter + (emit-byte segment #b00100111))) + +(define-instruction das (segment) + (:printer byte ((op #b00101111))) + (:emitter + (emit-byte segment #b00101111))) + +(define-instruction mul (segment dst src) + (:printer accum-reg/mem ((op '(#b1111011 #b100)))) + (:emitter + (let ((size (matching-operand-size dst src))) + (assert (accumulator-p dst)) + (maybe-emit-operand-size-prefix segment size) + (emit-byte segment (if (eq size :byte) #b11110110 #b11110111)) + (emit-ea segment src #b100)))) + +(define-instruction imul (segment dst &optional src1 src2) + (:printer accum-reg/mem ((op '(#b1111011 #b101)))) + (:printer ext-reg-reg/mem ((op #b1010111))) + (:printer reg-reg/mem ((op #b0110100) (width 1) (imm nil :type 'imm-word)) + '(:name :tab reg ", " reg/mem ", " imm)) + (:printer reg-reg/mem ((op #b0110101) (width 1) + (imm nil :type 'signed-imm-byte)) + '(:name :tab reg ", " reg/mem ", " imm)) + (:emitter + (flet ((r/m-with-immed-to-reg (reg r/m immed) + (let* ((size (matching-operand-size reg r/m)) + (sx (and (not (eq size :byte)) (<= -128 immed 127)))) + (maybe-emit-operand-size-prefix segment size) + (emit-byte segment (if sx #b01101011 #b01101001)) + (emit-ea segment r/m (reg-tn-encoding reg)) + (if sx + (emit-byte segment immed) + (emit-sized-immediate segment size immed))))) + (cond (src2 + (r/m-with-immed-to-reg dst src1 src2)) + (src1 + (if (integerp src1) + (r/m-with-immed-to-reg dst dst src1) + (let ((size (matching-operand-size dst src1))) + (maybe-emit-operand-size-prefix segment size) + (emit-byte segment #b00001111) + (emit-byte segment #b10101111) + (emit-ea segment src1 (reg-tn-encoding dst))))) + (t + (let ((size (operand-size dst))) + (maybe-emit-operand-size-prefix segment size) + (emit-byte segment (if (eq size :byte) #b11110110 #b11110111)) + (emit-ea segment dst #b101))))))) + +(define-instruction div (segment dst src) + (:printer accum-reg/mem ((op '(#b1111011 #b110)))) + (:emitter + (let ((size (matching-operand-size dst src))) + (assert (accumulator-p dst)) + (maybe-emit-operand-size-prefix segment size) + (emit-byte segment (if (eq size :byte) #b11110110 #b11110111)) + (emit-ea segment src #b110)))) + +(define-instruction idiv (segment dst src) + (:printer accum-reg/mem ((op '(#b1111011 #b111)))) + (:emitter + (let ((size (matching-operand-size dst src))) + (assert (accumulator-p dst)) + (maybe-emit-operand-size-prefix segment size) + (emit-byte segment (if (eq size :byte) #b11110110 #b11110111)) + (emit-ea segment src #b111)))) + +(define-instruction aad (segment) + (:printer two-bytes ((op '(#b11010101 #b00001010)))) + (:emitter + (emit-byte segment #b11010101) + (emit-byte segment #b00001010))) + +(define-instruction aam (segment) + (:printer two-bytes ((op '(#b11010100 #b00001010)))) + (:emitter + (emit-byte segment #b11010100) + (emit-byte segment #b00001010))) + +;;; CBW -- Convert Byte to Word. AX <- sign_xtnd(AL) +;;; +(define-instruction cbw (segment) + (:emitter + (maybe-emit-operand-size-prefix segment :word) + (emit-byte segment #b10011000))) + +;;; CWDE -- Convert Word To Double Word Extened. EAX <- sign_xtnd(AX) +;;; +(define-instruction cwde (segment) + (:emitter + (maybe-emit-operand-size-prefix segment :dword) + (emit-byte segment #b10011000))) + +;;; CWD -- Convert Word to Double Word. DX:AX <- sign_xtnd(AX) +;;; +(define-instruction cwd (segment) + (:emitter + (maybe-emit-operand-size-prefix segment :word) + (emit-byte segment #b10011001))) + +;;; CDQ -- Convert Double Word to Quad Word. EDX:EAX <- sign_xtnd(EAX) +;;; +(define-instruction cdq (segment) + (:emitter + (maybe-emit-operand-size-prefix segment :dword) + (emit-byte segment #b10011001))) + + +;;;; Logic. + +(defun emit-shift-inst (segment dst amount opcode) + (let ((size (operand-size dst))) + (maybe-emit-operand-size-prefix segment size) + (multiple-value-bind + (major-opcode immed) + (case amount + (:cl (values #b11010010 nil)) + (1 (values #b11010000 nil)) + (t (values #b11000000 t))) + (emit-byte segment + (if (eq size :byte) major-opcode (logior major-opcode 1))) + (emit-ea segment dst opcode) + (when immed + (emit-byte segment amount))))) + +(eval-when (compile eval) + (defun shift-inst-printer-list (subop) + `((reg/mem ((op (#b1101000 ,subop))) + (:name :tab reg/mem ", 1")) + (reg/mem ((op (#b1101001 ,subop))) + (:name :tab reg/mem ", " 'cl)) + (reg/mem-imm ((op (#b1100000 ,subop)) + (imm nil :type signed-imm-byte)))))) + +(define-instruction rol (segment dst amount) + (:printer-list + (shift-inst-printer-list #b000)) + (:emitter + (emit-shift-inst segment dst amount #b000))) + +(define-instruction ror (segment dst amount) + (:printer-list + (shift-inst-printer-list #b001)) + (:emitter + (emit-shift-inst segment dst amount #b001))) + +(define-instruction rcl (segment dst amount) + (:printer-list + (shift-inst-printer-list #b010)) + (:emitter + (emit-shift-inst segment dst amount #b010))) + +(define-instruction rcr (segment dst amount) + (:printer-list + (shift-inst-printer-list #b011)) + (:emitter + (emit-shift-inst segment dst amount #b011))) + +(define-instruction shl (segment dst amount) + (:printer-list + (shift-inst-printer-list #b100)) + (:emitter + (emit-shift-inst segment dst amount #b100))) + +(define-instruction shr (segment dst amount) + (:printer-list + (shift-inst-printer-list #b101)) + (:emitter + (emit-shift-inst segment dst amount #b101))) + +(define-instruction sar (segment dst amount) + (:printer-list + (shift-inst-printer-list #b111)) + (:emitter + (emit-shift-inst segment dst amount #b111))) + +(defun emit-double-shift (segment opcode dst src amt) + (let ((size (matching-operand-size dst src))) + (when (eq size :byte) + (error "Double shifts can only be used with words.")) + (maybe-emit-operand-size-prefix segment size) + (emit-byte segment #b00001111) + (emit-byte segment (dpb opcode (byte 1 3) + (if (eq amt :cl) #b10100101 #b10100100))) + #+nil + (emit-ea segment dst src) + (emit-ea segment dst (reg-tn-encoding src)) ; pw tries this + (unless (eq amt :cl) + (emit-byte segment amt)))) + +(eval-when (compile eval) + (defun double-shift-inst-printer-list (op) + `(#+nil + (ext-reg-reg/mem-imm ((op ,(logior op #b100)) + (imm nil :type signed-imm-byte))) + (ext-reg-reg/mem ((op ,(logior op #b101))) + (:name :tab reg/mem ", " 'cl))))) + +(define-instruction shld (segment dst src amt) + (:declare (type (or (member :cl) (mod 32)) amt)) + (:printer-list (double-shift-inst-printer-list #b10100000)) + (:emitter + (emit-double-shift segment #b0 dst src amt))) + +(define-instruction shrd (segment dst src amt) + (:declare (type (or (member :cl) (mod 32)) amt)) + (:printer-list (double-shift-inst-printer-list #b10101000)) + (:emitter + (emit-double-shift segment #b1 dst src amt))) + +(define-instruction and (segment dst src) + (:printer-list + (arith-inst-printer-list #b100)) + (:emitter + (emit-random-arith-inst "AND" segment dst src #b100))) + +(define-instruction test (segment this that) + (:printer accum-imm ((op #b1010100))) + (:printer reg/mem-imm ((op '(#b1111011 #b000)))) + (:printer reg-reg/mem ((op #b1000010))) + (:emitter + (let ((size (matching-operand-size this that))) + (maybe-emit-operand-size-prefix segment size) + (flet ((test-immed-and-something (immed something) + (cond ((accumulator-p something) + (emit-byte segment + (if (eq size :byte) #b10101000 #b10101001)) + (emit-sized-immediate segment size immed)) + (t + (emit-byte segment + (if (eq size :byte) #b11110110 #b11110111)) + (emit-ea segment something #b000) + (emit-sized-immediate segment size immed)))) + (test-reg-and-something (reg something) + (emit-byte segment (if (eq size :byte) #b10000100 #b10000101)) + (emit-ea segment something (reg-tn-encoding reg)))) + (cond ((integerp that) + (test-immed-and-something that this)) + ((integerp this) + (test-immed-and-something this that)) + ((register-p this) + (test-reg-and-something this that)) + ((register-p that) + (test-reg-and-something that this)) + (t + (error "Bogus operans for TEST: ~S and ~S" this that))))))) + +(define-instruction or (segment dst src) + (:printer-list + (arith-inst-printer-list #b001)) + (:emitter + (emit-random-arith-inst "OR" segment dst src #b001))) + +(define-instruction xor (segment dst src) + (:printer-list + (arith-inst-printer-list #b110)) + (:emitter + (emit-random-arith-inst "XOR" segment dst src #b110))) + +(define-instruction not (segment dst) + (:printer reg/mem ((op '(#b1111011 #b010)))) + (:emitter + (let ((size (operand-size dst))) + (maybe-emit-operand-size-prefix segment size) + (emit-byte segment (if (eq size :byte) #b11110110 #b11110111)) + (emit-ea segment dst #b010)))) + + +;;;; String manipulation. + +(disassem:define-instruction-format (string-op 8 + :include 'simple + :default-printer '(:name width))) + +(define-instruction cmps (segment size) + (:printer string-op ((op #b1010011))) + (:emitter + (maybe-emit-operand-size-prefix segment size) + (emit-byte segment (if (eq size :byte) #b10100110 #b10100111)))) + +(define-instruction ins (segment acc) + (:printer string-op ((op #b0110110))) + (:emitter + (let ((size (operand-size acc))) + (assert (accumulator-p acc)) + (maybe-emit-operand-size-prefix segment size) + (emit-byte segment (if (eq size :byte) #b01101100 #b01101101))))) + +(define-instruction lods (segment acc) + (:printer string-op ((op #b1010110))) + (:emitter + (let ((size (operand-size acc))) + (assert (accumulator-p acc)) + (maybe-emit-operand-size-prefix segment size) + (emit-byte segment (if (eq size :byte) #b10101100 #b10101101))))) + +(define-instruction movs (segment size) + (:printer string-op ((op #b1010010))) + (:emitter + (maybe-emit-operand-size-prefix segment size) + (emit-byte segment (if (eq size :byte) #b10100100 #b10100101)))) + +(define-instruction outs (segment acc) + (:printer string-op ((op #b0110111))) + (:emitter + (let ((size (operand-size acc))) + (assert (accumulator-p acc)) + (maybe-emit-operand-size-prefix segment size) + (emit-byte segment (if (eq size :byte) #b01101110 #b01101111))))) + +(define-instruction scas (segment acc) + (:printer string-op ((op #b1010111))) + (:emitter + (let ((size (operand-size acc))) + (assert (accumulator-p acc)) + (maybe-emit-operand-size-prefix segment size) + (emit-byte segment (if (eq size :byte) #b10101110 #b10101111))))) + +(define-instruction stos (segment acc) + (:printer string-op ((op #b1010101))) + (:emitter + (let ((size (operand-size acc))) + (assert (accumulator-p acc)) + (maybe-emit-operand-size-prefix segment size) + (emit-byte segment (if (eq size :byte) #b10101010 #b10101011))))) + +(define-instruction xlat (segment) + (:printer byte ((op #b11010111))) + (:emitter + (emit-byte segment #b11010111))) + +(define-instruction rep (segment) + (:emitter + (emit-byte segment #b11110010))) + +(define-instruction repe (segment) + (:printer byte ((op #b11110011))) + (:emitter + (emit-byte segment #b11110011))) + +(define-instruction repne (segment) + (:printer byte ((op #b11110010))) + (:emitter + (emit-byte segment #b11110010))) + + +;;;; Bit Manipulation + +(define-instruction bsf (segment dst src) + (:emitter + (let ((size (matching-operand-size dst src))) + (when (eq size :byte) + (error "Can't scan bytes: ~S" src)) + (maybe-emit-operand-size-prefix segment size) + (emit-byte segment #b00001111) + (emit-byte segment #b10111100) + (emit-ea segment src (reg-tn-encoding dst))))) + +(define-instruction bsr (segment dst src) + (:emitter + (let ((size (matching-operand-size dst src))) + (when (eq size :byte) + (error "Can't scan bytes: ~S" src)) + (maybe-emit-operand-size-prefix segment size) + (emit-byte segment #b00001111) + (emit-byte segment #b10111101) + (emit-ea segment src (reg-tn-encoding dst))))) + +(defun emit-bit-test-and-mumble (segment src index opcode) + (let ((size (operand-size src))) + (when (eq size :byte) + (error "Can't scan bytes: ~S" src)) + (maybe-emit-operand-size-prefix segment size) + (emit-byte segment #b00001111) + (cond ((integerp index) + (emit-byte segment #b10111010) + (emit-ea segment src opcode) + (emit-byte segment index)) + (t + (emit-byte segment (dpb opcode (byte 3 3) #b10000011)) + (emit-ea segment src (reg-tn-encoding index)))))) + +(define-instruction bt (segment src index) + (:emitter + (emit-bit-test-and-mumble segment src index #b100))) + +(define-instruction btc (segment src index) + (:emitter + (emit-bit-test-and-mumble segment src index #b111))) + +(define-instruction btr (segment src index) + (:emitter + (emit-bit-test-and-mumble segment src index #b110))) + +(define-instruction bts (segment src index) + (:emitter + (emit-bit-test-and-mumble segment src index #b101))) + + +;;;; Control transfer. + +(eval-when (compile load eval) +(defparameter condition-name-vec + (let ((vec (make-array 16 :initial-element nil))) + (dolist (cond conditions) + (when (null (aref vec (cdr cond))) + (setf (aref vec (cdr cond)) (car cond)))) + vec))) + +(disassem:define-argument-type condition-code + :printer condition-name-vec) + +(disassem:define-argument-type displacement + :sign-extend t + :use-label #'offset-next) + +(disassem:define-instruction-format (short-cond-jump 16) + (op :field (byte 4 4)) + (cc :field (byte 4 0) :type 'condition-code) + (label :field (byte 8 8) :type 'displacement)) + +(disassem:define-instruction-format (short-jump 16 + :default-printer '(:name :tab label)) + (const :field (byte 4 4) :value #b1110) + (op :field (byte 4 0)) + (label :field (byte 8 8) :type 'displacement)) + +(disassem:define-instruction-format (near-cond-jump 16) + (op :fields (list (byte 8 0) (byte 4 12)) :value '(#b00001111 #b1000)) + (cc :field (byte 4 8) :type 'condition-code) + ;; The disassembler currently doesn't let you have an instruction > 32 bits + ;; long, so we fake it by using a prefilter to read the offset. + (label :type 'displacement :prefilter #'read-signed-imm-dword)) + +(disassem:define-instruction-format (near-jump 8 + :default-printer '(:name :tab label)) + (op :field (byte 8 0)) + ;; The disassembler currently doesn't let you have an instruction > 32 bits + ;; long, so we fake it by using a prefilter to read the address. + (label :type 'displacement :prefilter #'read-signed-imm-dword)) + + +(define-instruction call (segment where) + (:printer near-jump ((op #b11101000))) + (:printer reg/mem ((op '(#b1111111 #b010)) (width 1))) + (:emitter + (typecase where + (label + (emit-byte segment #b11101000) + (emit-back-patch segment 4 + #'(lambda (segment posn) + (emit-dword segment + (- (label-position where) + (+ posn 4)))))) + (fixup + (emit-byte segment #b11101000) + (emit-relative-fixup segment where)) + (t + (emit-byte segment #b11111111) + (emit-ea segment where #b010))))) + +(defun emit-byte-displacement-backpatch (segment target) + (emit-back-patch segment 1 + #'(lambda (segment posn) + (let ((disp (- (label-position target) (1+ posn)))) + (assert (<= -128 disp 127)) + (emit-byte segment disp))))) + +(define-instruction jmp (segment cond &optional where) + ;; conditional jumps + (:printer short-cond-jump ((op #b0111)) '('j cc :tab label)) + (:printer near-cond-jump () '('j cc :tab label)) + ;; unconditional jumps + (:printer short-jump ((op #b1011))) + (:printer near-jump ((op #b11101001)) ) + (:printer reg/mem ((op '(#b1111111 #b100)) (width 1))) + (:emitter + (cond (where + (emit-chooser + segment 6 2 + #'(lambda (segment posn delta-if-after) + (let ((disp (- (label-position where posn delta-if-after) + (+ posn 2)))) + (when (<= -128 disp 127) + (emit-byte segment + (dpb (conditional-opcode cond) + (byte 4 0) + #b01110000)) + (emit-byte-displacement-backpatch segment where) + t))) + #'(lambda (segment posn) + (let ((disp (- (label-position where) (+ posn 6)))) + (emit-byte segment #b00001111) + (emit-byte segment + (dpb (conditional-opcode cond) + (byte 4 0) + #b10000000)) + (emit-dword segment disp))))) + ((label-p (setq where cond)) + (emit-chooser + segment 5 0 + #'(lambda (segment posn delta-if-after) + (let ((disp (- (label-position where posn delta-if-after) + (+ posn 2)))) + (when (<= -128 disp 127) + (emit-byte segment #b11101011) + (emit-byte-displacement-backpatch segment where) + t))) + #'(lambda (segment posn) + (let ((disp (- (label-position where) (+ posn 5)))) + (emit-byte segment #b11101001) + (emit-dword segment disp)) + ))) + ((fixup-p where) + (emit-byte segment #b11101001) + (emit-relative-fixup segment where)) + (t + (unless (or (ea-p where) (tn-p where)) + (error "Don't know what to do with ~A" where)) + (emit-byte segment #b11111111) + (emit-ea segment where #b100))))) + +(define-instruction jmp-short (segment label) + (:emitter + (emit-byte segment #b11101011) + (emit-byte-displacement-backpatch segment label))) + +(define-instruction ret (segment &optional stack-delta) + (:printer byte ((op #b11000011))) + (:printer byte ((op #b11000010) (imm nil :type 'imm-word-16)) + '(:name :tab imm)) + (:emitter + (cond (stack-delta + (emit-byte segment #b11000010) + (emit-word segment stack-delta)) + (t + (emit-byte segment #b11000011))))) + +(define-instruction jecxz (segment target) + (:printer short-jump ((op #b0011))) + (:emitter + (emit-byte segment #b11100011) + (emit-byte-displacement-backpatch segment target))) + +(define-instruction loop (segment target) + (:printer short-jump ((op #b0010))) + (:emitter + (emit-byte segment #b11100010) ; pfw this was 11100011, or jecxz!!!! + (emit-byte-displacement-backpatch segment target))) + +(define-instruction loopz (segment target) + (:printer short-jump ((op #b0001))) + (:emitter + (emit-byte segment #b11100001) + (emit-byte-displacement-backpatch segment target))) + +(define-instruction loopnz (segment target) + (:printer short-jump ((op #b0000))) + (:emitter + (emit-byte segment #b11100000) + (emit-byte-displacement-backpatch segment target))) + + +;;;; Conditional byte set. + +(disassem:define-instruction-format (cond-set 24 + :default-printer '('set cc :tab reg/mem)) + (prefix :field (byte 8 0) :value #b00001111) + (op :field (byte 4 12) :value #b1001) + (cc :field (byte 4 8) :type 'condition-code) + (reg/mem :fields (list (byte 2 22) (byte 3 16)) + :type 'byte-reg/mem) + (reg :field (byte 3 19) :value #b000)) + +(define-instruction set (segment dst cond) + (:printer cond-set ()) + (:emitter + (emit-byte segment #b00001111) + (emit-byte segment (dpb (conditional-opcode cond) (byte 4 0) #b10010000)) + (emit-ea segment dst #b000))) + + +;;;; Enter/Leave + +(disassem:define-instruction-format + (enter-format + 24 + :default-printer '(:name :tab disp (:unless (:constant 0) ", " level))) + (op :field (byte 8 0)) + (disp :field (byte 16 8)) + (level :field (byte 8 16))) + +(define-instruction enter (segment disp &optional (level 0)) + (:declare (type (unsigned-byte 16) disp) + (type (unsigned-byte 8) level)) + (:emitter + (emit-byte segment #b11001000) + (emit-word segment disp) + (emit-byte segment level))) + +(define-instruction leave (segment) + (:printer byte ((op #b11001001))) + (:emitter + (emit-byte segment #b11001001))) + + +;;;; Interrupt instructions. + +(disassem:define-instruction-format + (break 16 :default-printer '(:name :tab code)) + (op :field (byte 8 0) :value #b11001100) + (code :field (byte 8 8))) + +(define-emitter emit-break-inst 16 + (byte 8 0) (byte 8 8)) + +(defun snarf-error-junk (sap offset &optional length-only) + (let* ((length (system:sap-ref-8 sap offset)) + (vector (make-array length :element-type '(unsigned-byte 8)))) + (declare (type system:system-area-pointer sap) + (type (unsigned-byte 8) length) + (type (simple-array (unsigned-byte 8) (*)) vector)) + (cond (length-only + (values 0 (1+ length) nil nil)) + (t + (kernel:copy-from-system-area sap (* byte-bits (1+ offset)) + vector (* word-bits + vector-data-offset) + (* length byte-bits)) + (collect ((sc-offsets) + (lengths)) + (lengths 1) ; the length byte + (let* ((index 0) + (error-number (c::read-var-integer vector index))) + (lengths index) + (loop + (when (>= index length) + (return)) + (let ((old-index index)) + (sc-offsets (c::read-var-integer vector index)) + (lengths (- index old-index)))) + (values error-number + (1+ length) + (sc-offsets) + (lengths)))))))) + +(defmacro break-cases (breaknum &body cases) + (let ((bn-temp (gensym))) + (collect ((clauses)) + (dolist (case cases) + (clauses `((= ,bn-temp ,(car case)) ,@(cdr case)))) + `(let ((,bn-temp ,breaknum)) + (cond ,@(clauses)))))) + +(defun break-control (chunk inst stream dstate) + (declare (ignore inst)) + (flet ((nt (x) (if stream (disassem:note x dstate)))) + (case (break-code chunk dstate) + (#.vm:error-trap + (nt "Error trap") + (disassem:handle-break-args #'snarf-error-junk stream dstate)) + (#.vm:cerror-trap + (nt "Cerror trap") + (disassem:handle-break-args #'snarf-error-junk stream dstate)) + (#.vm:breakpoint-trap + (nt "Breakpoint trap")) + (#.vm:pending-interrupt-trap + (nt "Pending interrupt trap")) + (#.vm:halt-trap + (nt "Halt trap")) + (#.vm:function-end-breakpoint-trap + (nt "Function end breakpoint trap")) + ))) + +(define-instruction break (segment code) + (:declare (type (unsigned-byte 8) code)) + (:printer break ((op #b11001100)) + '(:name :tab code) + :control #'break-control ) + (:emitter + (emit-break-inst segment #b11001100 code))) + +(define-instruction int (segment number) + (:declare (type (unsigned-byte 8) number)) + (:emitter + (etypecase number + ((member 3) + (emit-byte segment #b11001100)) + ((unsigned-byte 8) + (emit-byte segment #b11001101) + (emit-byte segment number))))) + +(define-instruction into (segment) + (:printer byte ((op #b11001110))) + (:emitter + (emit-byte segment #b11001110))) + +(define-instruction bound (segment reg bounds) + (:emitter + (let ((size (matching-operand-size reg bounds))) + (when (eq size :byte) + (error "Can't bounds-test bytes: ~S" reg)) + (maybe-emit-operand-size-prefix segment size) + (emit-byte segment #b01100010) + (emit-ea segment bounds (reg-tn-encoding reg))))) + +(define-instruction iret (segment) + (:printer byte ((op #b11001111))) + (:emitter + (emit-byte segment #b11001111))) + + +;;;; Processor control + +(define-instruction hlt (segment) + (:printer byte ((op #b11110100))) + (:emitter + (emit-byte segment #b11110100))) + +(define-instruction nop (segment) + (:printer byte ((op #b10010000))) + (:emitter + (emit-byte segment #b10010000))) + +(define-instruction wait (segment) + (:printer byte ((op #b10011011))) + (:emitter + (emit-byte segment #b10011011))) + +(define-instruction lock (segment) + (:printer byte ((op #b11110000))) + (:emitter + (emit-byte segment #b11110000))) + + + +;;;; Random hackery + +(define-instruction byte (segment byte) + (:emitter + (emit-byte segment byte))) + +(define-instruction word (segment word) + (:emitter + (emit-word segment word))) + +(define-instruction dword (segment dword) + (:emitter + (emit-dword segment dword))) + +(defun emit-header-data (segment type) + (emit-back-patch + segment 4 + #'(lambda (segment posn) + (emit-dword segment + (logior type + (ash (+ posn (component-header-length)) + (- type-bits word-shift))))))) + +(define-instruction function-header-word (segment) + (:emitter + (emit-header-data segment function-header-type))) + +(define-instruction lra-header-word (segment) + (:emitter + (emit-header-data segment return-pc-header-type))) + +;;; ---------------------------------------------------------------- +;;; added by jrd. fp instructions +;;; + +;;; +;;; we treat the single-precision and double-precision variants +;;; as separate instructions +;;; + +;;; +;;; load single to st(0) +;;; +(define-instruction fld (segment source) + (:printer floating-point ((op '(#b001 #b000)))) + (:emitter + (emit-byte segment #b11011001) + (emit-fp-op segment source #b000))) + +;;; +;;; load double to st(0) +;;; +(define-instruction fldd (segment source) + (:printer floating-point ((op '(#b101 #b000)))) + (:printer floating-point-fp ((op '(#b001 #b000)))) + (:emitter + (if (fp-reg-tn-p source) + (emit-byte segment #b11011001) + (emit-byte segment #b11011101)) + (emit-fp-op segment source #b000))) + +;;; +;;; store single from st(0) +;;; +(define-instruction fst (segment dest) + (:printer floating-point ((op '(#b001 #b010)))) + (:emitter + (if (fp-reg-tn-p dest) + (progn + (emit-byte segment #b11011101) + (emit-fp-op segment dest #b010)) + (progn + (emit-byte segment #b11011001) + (emit-fp-op segment dest #b010))))) + +;;; +;;; store double from st(0) +;;; +(define-instruction fstd (segment dest) + (:printer floating-point ((op '(#b101 #b010)))) + (:printer floating-point-fp ((op '(#b101 #b010)))) + (:emitter + (if (fp-reg-tn-p dest) + (progn + (emit-byte segment #b11011101) + (emit-fp-op segment dest #b010)) + (progn + (emit-byte segment #b11011101) + (emit-fp-op segment dest #b010))))) + +;;; Arithmetic ops are all done with at least one operand at top of +;;; stack. The other operand is is another register or a 32/64 bit +;;; memory loc. + +;;; dtc: I've tried to follow the Intel ASM386 conventions, but note +;;; that these conflict with the Gdb conventions for binops. To reduce +;;; the confusion I've added comments showing the mathamatical +;;; operation and the two syntaxes. By the ASM386 convention the +;;; instruction syntax is: +;;; +;;; Fop Source +;;; or Fop Destination, Source +;;; +;;; If only one operand is given then it is the source and the +;;; destination is ST(0). There are reversed forms of the fsub and +;;; fdiv instructions inducated by an 'R' suffix. +;;; +;;; The mathematical operation for the non-reverse form is always: +;;; destination = destination op source +;;; +;;; For the reversed form it is: +;;; destination = source op destination +;;; +;;; The instructions below only accept one operand at present which is +;;; usually the source. I've hack in extra instructions to implement +;;; the fops with a ST(i) destination, these have a -sti suffix and +;;; the operand is the destination with the source being ST(0). + +;;; +;;; Add single +;;; st(0) = st(0) + memory or st(i) +;;; +(define-instruction fadd (segment source) + (:printer floating-point ((op '(#b000 #b000)))) + (:emitter + (emit-byte segment #b11011000) + (emit-fp-op segment source #b000))) + +;;; +;;; Add double +;;; st(0) = st(0) + memory or st(i) +;;; +(define-instruction faddd (segment source) + (:printer floating-point ((op '(#b100 #b000)))) + (:printer floating-point-fp ((op '(#b000 #b000)))) + (:emitter + (if (fp-reg-tn-p source) + (emit-byte segment #b11011000) + (emit-byte segment #b11011100)) + (emit-fp-op segment source #b000))) + +;;; +;;; Add double destination st(i) +;;; st(i) = st(0) + st(i) +;;; +(define-instruction fadd-sti (segment destination) + (:printer floating-point-fp ((op '(#b100 #b000)))) + (:emitter + (assert (fp-reg-tn-p destination)) + (emit-byte segment #b11011100) + (emit-fp-op segment destination #b000))) +;;; With pop +(define-instruction faddp-sti (segment destination) + (:printer floating-point-fp ((op '(#b110 #b000)))) + (:emitter + (assert (fp-reg-tn-p destination)) + (emit-byte segment #b11011110) + (emit-fp-op segment destination #b000))) + +;;; +;;; Subtract single +;;; st(0) = st(0) - memory or st(i) +;;; +(define-instruction fsub (segment source) + (:printer floating-point ((op '(#b000 #b100)))) + (:emitter + (emit-byte segment #b11011000) + (emit-fp-op segment source #b100))) + +;;; +;;; Subtract single, reverse +;;; st(0) = memory or st(i) - st(0) +;;; +(define-instruction fsubr (segment source) + (:printer floating-point ((op '(#b000 #b101)))) + (:emitter + (emit-byte segment #b11011000) + (emit-fp-op segment source #b101))) + +;;; +;;; Subtract double +;;; st(0) = st(0) - memory or st(i) +;;; +(define-instruction fsubd (segment source) + (:printer floating-point ((op '(#b100 #b100)))) + (:printer floating-point-fp ((op '(#b000 #b100)))) + (:emitter + (if (fp-reg-tn-p source) + (emit-byte segment #b11011000) + (emit-byte segment #b11011100)) + (emit-fp-op segment source #b100))) + +;;; +;;; Subtract double, reverse +;;; st(0) = memory or st(i) - st(0) +;;; +(define-instruction fsubrd (segment source) + (:printer floating-point ((op '(#b100 #b101)))) + (:printer floating-point-fp ((op '(#b000 #b101)))) + (:emitter + (if (fp-reg-tn-p source) + (emit-byte segment #b11011000) + (emit-byte segment #b11011100)) + (emit-fp-op segment source #b101))) + +;;; +;;; Subtract double, destination st(i) +;;; st(i) = st(i) - st(0) +;;; +;;; ASM386 syntax: FSUB ST(i), ST +;;; Gdb syntax: fsubr %st,%st(i) +;;; +(define-instruction fsub-sti (segment destination) + (:printer floating-point-fp ((op '(#b100 #b101)))) + (:emitter + (assert (fp-reg-tn-p destination)) + (emit-byte segment #b11011100) + (emit-fp-op segment destination #b101))) +;;; With a pop +(define-instruction fsubp-sti (segment destination) + (:printer floating-point-fp ((op '(#b110 #b101)))) + (:emitter + (assert (fp-reg-tn-p destination)) + (emit-byte segment #b11011110) + (emit-fp-op segment destination #b101))) + +;;; +;;; Subtract double, reverse, destination st(i) +;;; st(i) = st(0) - st(i) +;;; +;;; ASM386 syntax: FSUBR ST(i), ST +;;; Gdb syntax: fsub %st,%st(i) +;;; +(define-instruction fsubr-sti (segment destination) + (:printer floating-point-fp ((op '(#b100 #b100)))) + (:emitter + (assert (fp-reg-tn-p destination)) + (emit-byte segment #b11011100) + (emit-fp-op segment destination #b100))) +;;; With a pop +(define-instruction fsubrp-sti (segment destination) + (:printer floating-point-fp ((op '(#b110 #b100)))) + (:emitter + (assert (fp-reg-tn-p destination)) + (emit-byte segment #b11011110) + (emit-fp-op segment destination #b100))) + + +;;; +;;; Multiply single +;;; st(0) = st(0) * memory or st(i) +;;; +(define-instruction fmul (segment source) + (:printer floating-point ((op '(#b000 #b001)))) + (:emitter + (emit-byte segment #b11011000) + (emit-fp-op segment source #b001))) + +;;; +;;; Multiply double +;;; st(0) = st(0) * memory or st(i) +;;; +(define-instruction fmuld (segment source) + (:printer floating-point ((op '(#b100 #b001)))) + (:printer floating-point-fp ((op '(#b000 #b001)))) + (:emitter + (if (fp-reg-tn-p source) + (emit-byte segment #b11011000) + (emit-byte segment #b11011100)) + (emit-fp-op segment source #b001))) + +;;; +;;; Multiply double, destination st(i) +;;; st(i) = st(i) * st(0) +;;; +(define-instruction fmul-sti (segment destination) + (:printer floating-point-fp ((op '(#b100 #b001)))) + (:emitter + (assert (fp-reg-tn-p destination)) + (emit-byte segment #b11011100) + (emit-fp-op segment destination #b001))) + + + +;;; +;;; Divide single +;;; st(0) = st(0) / memory or st(i) +;;; +(define-instruction fdiv (segment source) + (:printer floating-point ((op '(#b000 #b110)))) + (:emitter + (emit-byte segment #b11011000) + (emit-fp-op segment source #b110))) + +;;; +;;; Divide single, reverse +;;; st(0) = memory or st(i) / st(0) +;;; +(define-instruction fdivr (segment source) + (:printer floating-point ((op '(#b000 #b111)))) + (:emitter + (emit-byte segment #b11011000) + (emit-fp-op segment source #b111))) + +;;; +;;; Divide double +;;; st(0) = st(0) / memory or st(i) +;;; +(define-instruction fdivd (segment source) + (:printer floating-point ((op '(#b100 #b110)))) + (:printer floating-point-fp ((op '(#b000 #b110)))) + (:emitter + (if (fp-reg-tn-p source) + (emit-byte segment #b11011000) + (emit-byte segment #b11011100)) + (emit-fp-op segment source #b110))) + +;;; +;;; Divide double, reverse +;;; st(0) = memory or st(i) / st(0) +;;; +(define-instruction fdivrd (segment source) + (:printer floating-point ((op '(#b100 #b111)))) + (:printer floating-point-fp ((op '(#b000 #b111)))) + (:emitter + (if (fp-reg-tn-p source) + (emit-byte segment #b11011000) + (emit-byte segment #b11011100)) + (emit-fp-op segment source #b111))) + +;;; +;;; Divide double, destination st(i) +;;; st(i) = st(i) / st(0) +;;; +;;; ASM386 syntax: FDIV ST(i), ST +;;; Gdb syntax: fdivr %st,%st(i) +;;; +(define-instruction fdiv-sti (segment destination) + (:printer floating-point-fp ((op '(#b100 #b111)))) + (:emitter + (assert (fp-reg-tn-p destination)) + (emit-byte segment #b11011100) + (emit-fp-op segment destination #b111))) + +;;; +;;; Divide double, reverse, destination st(i) +;;; st(i) = st(0) / st(i) +;;; +;;; ASM386 syntax: FDIVR ST(i), ST +;;; Gdb syntax: fdiv %st,%st(i) +;;; +(define-instruction fdivr-sti (segment destination) + (:printer floating-point-fp ((op '(#b100 #b110)))) + (:emitter + (assert (fp-reg-tn-p destination)) + (emit-byte segment #b11011100) + (emit-fp-op segment destination #b110))) + +;;; +;;; exchange fr0 with fr(n). no double variant +;;; +(define-instruction fxch (segment source) + (:printer floating-point-fp ((op '(#b001 #b001)))) + (:emitter + (unless (and (tn-p source) + (eq (sb-name (sc-sb (tn-sc source))) 'float-registers)) + (lisp:break)) + (emit-byte segment #b11011001) + (emit-fp-op segment source #b001))) +;;; +;;; added by pfw +;;; +;;; +;;; push 32-bit integer to st0 +(define-instruction fild(segment source) + (:printer floating-point ((op '(#b011 #b000)))) + (:emitter + (emit-byte segment #b11011011) + (emit-fp-op segment source #b000))) +;;; +;;; store 32-bit integer +;;; +(define-instruction fist (segment dest) + (:printer floating-point ((op '(#b011 #b010)))) + (:emitter + (emit-byte segment #b11011011) + (emit-fp-op segment dest #b010))) + +;;; Store and pop 32-bit interger +(define-instruction fistp (segment dest) + (:printer floating-point ((op '(#b011 #b011)))) + (:emitter + (emit-byte segment #b11011011) + (emit-fp-op segment dest #b011))) +;;; +;;; store single from st(0) and pop +;;; +(define-instruction fstp (segment dest) + (:printer floating-point ((op '(#b001 #b011)))) + (:printer floating-point-fp ((op '(#b101 #b011)))) + (:emitter + (if (fp-reg-tn-p dest) + (progn + (emit-byte segment #b11011101) + (emit-fp-op segment dest #b011)) + (progn + (emit-byte segment #b11011001) + (emit-fp-op segment dest #b011))))) +;;; +;;; decrement stack-top pointer +;;; +(define-instruction fdecstp (segment) + (:printer floating-point-no ((op #b10110))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11110110))) +;;; +;;; increment stack-top pointer +;;; +(define-instruction fincstp (segment) + (:printer floating-point-no ((op #b10111))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11110111))) +;;; +;;; free fp register +;;; +(define-instruction ffree (segment dest) + (:printer floating-point-fp ((op '(#b101 #b000)))) + (:emitter + (emit-byte segment #b11011101) + (emit-fp-op segment dest #b000))) + +(define-instruction fabs (segment) + (:printer floating-point-no ((op #b00001))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11100001))) + +(define-instruction fchs (segment) + (:printer floating-point-no ((op #b00000))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11100000))) + +(define-instruction frndint(segment) + (:printer floating-point-no ((op #b11100))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11111100))) + +;;; +;;; Initialize NPX +;;; +(define-instruction fninit(segment) + (:printer floating-point-5 ((op #b00011))) + (:emitter + (emit-byte segment #b11011011) + (emit-byte segment #b11100011))) + +;;; +;;; Store Status Word to AX +;;; +(define-instruction fnstsw(segment) + (:printer floating-point-st ((op #b00000))) + (:emitter + (emit-byte segment #b11011111) + (emit-byte segment #b11100000))) + +;;; +;;; Load Control Word +;;; +;;; src must be a memory location +(define-instruction fldcw(segment src) + (:printer floating-point ((op '(#b001 #b101)))) + (:emitter + (emit-byte segment #b11011001) + (emit-fp-op segment src #b101))) + +;;; +;;; Store Control Word +;;; +(define-instruction fnstcw(segment dst) + (:printer floating-point ((op '(#b001 #b111)))) + (:emitter + (emit-byte segment #b11011001) + (emit-fp-op segment dst #b111))) +;;; +;;; Store FP Environment +;;; +(define-instruction fstenv(segment dst) + (:printer floating-point ((op '(#b001 #b110)))) + (:emitter + (emit-byte segment #b11011001) + (emit-fp-op segment dst #b110))) +;;; +;;; Retore FP Environment +;;; +(define-instruction fldenv(segment src) + (:printer floating-point ((op '(#b001 #b100)))) + (:emitter + (emit-byte segment #b11011001) + (emit-fp-op segment src #b100))) +;;; +;;; Save FP State +;;; +(define-instruction fsave(segment dst) + (:printer floating-point ((op '(#b101 #b110)))) + (:emitter + (emit-byte segment #b11011101) + (emit-fp-op segment dst #b110))) +;;; +;;; Restore FP State +;;; +(define-instruction frstor(segment src) + (:printer floating-point ((op '(#b101 #b100)))) + (:emitter + (emit-byte segment #b11011101) + (emit-fp-op segment src #b100))) +;;; +;;; Clear exceptions +;;; +(define-instruction fnclex(segment) + (:printer floating-point-5 ((op #b00010))) + (:emitter + (emit-byte segment #b11011011) + (emit-byte segment #b11100010))) + +;;; +;;; Comparison +;;; +(define-instruction fcom(segment src) + (:printer floating-point ((op '(#b000 #b010)))) + (:emitter + (emit-byte segment #b11011000) + (emit-fp-op segment src #b010))) + +(define-instruction fcomd(segment src) + (:printer floating-point ((op '(#b100 #b010)))) + (:printer floating-point-fp ((op '(#b000 #b010)))) + (:emitter + (if (fp-reg-tn-p src) + (emit-byte segment #b11011000) + (emit-byte segment #b11011100)) + (emit-fp-op segment src #b010))) + +;;; +;;; Unordered comparison +;;; +(define-instruction fucom(segment src) + ;; XX Printer conflicts with frstor + ;; (:printer floating-point ((op '(#b101 #b100)))) + (:emitter + (assert (fp-reg-tn-p src)) + (emit-byte segment #b11011101) + (emit-fp-op segment src #b100))) + +(define-instruction ftst (segment) + (:printer floating-point-no ((op #b00100))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11100100))) + +;;; +;;; 80387 Specials +;;; +;;; +(define-instruction fsqrt(segment) + (:printer floating-point-no ((op #b11010))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11111010))) + +(define-instruction fscale(segment) + (:printer floating-point-no ((op #b11101))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11111101))) + +(define-instruction fxtract(segment) + (:printer floating-point-no ((op #b10100))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11110100))) + +(define-instruction fsin(segment) + (:printer floating-point-no ((op #b11110))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11111110))) + +(define-instruction fcos(segment) + (:printer floating-point-no ((op #b11111))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11111111))) + +(define-instruction fprem1(segment) + (:printer floating-point-no ((op #b10101))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11110101))) + +(define-instruction fprem(segment) + (:printer floating-point-no ((op #b11000))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11111000))) + +(define-instruction fxam (segment) + (:printer floating-point-no ((op #b00101))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11100101))) + +;;; These do push/pop to stack and need special handling +;;; in any VOPs that use them. See the book. + +;; st0 <- st1*log2(st0) +(define-instruction fyl2x(segment) ; POPS STACK + (:printer floating-point-no ((op #b10001))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11110001))) + +(define-instruction fyl2xp1(segment) + (:printer floating-point-no ((op #b11001))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11111001))) + +(define-instruction f2xm1(segment) + (:printer floating-point-no ((op #b10000))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11110000))) + +(define-instruction fptan(segment) ; st(0) <- 1; st(1) <- tan + (:printer floating-point-no ((op #b10010))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11110010))) + +(define-instruction fpatan(segment) ; POPS STACK + (:printer floating-point-no ((op #b10011))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11110011))) + +;;; load constant + +(define-instruction fldz(segment) + (:printer floating-point-no ((op #b01110))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11101110))) + +(define-instruction fld1(segment) + (:printer floating-point-no ((op #b01000))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11101000))) + +(define-instruction fldpi(segment) + (:printer floating-point-no ((op #b01011))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11101011))) + +(define-instruction fldl2t(segment) + (:printer floating-point-no ((op #b01001))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11101001))) + +(define-instruction fldl2e(segment) + (:printer floating-point-no ((op #b01010))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11101010))) + +(define-instruction fldlg2(segment) + (:printer floating-point-no ((op #b01100))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11101100))) + +(define-instruction fldln2(segment) + (:printer floating-point-no ((op #b01101))) + (:emitter + (emit-byte segment #b11011001) + (emit-byte segment #b11101101))) diff --git a/compiler/x86/macros.lisp b/compiler/x86/macros.lisp new file mode 100644 index 000000000..314008ba7 --- /dev/null +++ b/compiler/x86/macros.lisp @@ -0,0 +1,305 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/macros.lisp,v 1.1 1997/01/18 14:31:22 ram Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the a bunch of handy macros for the x86. +;;; +;;; Written by William Lott. +;;; +;;; Debugged by Paul F. Werkowski Spring/Summer 1995. +;;; +(in-package :x86) + + +;;; We can load/store into fp registers through the top of +;;; stack %st(0) (fr0 here). Loads imply a push to an empty register +;;; which then changes all the reg numbers. These macros help manage that. + +;;; Use this when don't have to load anything. It preserves old tos value +;;; But probably destroys tn with operation. +(defmacro with-tn@fp-top((tn) &body body) + `(progn + (unless (zerop (tn-offset ,tn)) + (inst fxch ,tn)) + ,@body + (unless (zerop (tn-offset ,tn)) + (inst fxch ,tn)))) + +;;; Use this to prepare for load of new value. +(defmacro with-empty-tn@fp-top((tn) &body body) + `(progn + (inst fstp ,tn) + ,@body + (unless (zerop (tn-offset ,tn)) + (inst fxch ,tn)))) ; save into new dest and restore st(0) + + +;;; Instruction-like macros. +(defmacro move (dst src) + "Move SRC into DST unless they are location=." + (once-only ((n-dst dst) + (n-src src)) + `(unless (location= ,n-dst ,n-src) + (inst mov ,n-dst ,n-src)))) + +(defmacro make-ea-for-object-slot (ptr slot lowtag) + `(make-ea :dword :base ,ptr :disp (- (* ,slot word-bytes) ,lowtag))) + +(defmacro loadw (value ptr &optional (slot 0) (lowtag 0)) + `(inst mov ,value (make-ea-for-object-slot ,ptr ,slot ,lowtag))) + +(defmacro storew (value ptr &optional (slot 0) (lowtag 0)) + (once-only ((value value)) + `(inst mov (make-ea-for-object-slot ,ptr ,slot ,lowtag) ,value))) + +(defmacro pushw (ptr &optional (slot 0) (lowtag 0)) + `(inst push (make-ea-for-object-slot ,ptr ,slot ,lowtag))) + +(defmacro popw (ptr &optional (slot 0) (lowtag 0)) + `(inst pop (make-ea-for-object-slot ,ptr ,slot ,lowtag))) + + +;;;; Macros to generate useful values. + +(defmacro load-symbol (reg symbol) + `(inst mov ,reg (+ nil-value (static-symbol-offset ,symbol)))) + +(defmacro load-symbol-value (reg symbol) + `(inst mov ,reg + (make-ea :dword + :disp (+ nil-value + (static-symbol-offset ',symbol) + (ash symbol-value-slot word-shift) + (- other-pointer-type))))) + +(defmacro store-symbol-value (reg symbol) + `(inst mov + (make-ea :dword + :disp (+ nil-value + (static-symbol-offset ',symbol) + (ash symbol-value-slot word-shift) + (- other-pointer-type))) + ,reg)) + + +(defmacro load-type (target source &optional (offset 0)) + "Loads the type bits of a pointer into target independent of + byte-ordering issues." + (once-only ((n-target target) + (n-source source) + (n-offset offset)) + (ecase (backend-byte-order *target-backend*) + (:little-endian + `(inst mov ,n-target + (make-ea :byte :base ,n-source :disp ,n-offset))) + (:big-endian + `(inst mov ,n-target + (make-ea :byte :base ,n-source :disp (+ ,n-offset 3))))))) + + +;;;; Allocation helpers + +#-cgc +(defmacro with-allocation ((alloc) &body body) + `(progn + (load-symbol-value ,alloc lisp::*allocation-pointer*) + ,@body + (store-symbol-value ,alloc lisp::*allocation-pointer*) + )) + +#-cgc +(defmacro with-fixed-allocation ((result alloc type-code size) &body body) + `(with-allocation (,alloc) + (inst lea ,result + (make-ea :byte :base ,alloc :disp other-pointer-type)) + (storew (logior (ash (1- ,size) vm:type-bits) ,type-code) ,alloc) + (inst add ,alloc (pad-data-block ,size)) + ,@body)) + +;;; Support for conservative GC and allocator. Call into C... +#+cgc +(defmacro with-cgc-allocation((alloc-tn size) &body body) + `(let ((stack-offset (- 28 (* 2 (tn-offset ,alloc-tn))))) + ;; I need to save all regs because C might trash a few. + ;; This works because register offsets are assigned in the + ;; same order that PUSHA pushes them on the stack. + (inst pusha) ; Save all registers + (inst push ,size) ; load the size param for C + (inst call (make-fixup (extern-alien-name "alloc") :foreign)) + (inst add esp-tn word-bytes) ; pop off the arg + (inst mov (make-ea :dword ; move result over saved alloc-tn + :base esp-tn :disp stack-offset) eax-tn) + (inst popa) ; restore all regs + ,@body)) + +#+cgc +(defmacro with-fixed-allocation ((result alloc type-code size) &body body) + `(with-cgc-allocation (,alloc (pad-data-block ,size)) + (inst lea ,result (make-ea :byte :base ,alloc :disp other-pointer-type)) + (storew (logior (ash (1- ,size) vm:type-bits) ,type-code) ,alloc) + ,@body)) + + + + +;;;; Error Code + +(defvar *adjustable-vectors* nil) + +(defmacro with-adjustable-vector ((var) &rest body) + `(let ((,var (or (pop *adjustable-vectors*) + (make-array 16 + :element-type '(unsigned-byte 8) + :fill-pointer 0 + :adjustable t)))) + (setf (fill-pointer ,var) 0) + (unwind-protect + (progn + ,@body) + (push ,var *adjustable-vectors*)))) + +(eval-when (compile load eval) + (defun emit-error-break (vop kind code values) + (let ((vector (gensym))) + `((inst int 3) ; i386 breakpoint instruction + ;; The return PC points here; note the location for the debugger. + (let ((vop ,vop)) + (when vop + (note-this-location vop :internal-error))) + (inst byte ,kind) ; eg trap_Xyyy + (with-adjustable-vector (,vector) ; interr arguments + (write-var-integer (error-number-or-lose ',code) ,vector) + ,@(mapcar #'(lambda (tn) + `(let ((tn ,tn)) + (write-var-integer + (make-sc-offset (sc-number + (tn-sc tn)) + ;; zzzzz jrd here. tn-offset + ;; is zero for constant tns. + ;; (tn-offset tn) + (or (tn-offset tn) 0) + ) + ,vector))) + values) + (inst byte (length ,vector)) + (dotimes (i (length ,vector)) + (inst byte (aref ,vector i)))))))) + +(defmacro error-call (vop error-code &rest values) + "Cause an error. ERROR-CODE is the error to cause." + (cons 'progn + (emit-error-break vop error-trap error-code values))) + + +(defmacro cerror-call (vop label error-code &rest values) + "Cause a continuable error. If the error is continued, execution resumes at + LABEL." + `(progn + ,@(emit-error-break vop cerror-trap error-code values) + (inst jmp ,label))) + +(defmacro generate-error-code (vop error-code &rest values) + "Generate-Error-Code Error-code Value* + Emit code for an error with the specified Error-Code and context Values." + `(assemble (*elsewhere*) + (let ((start-lab (gen-label))) + (emit-label start-lab) + (error-call ,vop ,error-code ,@values) + start-lab))) + +(defmacro generate-cerror-code (vop error-code &rest values) + "Generate-CError-Code Error-code Value* + Emit code for a continuable error with the specified Error-Code and + context Values. If the error is continued, execution resumes after + the GENERATE-CERROR-CODE form." + (let ((continue (gensym "CONTINUE-LABEL-")) + (error (gensym "ERROR-LABEL-"))) + `(let ((,continue (gen-label)) + (,error (gen-label))) + (emit-label ,continue) + (assemble (*elsewhere*) + (emit-label ,error) + (cerror-call ,vop ,continue ,error-code ,@values)) + ,error))) + + + +;;;; Indexed references: + +(defmacro define-full-reffer (name type offset lowtag scs el-type &optional translate) + `(progn + (define-vop (,name) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types ,type tagged-num) + (:results (value :scs ,scs)) + (:result-types ,el-type) + (:generator 3 ; pw was 5 + (inst mov + value + (make-ea :dword :base object :index index + :disp (- (* ,offset word-bytes) ,lowtag))))) + (define-vop (,(symbolicate name "-C")) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:info index) + (:arg-types ,type (:constant (signed-byte 30))) + (:results (value :scs ,scs)) + (:result-types ,el-type) + (:generator 2 ; pw was 5 + (inst mov + value + (make-ea :dword :base object + :disp (- (* (+ ,offset index) word-bytes) + ,lowtag))))))) + +(defmacro define-full-setter (name type offset lowtag scs el-type &optional translate) + `(progn + (define-vop (,name) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs ,scs :target result)) + (:arg-types ,type tagged-num ,el-type) + (:results (result :scs ,scs)) + (:result-types ,el-type) + (:generator 4 ; was 5 + (inst mov + (make-ea :dword :base object :index index + :disp (- (* ,offset word-bytes) ,lowtag)) + value) + (move result value))) + (define-vop (,(symbolicate name "-C")) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (value :scs ,scs :target result)) + (:info index) + (:arg-types ,type (:constant (signed-byte 30)) ,el-type) + (:results (result :scs ,scs)) + (:result-types ,el-type) + (:generator 3 ; was 5 + (inst mov + (make-ea :dword :base object + :disp (- (* (+ ,offset index) word-bytes) + ,lowtag)) + value) + (move result value))))) + diff --git a/compiler/x86/memory.lisp b/compiler/x86/memory.lisp new file mode 100644 index 000000000..0050b6bb4 --- /dev/null +++ b/compiler/x86/memory.lisp @@ -0,0 +1,109 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/memory.lisp,v 1.1 1997/01/18 14:31:21 ram Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the x86 definitions of some general purpose memory +;;; reference VOPs inherited by basic memory reference operations. +;;; +;;; Written by William Lott. +;;; +;;; Debugged by Paul F. Werkowski Spring/Summer 1995. +;;; + +(in-package :x86) + +;;; Cell-Ref and Cell-Set are used to define VOPs like CAR, where the offset to +;;; be read or written is a property of the VOP used. Cell-Setf is similar to +;;; Cell-Set, but delivers the new value as the result. Cell-Setf-Function +;;; takes its arguments as if it were a setf function (new value first, as +;;; apposed to a setf macro, which takes the new value last). +;;; +(define-vop (cell-ref) + (:args (object :scs (descriptor-reg))) + (:results (value :scs (descriptor-reg any-reg))) + (:variant-vars offset lowtag) + (:policy :fast-safe) + (:generator 4 + (loadw value object offset lowtag))) +;;; +(define-vop (cell-set) + (:args (object :scs (descriptor-reg)) + (value :scs (descriptor-reg any-reg))) + (:variant-vars offset lowtag) + (:policy :fast-safe) + (:generator 4 + (storew value object offset lowtag))) +;;; +(define-vop (cell-setf) + (:args (object :scs (descriptor-reg)) + (value :scs (descriptor-reg any-reg) + :target result)) + (:results (result :scs (descriptor-reg any-reg + descriptor-stack immediate-stack))) + (:variant-vars offset lowtag) + (:policy :fast-safe) + (:generator 4 + (storew value object offset lowtag) + (move result value))) +;;; +(define-vop (cell-setf-function) + (:args (value :scs (descriptor-reg any-reg) + :target result) + (object :scs (descriptor-reg))) + (:results (result :scs (descriptor-reg any-reg + descriptor-stack immediate-stack))) + (:variant-vars offset lowtag) + (:policy :fast-safe) + (:generator 4 + (storew value object offset lowtag) + (move result value))) + +;;; Define-Cell-Accessors -- Interface +;;; +;;; Define accessor VOPs for some cells in an object. If the operation name +;;; is NIL, then that operation isn't defined. If the translate function is +;;; null, then we don't define a translation. +;;; +(defmacro define-cell-accessors (offset lowtag + ref-op ref-trans set-op set-trans) + `(progn + ,@(when ref-op + `((define-vop (,ref-op cell-ref) + (:variant ,offset ,lowtag) + ,@(when ref-trans + `((:translate ,ref-trans)))))) + ,@(when set-op + `((define-vop (,set-op cell-setf) + (:variant ,offset ,lowtag) + ,@(when set-trans + `((:translate ,set-trans)))))))) + + +;;; Slot-Ref and Slot-Set are used to define VOPs like Closure-Ref, where the +;;; offset is constant at compile time, but varies for different uses. +;;; +(define-vop (slot-ref) + (:args (object :scs (descriptor-reg))) + (:results (value :scs (descriptor-reg any-reg))) + (:variant-vars base lowtag) + (:info offset) + (:generator 4 + (loadw value object (+ base offset) lowtag))) +;;; +(define-vop (slot-set) + (:args (object :scs (descriptor-reg)) + (value :scs (descriptor-reg any-reg))) + (:variant-vars base lowtag) + (:info offset) + (:generator 4 + (storew value object (+ base offset) lowtag))) + diff --git a/compiler/x86/move.lisp b/compiler/x86/move.lisp new file mode 100644 index 000000000..2a70fc15f --- /dev/null +++ b/compiler/x86/move.lisp @@ -0,0 +1,472 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/move.lisp,v 1.1 1997/01/18 14:31:21 ram Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the x86 VM definition of operand loading/saving and +;;; the Move VOP. +;;; +;;; Written by William Lott. +;;; +;;; Debugged by Paul F. Werkowski Spring/Summer 1995. +;;; +(in-package :x86) + +(define-move-function (load-immediate 1) (vop x y) + ((immediate) + (any-reg descriptor-reg)) + (let ((val (tn-value x))) + (etypecase val + (integer + (if (zerop val) + (inst xor y y) + (inst mov y (fixnum val)))) + (symbol + (load-symbol y val)) + (character + (inst mov y (logior (ash (char-code val) type-bits) + base-char-type)))))) + +(define-move-function (load-number 1) (vop x y) + ((immediate) (signed-reg unsigned-reg)) + (inst mov y (tn-value x))) + +(define-move-function (load-base-char 1) (vop x y) + ((immediate) (base-char-reg)) + (inst mov y (char-code (tn-value x)))) + +(define-move-function (load-system-area-pointer 1) (vop x y) + ((immediate) (sap-reg)) + (inst mov y (sap-int (tn-value x)))) + +#+nil ;; original +(define-move-function (load-constant 5) (vop x y) + ((constant) (descriptor-reg)) + (inst mov y x)) + +(define-move-function (load-constant 5) (vop x y) + ;; pfw adds any-reg to no effect + ((constant) (descriptor-reg any-reg)) + (inst mov y x)) + +#+nil ;; not sure this will work -- need test case +(define-move-function (load-constant 5) (vop x y) + ((constant) (descriptor-reg any-reg)) + (inst mov y (make-fixup nil :code-object (tn-offset x)))) + +(define-move-function (load-stack 5) (vop x y) + ((descriptor-stack) (descriptor-reg) + (immediate-stack) (any-reg) + (base-char-stack) (base-char-reg) + (sap-stack) (sap-reg) + (signed-stack) (signed-reg) + (unsigned-stack) (unsigned-reg)) + (inst mov y x)) + +(define-move-function (store-stack 5) (vop x y) + ((descriptor-reg) (descriptor-stack) + (any-reg) (immediate-stack) + (base-char-reg) (base-char-stack) + (sap-reg) (sap-stack) + (signed-reg) (signed-stack) + (unsigned-reg) (unsigned-stack)) + (inst mov y x)) + +;;; +;;; ZZZZZ added by jrd. add a move-function for immediate-stack -> descriptor-reg. +;;; dunno if this is right, but we get into the pickle of trying to do this kind of +;;; move a fair amount. see if this fixes it +;;; +(define-move-function (load-immediate-stack 5) (vop x y) + ((immediate-stack) (descriptor-reg)) + (inst mov x y)) + +(define-move-function (store-immediate-stack 5) (vop x y) + ((descriptor-reg) (immediate-stack)) + (inst mov x y)) + +;;; zzzzz seem to need this one for the verify-argument-count vop??? +;(define-move-function (move-unsigned-to-any 5) (vop x y) +; ((unsigned-reg) (any-reg)) +; (inst mov y x) +; (inst shl y 2)) + + + +;;;; The Move VOP: +;;; +(define-vop (move) + (:args (x :target y + :scs (any-reg immediate-stack descriptor-reg descriptor-stack + immediate) + :load-if (not (location= x y)))) + (:results (y :scs (any-reg descriptor-reg) + :load-if + (not (or (location= x y) + (and (sc-is x any-reg descriptor-reg immediate) + (sc-is y immediate-stack descriptor-stack)))))) + (:effects) + (:affected) + (:generator 0 + (if (and (sc-is x immediate) + (sc-is y any-reg immediate-stack descriptor-reg descriptor-stack)) + (let ((val (tn-value x))) + (etypecase val + (integer + (if (and (zerop val) (sc-is y any-reg descriptor-reg)) + (inst xor y y) + (inst mov y (fixnum val)))) + (symbol + (inst mov y (+ nil-value (static-symbol-offset val)))) + (character + (inst mov y (logior (ash (char-code val) type-bits) + base-char-type))))) + (move y x)))) + +(define-move-vop move :move + (any-reg immediate-stack descriptor-reg descriptor-stack immediate) + (any-reg descriptor-reg)) + + +;;; Make Move the check VOP for T so that type check generation doesn't think +;;; it is a hairy type. This also allows checking of a few of the values in a +;;; continuation to fall out. +;;; +(primitive-type-vop move (:check) t) + +;;; The Move-Argument VOP is used for moving descriptor values into another +;;; frame for argument or known value passing. +;;; +;;; Note: It is not going to be possible to move a constant directly +;;; to another frame, except if the destination is a register and in +;;; this case the loading works out. +(define-vop (move-argument) + (:args (x :target y + :scs (any-reg descriptor-reg immediate) + :load-if (not (and (sc-is y any-reg descriptor-reg) + (sc-is x immediate-stack)))) + (fp :scs (any-reg) + :load-if (not (sc-is y any-reg descriptor-reg)))) + (:results (y)) + (:generator 0 + (sc-case y + ((any-reg descriptor-reg) + (if (sc-is x immediate) + (let ((val (tn-value x))) + (etypecase val + (integer + (if (zerop val) + (inst xor y y) + (inst mov y (fixnum val)))) + (symbol + (load-symbol y val)) + (character + (inst mov y (logior (ash (char-code val) type-bits) + base-char-type))))) + (move y x))) + ((descriptor-stack immediate-stack) + (if (sc-is x immediate) + (let ((val (tn-value x))) + (if (= (tn-offset fp) esp-offset) + ;; C-call + (etypecase val + (integer + (storew (fixnum val) fp (tn-offset y))) + (symbol + (storew (+ nil-value (static-symbol-offset val)) + fp (tn-offset y))) + (character + (storew (logior (ash (char-code val) type-bits) + base-char-type) + fp (tn-offset y)))) + ;; Lisp stack + (etypecase val + (integer + (storew (fixnum val) fp (- (1+ (tn-offset y))))) + (symbol + (storew (+ nil-value (static-symbol-offset val)) + fp (- (1+ (tn-offset y))))) + (character + (storew (logior (ash (char-code val) type-bits) + base-char-type) + fp (- (1+ (tn-offset y)))))))) + (if (= (tn-offset fp) esp-offset) + ;; C-call + (storew x fp (tn-offset y)) + ;; Lisp stack + (storew x fp (- (1+ (tn-offset y)))))))))) + +;;; +(define-move-vop move-argument :move-argument + (any-reg descriptor-reg) + (any-reg descriptor-reg)) + + + +;;;; ILLEGAL-MOVE + +;;; This VOP exists just to begin the lifetime of a TN that couldn't be written +;;; legally due to a type error. An error is signalled before this VOP is +;;; so we don't need to do anything (not that there would be anything sensible +;;; to do anyway.) +;;; +(define-vop (illegal-move) + (:args (x) (type)) + (:results (y)) + (:ignore y) + (:vop-var vop) + (:save-p :compute-only) + (:generator 666 + (error-call vop object-not-type-error x type))) + + + +;;;; Moves and coercions: + +;;; These MOVE-TO-WORD VOPs move a tagged integer to a raw full-word +;;; representation. Similarly, the MOVE-FROM-WORD VOPs converts a raw integer +;;; to a tagged bignum or fixnum. + +;;; Arg is a fixnum, so just shift it. We need a type restriction because some +;;; possible arg SCs (control-stack) overlap with possible bignum arg SCs. +;;; +(define-vop (move-to-word/fixnum) + (:args (x :scs (any-reg immediate-stack descriptor-reg descriptor-stack))) + (:results (y :scs (signed-reg unsigned-reg))) + (:arg-types tagged-num) + (:note "fixnum untagging") + (:generator 1 + (move y x) + (inst sar y 2))) +;;; +(define-move-vop move-to-word/fixnum :move + (any-reg descriptor-reg) (signed-reg unsigned-reg)) + +;;; Arg is a non-immediate constant, load it. +(define-vop (move-to-word-c) + (:args (x :scs (constant))) + (:results (y :scs (signed-reg unsigned-reg))) + (:note "constant load") + (:generator 1 + (inst mov y (tn-value x)))) +;;; +(define-move-vop move-to-word-c :move + (constant) (signed-reg unsigned-reg)) + + +;;; Arg is a fixnum or bignum, figure out which and load if necessary. +(define-vop (move-to-word/integer) + (:args (x :scs (descriptor-reg) :target eax)) + (:results (y :scs (signed-reg unsigned-reg))) + (:note "integer to untagged word coercion") + (:temporary (:sc dword-reg :offset eax-offset + :from (:argument 0) + :to (:result 0) :target y) eax) + (:generator 4 + (move eax x) + (inst test al-tn 3) + (inst jmp :z fixnum) + (loadw y eax bignum-digits-offset other-pointer-type) + (inst jmp done) + FIXNUM + (inst sar eax 2) + (move y eax) + DONE)) +;;; +(define-move-vop move-to-word/integer :move + (descriptor-reg) (signed-reg unsigned-reg)) + + +;;; Result is a fixnum, so we can just shift. We need the result type +;;; restriction because of the control-stack ambiguity noted above. +;;; +(define-vop (move-from-word/fixnum) + (:args (x :scs (signed-reg signed-stack unsigned-reg unsigned-stack))) + (:results (y :scs (any-reg descriptor-reg))) + (:result-types tagged-num) + (:note "fixnum tagging") + (:generator 1 + (if (and (sc-is x signed-reg unsigned-reg) + (not (location= x y))) + ;; Uses 7 bytes, but faster on the Pentium + (inst lea y (make-ea :dword :index x :scale 4)) + (progn + ;; Uses: If x is a reg 2 + 3; if x = y uses only 3 bytes + (move y x) + (inst shl y 2))))) +;;; +(define-move-vop move-from-word/fixnum :move + (signed-reg unsigned-reg) (any-reg descriptor-reg)) + +;;; Result may be a bignum, so we have to check. Use a worst-case cost to make +;;; sure people know they may be number consing. +;;; +(define-vop (move-from-signed) + (:args (x :scs (signed-reg unsigned-reg) :target eax)) + (:temporary (:sc dword-reg :offset eax-offset :from (:argument 0)) eax) + (:temporary (:sc dword-reg :offset ebx-offset :to (:result 0) :target y) + ebx) + (:temporary (:sc dword-reg :offset ecx-offset + :from (:argument 0) :to (:result 0)) + ecx) + (:ignore ecx) + (:results (y :scs (any-reg descriptor-reg))) + (:note "signed word to integer coercion") + (:generator 20 + (move eax x) + (inst call (make-fixup 'move-from-signed :assembly-routine)) + (move y ebx))) + +#+notyet ;; new from dtc -- need to test +(define-vop (move-from-signed) + (:args (x :scs (signed-reg unsigned-reg) :to :save)) + (:temporary (:sc dword-reg) alloc) + (:results (y :scs (any-reg descriptor-reg))) + (:note "signed word to integer coercion") + (:generator 20 + (assert (not (location= x y))) + (assert (not (location= x alloc))) + (assert (not (location= y alloc))) + (let ( (bignum (gen-label)) + (done (gen-label)) ) + (inst mov y x) + (inst shl y 1) + (inst jmp :o bignum) + (inst shl y 1) + (inst jmp :o bignum) + (emit-label done) + + (assemble (*elsewhere*) + (emit-label bignum) + (with-fixed-allocation (y alloc bignum-type + (+ bignum-digits-offset 1)) + (storew x y bignum-digits-offset other-pointer-type)) + (inst jmp done))))) +;;; +(define-move-vop move-from-signed :move + (signed-reg) (descriptor-reg)) + + +;;; Check for fixnum, and possibly allocate one or two word bignum result. Use +;;; a worst-case cost to make sure people know they may be number consing. +;;; + +(define-vop (move-from-unsigned) + (:args (x :scs (signed-reg unsigned-reg) :target eax)) + (:temporary (:sc dword-reg :offset eax-offset :from (:argument 0)) eax) + (:temporary (:sc dword-reg :offset ebx-offset :to (:result 0) :target y) + ebx) + (:temporary (:sc dword-reg :offset ecx-offset + :from (:argument 0) :to (:result 0)) + ecx) + (:ignore ecx) + (:results (y :scs (any-reg descriptor-reg))) + (:note "unsigned word to integer coercion") + (:generator 20 + (move eax x) + (inst call (make-fixup 'move-from-unsigned :assembly-routine)) + (move y ebx))) + +#+notyet ;; from dtc -- need to test this +(define-vop (move-from-unsigned) + (:args (x :scs (signed-reg unsigned-reg) :to :save)) + (:temporary (:sc dword-reg) alloc) + (:results (y :scs (any-reg descriptor-reg))) + (:note "unsigned word to integer coercion") + (:generator 20 + (assert (not (location= x y))) + (assert (not (location= x alloc))) + (assert (not (location= y alloc))) + (let ( (bignum (gen-label)) + (done (gen-label)) + (one-word-bignum (gen-label)) + (l1 (gen-label)) ) + (inst test x #xe0000000) + (inst jmp :nz bignum) + ;; Fixnum. + (inst lea y (make-ea :dword :index x :scale 4)) ; Faster but bigger. + ;(inst mov y x) + ;(inst shl y 2) + (emit-label done) + + (assemble (*elsewhere*) + (emit-label bignum) + ;; Note: As on the mips port, space for a two word bignum is + ;; always allocated and the header size is set to either one + ;; or two words as appropriate. + (inst jmp :ns one-word-bignum) + ;; Two word bignum. + (inst mov y (logior (ash (1- (+ bignum-digits-offset 2)) vm:type-bits) + bignum-type)) + (inst jmp l1) + (emit-label one-word-bignum) + (inst mov y (logior (ash (1- (+ bignum-digits-offset 1)) vm:type-bits) + bignum-type)) + (emit-label l1) + (with-cgc-allocation + (alloc (pad-data-block (+ bignum-digits-offset 2))) + (storew y alloc) + (inst lea y (make-ea :byte :base alloc :disp other-pointer-type))) + (storew x y bignum-digits-offset other-pointer-type) + (inst jmp done))))) +;;; +(define-move-vop move-from-unsigned :move + (unsigned-reg) (descriptor-reg)) + + +;;; Move untagged numbers. +;;; +(define-vop (word-move) + (:args (x :target y + :scs (signed-reg unsigned-reg signed-stack unsigned-stack) + :load-if (not (location= x y)))) + (:results (y :scs (signed-reg unsigned-reg) + :load-if + (not (or (location= x y) + (and (sc-is x signed-reg unsigned-reg) + (sc-is y signed-stack unsigned-stack)))))) + (:effects) + (:affected) + (:note "word integer move") + (:generator 0 + (move y x))) +;;; +(define-move-vop word-move :move + (signed-reg unsigned-reg) (signed-reg unsigned-reg)) + +;;; Move untagged number arguments/return-values. +;;; +(define-vop (move-word-argument) + (:args (x :target y + :scs (signed-reg unsigned-reg)) + (fp :scs (any-reg) + :load-if (not (sc-is y sap-reg)))) + (:results (y)) + (:note "word integer argument move") + (:generator 0 + (sc-case y + ((signed-reg unsigned-reg) + (move y x)) + ((signed-stack unsigned-stack) + (if (= (tn-offset fp) esp-offset) + (storew x fp (tn-offset y)) ; c-call + (storew x fp (- (1+ (tn-offset y))))))))) + +;;; +(define-move-vop move-word-argument :move-argument + (descriptor-reg any-reg signed-reg unsigned-reg) (signed-reg unsigned-reg)) + + +;;; Use standard MOVE-ARGUMENT + coercion to move an untagged number to a +;;; descriptor passing location. +;;; +(define-move-vop move-argument :move-argument + (signed-reg unsigned-reg) (any-reg descriptor-reg)) diff --git a/compiler/x86/nlx.lisp b/compiler/x86/nlx.lisp new file mode 100644 index 000000000..6cde54f1d --- /dev/null +++ b/compiler/x86/nlx.lisp @@ -0,0 +1,412 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/nlx.lisp,v 1.1 1997/01/18 14:31:22 ram Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the VM definition of non-local exit for the x86. +;;; +;;; Written by William Lott. +;;; +;;; Debugged by Paul F. Werkowski Spring/Summer 1995. +;;; +(in-package :x86) + +;;; MAKE-NLX-SP-TN -- Interface +;;; +;;; Make an environment-live stack TN for saving the SP for NLX entry. +;;; +(def-vm-support-routine make-nlx-sp-tn (env) + (environment-live-tn + (make-representation-tn *fixnum-primitive-type* any-reg-sc-number) + env)) + +(defun catch-block-ea (tn) + (assert (sc-is tn catch-block)) + (make-ea :dword :base ebp-tn + :disp (- (* (+ (tn-offset tn) catch-block-size) word-bytes)))) + + +;;; Save and restore dynamic environment. +;;; +;;; These VOPs are used in the reentered function to restore the appropriate +;;; dynamic environment. Currently we only save the Current-Catch and eval +;;; stack pointer. We don't need to save/restore the current unwind-protect, +;;; since unwind-protects are implicitly processed during unwinding. +;;; +;;; We don't need to save the BSP, because that is handled automatically. + +;;; Make-Dynamic-State-TNs -- Interface +;;; +;;; Return a list of TNs that can be used to snapshot the dynamic state for +;;; use with the Save/Restore-Dynamic-Environment VOPs. +;;; +(def-vm-support-routine make-dynamic-state-tns () + #+nil + (make-n-tns 2 *any-primitive-type*) + (make-n-tns 3 *any-primitive-type*)) + +(define-vop (save-dynamic-state) + (:results (catch :scs (descriptor-reg)) + (eval :scs (descriptor-reg)) + (oldfp :scs (descriptor-reg))) ; pw adds this + (:vop-var vop) + (:generator 13 + (load-symbol-value catch lisp::*current-catch-block*) + (load-symbol-value eval lisp::*eval-stack-top*) + (loadw oldfp ebp-tn (- (1+ old-fp-save-offset))))) + + +(define-vop (restore-dynamic-state) + (:args (catch :scs (descriptor-reg)) + (eval :scs (descriptor-reg)) + (oldfp :scs (descriptor-reg))) + (:vop-var vop) + (:generator 10 + (store-symbol-value catch lisp::*current-catch-block*) + (store-symbol-value eval lisp::*eval-stack-top*) + (storew oldfp ebp-tn (- (1+ old-fp-save-offset))))) + +(define-vop (current-stack-pointer) + (:results (res :scs (any-reg immediate-stack))) + (:generator 1 + (move res esp-tn))) + +(define-vop (current-binding-pointer) + (:results (res :scs (any-reg descriptor-reg))) + (:generator 1 + (load-symbol-value res lisp::*binding-stack-pointer*))) + + +;;;; Unwind block hackery: + +;;; Compute the address of the catch block from its TN, then store into the +;;; block the current Fp, Env, Unwind-Protect, and the entry PC. + +(define-vop (make-unwind-block) + (:args (tn)) + (:info entry-label) + (:temporary (:sc dword-reg) temp) + (:results (block :scs (any-reg))) + (:generator 22 + (inst lea block (catch-block-ea tn)) + (load-symbol-value temp lisp::*current-unwind-protect-block*) + (storew temp block unwind-block-current-uwp-slot) + (storew ebp-tn block unwind-block-current-cont-slot) + (inst lea temp (make-fixup nil :code-object entry-label)) + (storew temp block catch-block-entry-pc-slot))) + +;;; Like Make-Unwind-Block, except that we also store in the specified tag, and +;;; link the block into the Current-Catch list. +;;; + +(define-vop (make-catch-block) + (:args (tn) + (tag :scs (descriptor-reg) :to (:result 1))) + (:info entry-label) + (:results (block :scs (any-reg))) + (:temporary (:sc descriptor-reg) temp) + (:generator 44 + (inst lea block (catch-block-ea tn)) + (load-symbol-value temp lisp::*current-unwind-protect-block*) + (storew temp block unwind-block-current-uwp-slot) + (storew ebp-tn block unwind-block-current-cont-slot) + (inst lea temp (make-fixup nil :code-object entry-label)) + (storew temp block catch-block-entry-pc-slot) + (storew tag block catch-block-tag-slot) + (load-symbol-value temp lisp::*current-catch-block*) + (storew temp block catch-block-previous-catch-slot) + (store-symbol-value block lisp::*current-catch-block*))) + +;;; Just set the current unwind-protect to TN's address. This instantiates an +;;; unwind block as an unwind-protect. +;;; +(define-vop (set-unwind-protect) + (:args (tn)) + (:temporary (:sc dword-reg) new-uwp) + (:generator 7 + (inst lea new-uwp (catch-block-ea tn)) + (store-symbol-value new-uwp lisp::*current-unwind-protect-block*))) + +(define-vop (unlink-catch-block) + (:temporary (:sc dword-reg) block) + (:policy :fast-safe) + (:translate %catch-breakup) + (:generator 17 + (load-symbol-value block lisp::*current-catch-block*) + (loadw block block catch-block-previous-catch-slot) + (store-symbol-value block lisp::*current-catch-block*))) + +(define-vop (unlink-unwind-protect) + (:temporary (:sc dword-reg) block) + (:policy :fast-safe) + (:translate %unwind-protect-breakup) + (:generator 17 + (load-symbol-value block lisp::*current-unwind-protect-block*) + (loadw block block unwind-block-current-uwp-slot) + (store-symbol-value block lisp::*current-unwind-protect-block*))) + + +;;;; NLX entry VOPs: +#+nil ;; this is bogus? +(define-vop (nlx-entry) + (:args (sp) ; Note: we can't list an sc-restriction, 'cause any load vops + ; would be inserted before the return-pc label. + (start) + (count)) + (:results (values :more t)) + (:temporary (:sc descriptor-reg) nil-temp move-temp) + (:info label nvals) + (:save-p :force-to-stack) + (:vop-var vop) + (:generator 30 + (emit-label label) + (note-this-location vop :non-local-entry) + (cond ((zerop nvals)) + ((= nvals 1) + (let ((no-values (gen-label))) + ;; (move (tn-ref-tn values) nil-value) -- jrd + (inst mov (tn-ref-tn values) nil-value) + + (inst jecxz no-values) + + ;; jrd rewrote this piece. because we can't issue an sc-restriction, + ;; as above, we generate a bogus EA here (see the expansion of LOADW) + ;; and croak. Do the move by hand. + ;; (loadw (tn-ref-tn values) start -1) + (inst mov move-temp start) + (loadw (tn-ref-tn values) move-temp -1) + + (emit-label no-values))) + (t + (collect ((defaults)) + (inst mov nil-temp nil-value) + (do ((i 0 (1+ i)) + (tn-ref values (tn-ref-across tn-ref))) + ((null tn-ref)) + (let ((default-lab (gen-label)) + (tn (tn-ref-tn tn-ref))) + (defaults (cons default-lab tn)) + + (inst cmp count (fixnum i)) + (inst jmp :le default-lab) + (sc-case tn + ((descriptor-reg any-reg) + ;; see above -- jrd + ;; (loadw tn start (- (1+ i))) + (inst mov move-temp start) + (loadw tn move-temp (- (1+ i)))) + ((descriptor-stack immediate-stack) + ;; (loadw move-temp start (- (1+ i))) + (inst mov move-temp start) + (loadw move-temp move-temp (- (1+ i))) + (move tn move-temp))))) + (let ((defaulting-done (gen-label))) + (emit-label defaulting-done) + (assemble (*elsewhere*) + (dolist (def (defaults)) + (emit-label (car def)) + (move (cdr def) nil-temp)) + (inst jmp defaulting-done)))))) + (inst mov esp-tn sp))) + +;;; see comments below regarding start arg to nlx-entry-multiple +(define-vop (nlx-entry) + (:args (sp) ; Note: we can't list an sc-restriction, 'cause any load vops + ; would be inserted before the return-pc label. + (start) + (count)) + (:results (values :more t)) + (:temporary (:sc descriptor-reg) nil-temp move-temp) + (:info label nvals) + (:save-p :force-to-stack) + (:vop-var vop) + (:generator 30 + (emit-label label) + (note-this-location vop :non-local-entry) + (cond ((zerop nvals)) + ((= nvals 1) + (let ((no-values (gen-label))) + ;; (move (tn-ref-tn values) nil-value) -- jrd + (inst mov (tn-ref-tn values) nil-value) + + (inst jecxz no-values) + + (move move-temp start) + (loadw (tn-ref-tn values) move-temp -1) + + (emit-label no-values))) + (t + (collect ((defaults)) + (inst mov nil-temp nil-value) + (do ((i 0 (1+ i)) + (tn-ref values (tn-ref-across tn-ref))) + ((null tn-ref)) + (let ((default-lab (gen-label)) + (tn (tn-ref-tn tn-ref))) + (defaults (cons default-lab tn)) + + (inst cmp count (fixnum i)) + (inst jmp :le default-lab) + (sc-case tn + ((descriptor-reg any-reg) + ;; see above -- jrd + ;; (loadw tn start (- (1+ i))) + (move move-temp start) + (loadw tn move-temp (- (1+ i)))) + ((descriptor-stack immediate-stack) + ;; (loadw move-temp start (- (1+ i))) + (move move-temp start) + (loadw move-temp move-temp (- (1+ i))) + (move tn move-temp))))) + (let ((defaulting-done (gen-label))) + (emit-label defaulting-done) + (assemble (*elsewhere*) + (dolist (def (defaults)) + (emit-label (car def)) + (move (cdr def) nil-temp)) + (inst jmp defaulting-done)))))) + (inst mov esp-tn sp))) + +#+nil ;;; this is badly broken and just kept here for reference -pw + ;;; actually maybe it's not so broken -- check later +(define-vop (nlx-entry-multiple) + (:args (top) + (source) + (count :target ecx)) + ;; Again, no SC restrictions for the args, 'cause the loading would + ;; happen before the entry label. + (:info label) + ;;(:temporary (:sc dword-reg :offset esi-offset) esi) + (:temporary (:sc dword-reg :offset ecx-offset :from (:argument 2)) ecx) + (:temporary (:sc dword-reg :offset esi-offset) esi) + (:temporary (:sc dword-reg :offset edi-offset) edi) + (:results (result :scs (any-reg) :from (:argument 0)) + (num :scs (any-reg immediate-stack))) + (:save-p :force-to-stack) + (:vop-var vop) + (:generator 30 + #+x86-lra + (progn + (align lowtag-bits #x90) + (inst lra-header-word) + (inst nop) + (inst nop) + (inst nop)) + (emit-label label) + (note-this-location vop :non-local-entry) + + ;; Set up the result values and copy the arguments. + (move result top) + + ;; -- jrd. see comments above. need to do extra moves by hand, to + ;; get the ea's into registers + ;; (inst lea esi (make-ea :dword :base source :disp (- word-bytes))) + (inst lea edi (make-ea :dword :base result :disp (- word-bytes))) + (inst mov esi source) + (inst lea esi (make-ea :dword :base esi :disp (- word-bytes))) + (inst mov edi result) + (inst lea edi (make-ea :dword :base edi :disp (- word-bytes))) + + (move ecx count) ; fixnum words == bytes + (move num ecx) + (inst shr ecx word-shift) ; word count for <rep movs> + ;; If we got zero, we be done. + (inst jecxz done) + + ;; Copy them down. + (inst std) + (inst rep) + (inst movs :dword) + + ;; Reset the CSP. + DONE + (inst lea esp-tn (make-ea :dword :base edi :disp word-bytes)))) + +(define-vop (nlx-entry-multiple) + (:args (top) + (source) + (count :target ecx)) + ;; Again, no SC restrictions for the args, 'cause the loading would + ;; happen before the entry label. + (:info label) + (:temporary (:sc dword-reg :offset ecx-offset :from (:argument 2)) ecx) + (:temporary (:sc dword-reg :offset esi-offset) esi) + (:temporary (:sc dword-reg :offset edi-offset) edi) + (:results (result :scs (any-reg) :from (:argument 0)) + (num :scs (any-reg immediate-stack))) + (:save-p :force-to-stack) + (:vop-var vop) + (:generator 30 + #+x86-lra + (progn + (align lowtag-bits #x90) + (inst lra-header-word) + (inst nop) + (inst nop) + (inst nop)) + (emit-label label) + (note-this-location vop :non-local-entry) + + ;; The RISC implementations have old-fp-save wired to a register. + ;; ir2tran calls (make-old-fp-save-location) to retrieve that tn + ;; as the source address for the thrown results. Doing that here + ;; provides the S0 slot as that source which is the wrong end of + ;; the stack. Examination of the throw-catch-unwind process shows + ;; that %ebx is the analog of OCFP here and at least in testing so + ;; far does actually point (1 above) the values. + ;; Actually, now it seems that 'unwind' is supposed to set up + ;; edx and old-fp with certain values so that the compiler can + ;; call these nlx entry points correctly. NOT. + (move esi source) ; old-fp + (inst lea esi (make-ea :dword :base esi :disp (- word-bytes))) + ;; The 'top' arg contains the %esp value saved prior to creating + ;; the catch block and dynamic save structures and points to where + ;; the thrown values should sit. + (move edi top) + (move result edi) + ;; not too sure here -- yes! this seems to be correct + (inst lea edi (make-ea :dword :base edi :disp (- word-bytes))) + + (move ecx count) ; fixnum words == bytes + (move num ecx) + (inst shr ecx word-shift) ; word count for <rep movs> + ;; If we got zero, we be done. + (inst jecxz done) + ;; Copy them down. + (inst std) + (inst rep) + (inst movs :dword) + + ;; Reset the CSP (at last moved arg??) + DONE + (inst lea esp-tn (make-ea :dword :base edi :disp word-bytes)))) + + +;;; This VOP is just to force the TNs used in the cleanup onto the stack. +;;; +(define-vop (uwp-entry) + #+info-only + (:args (target)(block)(start)(count)) + (:info label) + (:save-p :force-to-stack) + (:results (block) (start) (count)) + (:ignore block start count) + (:vop-var vop) + (:generator 0 + #+x86-lra + (progn + (align lowtag-bits #x90) + (inst lra-header-word) + (inst nop) + (inst nop) + (inst nop)) + (emit-label label) + (note-this-location vop :non-local-entry))) diff --git a/compiler/x86/parms.lisp b/compiler/x86/parms.lisp new file mode 100644 index 000000000..5c1e6293f --- /dev/null +++ b/compiler/x86/parms.lisp @@ -0,0 +1,284 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: python-x86 -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/parms.lisp,v 1.1 1997/01/18 14:31:21 ram Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains some parameterizations of various VM +;;; attributes for the x86. This file is separate from other stuff so +;;; that it can be compiled and loaded earlier. +;;; +;;; Written by William Lott. +;;; +;;; Debugged by Paul F. Werkowski Spring/Summer 1995. +;;; + +(in-package :x86) +(use-package :c) + +;;; ### Note: we simultaneously use ``word'' to mean a 32 bit quantity and +;;; a 16 bit quantity depending on context. This is because Intel insists +;;; on calling 16 bit things words and 32 bit things double-words (or dwords). +;;; Therefore, in the instruction defintion and register specs, we use the +;;; Intel convention. But whenever we are talking about stuff the rest of +;;; the lisp system might be interested in, we use ``word'' to mean the size +;;; of a descriptor object, which is 32 bits. + + +;;;; Compiler constants. + +(eval-when (compile eval load) + +(setf (backend-name *target-backend*) "X86") +(setf (backend-version *target-backend*) "Intel x86") +(setf (backend-fasl-file-type *target-backend*) "x86f") +(setf (backend-fasl-file-implementation *target-backend*) + x86-fasl-file-implementation) +(setf (backend-fasl-file-version *target-backend*) 1) +(setf (backend-register-save-penalty *target-backend*) 3) +(setf (backend-byte-order *target-backend*) :little-endian) + +;;;#+cross-compiler +;;;(setf (backend-package *target-backend*) :python-x86) + +#| +;;; +;;; windows NT uses a memory system granularity of 64K, which means everything +;;; that gets mapped must be a multiple of that. The real page size is 512, but +;;; that doesn't do us a whole lot of good. Effectively, the page size is 64K +;;; +(setf (backend-page-size *target-backend*) 65536) +|# + +(setf (backend-page-size *target-backend*) 4096) +); eval-when + + +;;;; Machine Architecture parameters: + +(export '(word-bits byte-bits word-shift word-bytes float-sign-shift + + single-float-bias single-float-exponent-byte + single-float-significand-byte single-float-normal-exponent-min + single-float-normal-exponent-max single-float-hidden-bit + single-float-trapping-nan-bit single-float-digits + + double-float-bias double-float-exponent-byte + double-float-significand-byte double-float-normal-exponent-min + double-float-normal-exponent-max double-float-hidden-bit + double-float-trapping-nan-bit double-float-digits + + float-underflow-trap-bit float-overflow-trap-bit + float-imprecise-trap-bit float-invalid-trap-bit + float-divide-by-zero-trap-bit)) + + + +(eval-when (compile load eval) + +(defconstant word-bits 32 + "Number of bits per word where a word holds one lisp descriptor.") + +(defconstant byte-bits 8 + "Number of bits per byte where a byte is the smallest addressable object.") + +(defconstant word-shift (1- (integer-length (/ word-bits byte-bits))) + "Number of bits to shift between word addresses and byte addresses.") + +(defconstant word-bytes (/ word-bits byte-bits) + "Number of bytes in a word.") +) ; eval-when + +(eval-when (compile load eval) +(defconstant float-sign-shift 31) + +;; These values were taken from the alpha code. The values for +;; bias and exponent min/max are not the same as shown in the 486 book. +;; They may be correct for how Python uses them. +(defconstant single-float-bias 126) ; Intel says 127 +(defconstant single-float-exponent-byte (byte 8 23)) +(defconstant single-float-significand-byte (byte 23 0)) +;; The 486 book shows the exponent range -126 to +127. The Lisp +;; code that uses these values seems to want already biased numbers. +(defconstant single-float-normal-exponent-min 1) +(defconstant single-float-normal-exponent-max 254) +(defconstant single-float-hidden-bit (ash 1 23)) +(defconstant single-float-trapping-nan-bit (ash 1 22)) + +(defconstant double-float-bias 1022) +(defconstant double-float-exponent-byte (byte 11 20)) +(defconstant double-float-significand-byte (byte 20 0)) +(defconstant double-float-normal-exponent-min 1) +(defconstant double-float-normal-exponent-max #x7FE) +(defconstant double-float-hidden-bit (ash 1 20)) +(defconstant double-float-trapping-nan-bit (ash 1 19)) + +(defconstant single-float-digits + (+ (byte-size single-float-significand-byte) 1)) + +(defconstant double-float-digits + (+ (byte-size double-float-significand-byte) word-bits 1)) + + +;;; pfw -- from i486 microprocessor programmers reference manual +(defconstant float-invalid-trap-bit (ash 1 0)) +(defconstant float-denormal-trap-bit (ash 1 1)) ; not used by lisp +(defconstant float-divide-by-zero-trap-bit (ash 1 2)) +(defconstant float-overflow-trap-bit (ash 1 3)) +(defconstant float-underflow-trap-bit (ash 1 4)) +(defconstant float-inexact-trap-bit (ash 1 5)) + +(defconstant float-round-to-nearest 0) +(defconstant float-round-to-negative 1) +(defconstant float-round-to-positive 2) +(defconstant float-round-to-zero 3) + +(defconstant float-rounding-mode (byte 2 10)) +(defconstant float-sticky-bits (byte 6 16)) +(defconstant float-traps-byte (byte 6 0)) +(defconstant float-exceptions-byte (byte 6 16)) +(defconstant float-fast-bit 0) ; No fast mode on x86 +); eval-when + + +;;;; Description of the target address space. + +(export '(target-read-only-space-start + target-static-space-start + target-dynamic-space-start)) + +;;; Where to put the different spaces. +;;; +(defparameter target-read-only-space-start #x01000000) +(defparameter target-static-space-start #x05000000) +(defparameter target-dynamic-space-start #x09000000) + +;;; Given that NIL and T are the first things allocated in static space, we +;;; can know their values at compile time: +;;; +(defparameter nil-value #x0500000B) +(defparameter t-value #x0500002F) + + +;;;; Other random constants. + +(export '(halt-trap pending-interrupt-trap error-trap cerror-trap + breakpoint-trap function-end-breakpoint-trap single-step-breakpoint + trace-table-normal trace-table-call-site + trace-table-function-prologue trace-table-function-epilogue)) + +(defenum (:suffix -trap :start 8) + halt + pending-interrupt + error + cerror + breakpoint + function-end-breakpoint + single-step-breakpoint) + +(defenum (:prefix object-not- :suffix -trap :start 16) + list + instance) + +(defenum (:prefix trace-table-) + normal + call-site + function-prologue + function-epilogue) + + + +;;;; Static symbols. + +(export '(static-symbols static-functions)) + +;;; These symbols are loaded into static space directly after NIL so +;;; that the system can compute their address by adding a constant +;;; amount to NIL. +;;; +;;; The fdefn objects for the static functions are loaded into static +;;; space directly after the static symbols. That way, the raw-addr +;;; can be loaded directly out of them by indirecting relative to NIL. +;;; +;;; pfw X86 doesn't have enough registers to keep these things there. +;;; Note these spaces grow from low to high addresses. +(defvar lisp::*allocation-pointer*) +(defvar lisp::*binding-stack-pointer*) +(defvar lisp::*x86-cgc-active-p*) +(defvar lisp::*static-blue-bag* nil) + +(defparameter static-symbols + `(t + + ;; The C startup code must fill these in. + lisp::lisp-environment-list + lisp::lisp-command-line-list + lisp::*initial-fdefn-objects* + + ;; Functions that the C code needs to call + lisp::%initial-function + lisp::maybe-gc + kernel::internal-error + di::handle-breakpoint + lisp::fdefinition-object + + ;; Free Pointers. + lisp::*read-only-space-free-pointer* + lisp::*static-space-free-pointer* + lisp::*initial-dynamic-space-free-pointer* + + ;; Things needed for non-local-exit. + lisp::*current-catch-block* + lisp::*current-unwind-protect-block* + *eval-stack-top* + + ;; Interrupt Handling + lisp::*free-interrupt-context-index* + unix::*interrupts-enabled* + unix::*interrupt-pending* + + ;; added by pfw + lisp::*allocation-pointer* + lisp::*binding-stack-pointer* + lisp::*x86-cgc-active-p* + lisp::*internal-gc-trigger* ; Keep C code happy + + *fp-constant-1s0* + *fp-constant-1d0* + *fp-constant-0s0* + *fp-constant-0d0* + + ;; Some unused static variables - very handy for hacking. + lisp::*unused-static-8* + lisp::*unused-static-7* + lisp::*unused-static-6* + lisp::*unused-static-5* + lisp::*unused-static-4* + lisp::*unused-static-3* + lisp::*unused-static-2* + lisp::*unused-static-1* + + lisp::*static-blue-bag* ; Must be last or change C code + )) + +(defparameter static-functions + '(length + two-arg-+ two-arg-- two-arg-* two-arg-/ two-arg-< two-arg-> two-arg-= eql + %negate two-arg-and two-arg-ior two-arg-xor two-arg-gcd two-arg-lcm + )) + +;;; +;;; Stuff added by jrd ---- +;;; + + +;;; cf the sparc PARMS.LISP +(defparameter *assembly-unit-length* 8) + diff --git a/compiler/x86/pred.lisp b/compiler/x86/pred.lisp new file mode 100644 index 000000000..5021c9c3b --- /dev/null +++ b/compiler/x86/pred.lisp @@ -0,0 +1,82 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/pred.lisp,v 1.1 1997/01/18 14:31:22 ram Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the VM definition of predicate VOPs for the x86. +;;; +;;; Written by William Lott. +;;; + +(in-package :x86) + + +;;;; The Branch VOP. + +;;; The unconditional branch, emitted when we can't drop through to the desired +;;; destination. Dest is the continuation we transfer control to. +;;; +(define-vop (branch) + (:info dest) + (:generator 5 + (inst jmp dest))) + + +;;;; Conditional VOPs: + +;;; Note: a constant-tn is allowed in CMP; it uses an EA displacement, +;;; not immediate data. +(define-vop (if-eq) + (:args (x :scs (any-reg descriptor-reg immediate-stack descriptor-stack + constant) + :load-if (not (and (sc-is x immediate) + (sc-is y any-reg descriptor-reg + immediate-stack descriptor-stack + constant)))) + (y :scs (any-reg descriptor-reg immediate) + :load-if (not (and (sc-is x any-reg descriptor-reg immediate) + (sc-is y immediate-stack descriptor-stack + constant))))) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:translate eq) + (:generator 3 + (cond + ((sc-is y immediate) + (let ((val (tn-value y))) + (etypecase val + (integer + (if (and (zerop val) (sc-is x any-reg descriptor-reg)) + (inst test x x) ; smaller + (inst cmp x (fixnum val)))) + (symbol + (inst cmp x (+ nil-value (static-symbol-offset val)))) + (character + (inst cmp x (logior (ash (char-code val) type-bits) + base-char-type)))))) + ((sc-is x immediate) ; and y not immediate + ;; Swap the order to fit the compare instruction. + (let ((val (tn-value x))) + (etypecase val + (integer + (if (and (zerop val) (sc-is y any-reg descriptor-reg)) + (inst test y y) ; smaller + (inst cmp y (fixnum val)))) + (symbol + (inst cmp y (+ nil-value (static-symbol-offset val)))) + (character + (inst cmp y (logior (ash (char-code val) type-bits) + base-char-type)))))) + (t + (inst cmp x y))) + + (inst jmp (if not-p :ne :e) target))) diff --git a/compiler/x86/print.lisp b/compiler/x86/print.lisp new file mode 100644 index 000000000..d9a5317f3 --- /dev/null +++ b/compiler/x86/print.lisp @@ -0,0 +1,33 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/print.lisp,v 1.1 1997/01/18 14:31:22 ram Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the print VOP, which is used while booting the kernel +;;; core to keep the user entertained. +;;; +;;; Written by William Lott. +;;; +(in-package :x86) + +(define-vop (print) + (:args (object :scs (descriptor-reg any-reg))) + (:temporary (:sc dword-reg :offset eax-offset :target result + :from :eval :to (:result 0)) + eax) + (:results (result :scs (descriptor-reg))) + (:save-p t) + (:generator 100 + (inst push object) + (inst lea eax (make-fixup (extern-alien-name "debug_print") :foreign)) + (inst call (make-fixup (extern-alien-name "call_into_c") :foreign)) + (inst add esp-tn word-bytes) + (move result eax))) diff --git a/compiler/x86/sap.lisp b/compiler/x86/sap.lisp new file mode 100644 index 000000000..1bb0ca4ff --- /dev/null +++ b/compiler/x86/sap.lisp @@ -0,0 +1,456 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/sap.lisp,v 1.1 1997/01/18 14:31:23 ram Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the x86 VM definition of SAP operations. +;;; +;;; Written by William Lott. +;;; +;;; Debugged by Paul F. Werkowski Spring/Summer 1995. +;;; +(in-package :x86) + + +;;;; Moves and coercions: + +;;; Move a tagged SAP to an untagged representation. +;;; +(define-vop (move-to-sap) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (sap-reg))) + (:note "pointer to SAP coercion") + (:generator 1 + (loadw y x sap-pointer-slot other-pointer-type))) +;;; +(define-move-vop move-to-sap :move + (descriptor-reg) (sap-reg)) + +;;; Move an untagged SAP to a tagged representation. +;;; + +(define-vop (move-from-sap) + (:args (sap :scs (sap-reg) :to :save)) + (:temporary (:sc dword-reg) alloc) + (:results (res :scs (descriptor-reg))) + (:note "SAP to pointer coercion") + (:generator 20 + (with-fixed-allocation (res alloc sap-type sap-size) + (storew sap res sap-pointer-slot other-pointer-type)))) + +;;; +(define-move-vop move-from-sap :move + (sap-reg) (descriptor-reg)) + + +;;; Move untagged sap values. +;;; +(define-vop (sap-move) + (:args (x :target y + :scs (sap-reg) + :load-if (not (location= x y)))) + (:results (y :scs (sap-reg) + :load-if (not (location= x y)))) + (:note "SAP move") + (:effects) + (:affected) + (:generator 0 + (move y x))) + + +;;; +(define-move-vop sap-move :move + (sap-reg) (sap-reg)) + + +;;; Move untagged sap arguments/return-values. +;;; +(define-vop (move-sap-argument) + (:args (x :target y + :scs (sap-reg)) + (fp :scs (any-reg) + :load-if (not (sc-is y sap-reg)))) + (:results (y)) + (:note "SAP argument move") + (:generator 0 + (sc-case y + (sap-reg + (move y x)) + (sap-stack + (if (= (tn-offset fp) esp-offset) + (storew x fp (tn-offset y)) ; c-call + (storew x fp (- (1+ (tn-offset y))))))))) +;;; +(define-move-vop move-sap-argument :move-argument + (descriptor-reg sap-reg) (sap-reg)) + + +;;; Use standard MOVE-ARGUMENT + coercion to move an untagged sap to a +;;; descriptor passing location. +;;; +(define-move-vop move-argument :move-argument + (sap-reg) (descriptor-reg)) + + + +;;;; SAP-INT and INT-SAP + +(define-vop (sap-int) + (:args (sap :scs (sap-reg) :target int)) + (:arg-types system-area-pointer) + (:results (int :scs (unsigned-reg))) + (:result-types unsigned-num) + (:translate sap-int) + (:policy :fast-safe) + (:generator 1 + (move int sap))) + +(define-vop (int-sap) + (:args (int :scs (unsigned-reg) :target sap)) + (:arg-types unsigned-num) + (:results (sap :scs (sap-reg))) + (:result-types system-area-pointer) + (:translate int-sap) + (:policy :fast-safe) + (:generator 1 + (move sap int))) + + + +;;;; POINTER+ and POINTER- + +(define-vop (pointer+) + (:translate sap+) + (:args (ptr :scs (sap-reg) :target res) + (offset :scs (signed-reg))) + (:arg-types system-area-pointer signed-num) + (:results (res :scs (sap-reg) :from (:argument 0))) + (:result-types system-area-pointer) + (:policy :fast-safe) + (:generator 1 + (move res ptr) + (inst add res offset))) + +(define-vop (pointer+-c) + (:translate sap+) + (:args (ptr :scs (sap-reg) :target res)) + (:info offset) + (:arg-types system-area-pointer (:constant (signed-byte 32))) + (:results (res :scs (sap-reg))) + (:result-types system-area-pointer) + (:policy :fast-safe) + (:generator 1 + (move res ptr) + (inst add res offset))) + +(define-vop (pointer-) + (:translate sap-) + (:args (ptr1 :scs (sap-reg) :target res) + (ptr2 :scs (sap-reg))) + (:arg-types system-area-pointer system-area-pointer) + (:policy :fast-safe) + (:results (res :scs (signed-reg) :from (:argument 0))) + (:result-types signed-num) + (:generator 1 + (move res ptr1) + (inst sub res ptr2))) + + + +;;;; mumble-SYSTEM-REF and mumble-SYSTEM-SET + +(eval-when (compile eval) + +(defmacro def-system-ref-and-set + (ref-name set-name sc type size &optional signed) + (let ((ref-name-c (symbolicate ref-name "-C")) + (set-name-c (symbolicate set-name "-C")) + (temp-sc (symbolicate size "-REG"))) + `(progn + (define-vop (,ref-name) + (:translate ,ref-name) + (:policy :fast-safe) + (:args (sap :scs (sap-reg)) + (offset :scs (unsigned-reg))) + (:arg-types system-area-pointer unsigned-num) + ,@(unless (eq size :dword) + `((:temporary (:sc ,temp-sc :from (:eval 0) :to (:eval 1)) + temp))) + (:results (result :scs (,sc))) + (:result-types ,type) + (:generator 5 + (inst mov ,(if (eq size :dword) 'result 'temp) + (make-ea ,size :base sap :index offset)) + ,@(unless (eq size :dword) + `((inst ,(if signed 'movsx 'movzx) + result temp))))) + (define-vop (,ref-name-c) + (:translate ,ref-name) + (:policy :fast-safe) + (:args (sap :scs (sap-reg))) + (:arg-types system-area-pointer (:constant (signed-byte 32))) + (:info offset) + ,@(unless (eq size :dword) + `((:temporary (:sc ,temp-sc :from (:eval 0) :to (:eval 1)) + temp))) + (:results (result :scs (,sc))) + (:result-types ,type) + (:generator 4 + (inst mov ,(if (eq size :dword) 'result 'temp) + (make-ea ,size :base sap :disp offset)) + ,@(unless (eq size :dword) + `((inst ,(if signed 'movsx 'movzx) + result temp))))) + (define-vop (,set-name) + (:translate ,set-name) + (:policy :fast-safe) + (:args (sap :scs (sap-reg) :to (:eval 0)) + (offset :scs (unsigned-reg) :to (:eval 0)) + (value :scs (,sc) + :target ,(if (eq size :dword) 'result 'temp))) + (:arg-types system-area-pointer unsigned-num ,type) + ,@(unless (eq size :dword) + `((:temporary (:sc ,temp-sc :offset eax-offset + :from (:argument 2) :to (:result 0) + :target result) + temp))) + (:results (result :scs (,sc))) + (:result-types ,type) + (:generator 5 + ,@(unless (eq size :dword) + `((move eax-tn value))) + (inst mov (make-ea ,size :base sap :index offset) + ,(if (eq size :dword) 'value 'temp)) + (move result ,(if (eq size :dword) 'value 'eax-tn)))) + (define-vop (,set-name-c) + (:translate ,set-name) + (:policy :fast-safe) + (:args (sap :scs (sap-reg) :to (:eval 0)) + (value :scs (,sc) + :target ,(if (eq size :dword) 'result 'temp))) + (:arg-types system-area-pointer (:constant (signed-byte 32)) ,type) + (:info offset) + ,@(unless (eq size :dword) + `((:temporary (:sc ,temp-sc :offset eax-offset + :from (:argument 2) :to (:result 0) + :target result) + temp))) + (:results (result :scs (,sc))) + (:result-types ,type) + (:generator 4 + ,@(unless (eq size :dword) + `((move eax-tn value))) + (inst mov (make-ea ,size :base sap :disp offset) + ,(if (eq size :dword) 'value 'temp)) + (move result ,(if (eq size :dword) 'value 'eax-tn))))))) + +); eval-when (compile eval) + +(def-system-ref-and-set sap-ref-8 %set-sap-ref-8 + unsigned-reg positive-fixnum :byte nil) +(def-system-ref-and-set signed-sap-ref-8 %set-signed-sap-ref-8 + signed-reg tagged-num :byte t) +(def-system-ref-and-set sap-ref-16 %set-sap-ref-16 + unsigned-reg positive-fixnum :word nil) +(def-system-ref-and-set signed-sap-ref-16 %set-signed-sap-ref-16 + signed-reg tagged-num :word t) +(def-system-ref-and-set sap-ref-32 %set-sap-ref-32 + unsigned-reg unsigned-num :dword nil) +(def-system-ref-and-set signed-sap-ref-32 %set-signed-sap-ref-32 + signed-reg signed-num :dword t) +(def-system-ref-and-set sap-ref-sap %set-sap-ref-sap + sap-reg system-area-pointer :dword) + + +;;; Sap-Ref-Double +(define-vop (sap-ref-double) + (:translate sap-ref-double) + (:policy :fast-safe) + (:args (sap :scs (sap-reg)) + (offset :scs (unsigned-reg))) + (:arg-types system-area-pointer unsigned-num) + (:results (result :scs (double-reg))) + (:result-types double-float) + (:generator 5 + (with-empty-tn@fp-top(result) + (inst fldd (make-ea :dword :base sap :index offset))))) + +(define-vop (sap-ref-double-c) + (:translate sap-ref-double) + (:policy :fast-safe) + (:args (sap :scs (sap-reg))) + (:arg-types system-area-pointer (:constant (signed-byte 32))) + (:info offset) + (:results (result :scs (double-reg))) + (:result-types double-float) + (:generator 4 + (with-empty-tn@fp-top(result) + (inst fldd (make-ea :dword :base sap :disp offset))))) + +(define-vop (%set-sap-ref-double) + (:translate %set-sap-ref-double) + (:policy :fast-safe) + (:args (sap :scs (sap-reg) :to (:eval 0)) + (offset :scs (unsigned-reg) :to (:eval 0)) + (value :scs (double-reg))) + (:arg-types system-area-pointer unsigned-num double-float) + (:results (result :scs (double-reg))) + (:result-types double-float) + (:generator 5 + (if (zerop (tn-offset value)) + (progn + ;; Value is in ST0 + (inst fstd (make-ea :dword :base sap :index offset)) + (unless (zerop (tn-offset result)) + ;; Value is in ST0 but not result. + (inst fstd result))) + (progn + ;; Value is not in ST0. + (inst fxch value) + (inst fstd (make-ea :dword :base sap :index offset)) + (if (zerop (tn-offset result)) + ;; The result is in ST0. + (inst fstd value) + (progn + ;; Neither value or result are in ST0 + (unless (location= value result) + (inst fstd result)) + (inst fxch value))))))) + +(define-vop (%set-sap-ref-double-c) + (:translate %set-sap-ref-double) + (:policy :fast-safe) + (:args (sap :scs (sap-reg) :to (:eval 0)) + (value :scs (double-reg))) + (:arg-types system-area-pointer (:constant (signed-byte 32)) double-float) + (:info offset) + (:results (result :scs (double-reg))) + (:result-types double-float) + (:generator 4 + (if (zerop (tn-offset value)) + (progn + ;; Value is in ST0 + (inst fstd (make-ea :dword :base sap :disp offset)) + (unless (zerop (tn-offset result)) + ;; Value is in ST0 but not result. + (inst fstd result))) + (progn + ;; Value is not in ST0. + (inst fxch value) + (inst fstd (make-ea :dword :base sap :disp offset)) + (if (zerop (tn-offset result)) + ;; The result is in ST0. + (inst fstd value) + (progn + ;; Neither value or result are in ST0 + (unless (location= value result) + (inst fstd result)) + (inst fxch value))))))) + + +;;; Sap-Ref-Single +(define-vop (sap-ref-single) + (:translate sap-ref-single) + (:policy :fast-safe) + (:args (sap :scs (sap-reg)) + (offset :scs (unsigned-reg))) + (:arg-types system-area-pointer unsigned-num) + (:results (result :scs (single-reg))) + (:result-types single-float) + (:generator 5 + (with-empty-tn@fp-top(result) + (inst fld (make-ea :dword :base sap :index offset))))) + +(define-vop (sap-ref-single-c) + (:translate sap-ref-single) + (:policy :fast-safe) + (:args (sap :scs (sap-reg))) + (:arg-types system-area-pointer (:constant (signed-byte 32))) + (:info offset) + (:results (result :scs (single-reg))) + (:result-types single-float) + (:generator 4 + (with-empty-tn@fp-top(result) + (inst fld (make-ea :dword :base sap :disp offset))))) + +(define-vop (%set-sap-ref-single) + (:translate %set-sap-ref-single) + (:policy :fast-safe) + (:args (sap :scs (sap-reg) :to (:eval 0)) + (offset :scs (unsigned-reg) :to (:eval 0)) + (value :scs (single-reg))) + (:arg-types system-area-pointer unsigned-num single-float) + (:results (result :scs (single-reg))) + (:result-types single-float) + (:generator 5 + (if (zerop (tn-offset value)) + (progn + ;; Value is in ST0 + (inst fst (make-ea :dword :base sap :index offset)) + (unless (zerop (tn-offset result)) + ;; Value is in ST0 but not result. + (inst fst result))) + (progn + ;; Value is not in ST0. + (inst fxch value) + (inst fst (make-ea :dword :base sap :index offset)) + (if (zerop (tn-offset result)) + ;; The result is in ST0. + (inst fst value) + (progn + ;; Neither value or result are in ST0 + (unless (location= value result) + (inst fst result)) + (inst fxch value))))))) + +(define-vop (%set-sap-ref-single-c) + (:translate %set-sap-ref-single) + (:policy :fast-safe) + (:args (sap :scs (sap-reg) :to (:eval 0)) + (value :scs (single-reg))) + (:arg-types system-area-pointer (:constant (signed-byte 32)) single-float) + (:info offset) + (:results (result :scs (single-reg))) + (:result-types single-float) + (:generator 4 + (if (zerop (tn-offset value)) + (progn + ;; Value is in ST0 + (inst fst (make-ea :dword :base sap :disp offset)) + (unless (zerop (tn-offset result)) + ;; Value is in ST0 but not result. + (inst fst result))) + (progn + ;; Value is not in ST0. + (inst fxch value) + (inst fst (make-ea :dword :base sap :disp offset)) + (if (zerop (tn-offset result)) + ;; The result is in ST0. + (inst fst value) + (progn + ;; Neither value or result are in ST0 + (unless (location= value result) + (inst fst result)) + (inst fxch value))))))) + + +;;; Noise to convert normal lisp data objects into SAPs. + +(define-vop (vector-sap) + (:translate vector-sap) + (:policy :fast-safe) + (:args (vector :scs (descriptor-reg) :target sap)) + (:results (sap :scs (sap-reg))) + (:result-types system-area-pointer) + (:generator 2 + (move sap vector) + (inst add sap (- (* vector-data-offset word-bytes) other-pointer-type)))) + diff --git a/compiler/x86/static-fn.lisp b/compiler/x86/static-fn.lisp new file mode 100644 index 000000000..6dafb81ad --- /dev/null +++ b/compiler/x86/static-fn.lisp @@ -0,0 +1,182 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/static-fn.lisp,v 1.1 1997/01/18 14:31:22 ram Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the VOPs and macro magic necessary to call static +;;; functions. +;;; +;;; Written by William Lott. +;;; +;;; Debugged by Paul F. Werkowski Spring/Summer 1995. +;;; +(in-package :x86) + + +(define-vop (static-function-template) + (:save-p t) + (:policy :safe) + (:variant-vars function) + (:vop-var vop) + (:node-var node) + #+nil + (:temporary (:sc dword-reg :offset eax-offset) eax) ; used for call + (:temporary (:sc dword-reg :offset ebx-offset :from (:eval 1) :to (:eval 2)) + ebx) + (:ignore #+nil eax ebx) + (:temporary (:sc dword-reg :offset ecx-offset :from (:eval 0) :to (:eval 2)) + ecx)) + +(eval-when (compile load eval) + +(defun static-function-template-name (num-args num-results) + (intern (format nil "~:@(~R-arg-~R-result-static-function~)" + num-args num-results))) + +(defun moves (dst src) + (collect ((moves)) + (do ((dst dst (cdr dst)) + (src src (cdr src))) + ((or (null dst) (null src))) + (moves `(move ,(car dst) ,(car src)))) + (moves))) + +(defun static-function-template-vop (num-args num-results) + (assert (and (<= num-args register-arg-count) + (<= num-results register-arg-count)) + (num-args num-results) + "Either too many args (~D) or too many results (~D). Max = ~D" + num-args num-results register-arg-count) + (let ((num-temps (max num-args num-results))) + (collect ((temp-names) (temps) (arg-names) (args) (result-names) (results)) + (dotimes (i num-results) + (let ((result-name (intern (format nil "RESULT-~D" i)))) + (result-names result-name) + (results `(,result-name :scs (any-reg descriptor-reg))))) + (dotimes (i num-temps) + (let ((temp-name (intern (format nil "TEMP-~D" i)))) + (temp-names temp-name) + (temps `(:temporary (:sc dword-reg + :offset ,(nth i register-arg-offsets) + :from ,(if (< i num-args) + `(:argument ,i) + '(:eval 1)) + :to ,(if (< i num-results) + `(:result ,i) + '(:eval 1)) + ,@(when (< i num-results) + `(:target ,(nth i (result-names))))) + ,temp-name)))) + (dotimes (i num-args) + (let ((arg-name (intern (format nil "ARG-~D" i)))) + (arg-names arg-name) + (args `(,arg-name + :scs (any-reg descriptor-reg) + :target ,(nth i (temp-names)))))) + `(define-vop (,(static-function-template-name num-args num-results) + static-function-template) + (:args ,@(args)) + ,@(temps) + (:results ,@(results)) + (:generator ,(+ 50 num-args num-results) + ,@(moves (temp-names) (arg-names)) + ;; If speed is more important than size, duplicate the effect of + ;; the ENTER with discrete instructions. Takes 9 bytes/6 cycles + ;; as opposed to 4 bytes/10 cycles. + (cond ((policy node (> speed space)) + (inst push ebp-tn) + (inst mov ebp-tn esp-tn) + (inst sub esp-tn (fixnum 3))) ; pw -- was 2 + (t + (inst enter (fixnum 3)))) ; pw -- was 2 + ;; The enter instruction pushes EBP and then copies ESP into + ;; EBP. We want the new EBP to be the original ESP, so we fix it + ;; up afterwards. + (inst add ebp-tn (fixnum 1)) + (inst mov ecx (fixnum ,num-args)) + + ;; jrd fixed it up this way, to deal with the fact that the thing in + ;; static-symbols is the fdefn + ;; pfw says this is no longer true + (inst mov eax-tn + (make-ea :dword + :disp (+ nil-value (static-function-offset function)))) + + ;; Save the return address. + #+x86-lra + (storew (make-fixup nil :code-object return) + ebp-tn (- (1+ return-pc-save-offset))) + + ;; Push the return address for backward compatability. + #+x86-lra + (inst push (make-ea :dword :base ebp-tn :disp -8)) + + (note-this-location vop :call-site) + #-x86-lra + (inst call eax-tn) + #+x86-lra + (progn + (inst jmp eax-tn) + (align lowtag-bits #x90) + (inst lra-header-word) + (inst nop) + (inst nop) + (inst nop)) + #+x86-lra + RETURN + + ,(collect ((bindings) (links)) + (do ((temp (temp-names) (cdr temp)) + (name 'values (gensym)) + (prev nil name) + (i 0 (1+ i))) + ((= i num-results)) + (bindings `(,name + (make-tn-ref ,(car temp) nil))) + (when prev + (links `(setf (tn-ref-across ,prev) ,name)))) + `(let ,(bindings) + ,@(links) + (default-unknown-values + vop + ,(if (zerop num-results) nil 'values) + ,num-results))) + ,@(moves (result-names) (temp-names))))))) + + +) ; eval-when (compile load eval) + + +(macrolet ((frob (num-args num-res) + (static-function-template-vop (eval num-args) (eval num-res)))) + (frob 0 1) + (frob 1 1) + (frob 2 1) + (frob 3 1)) + + +(defmacro define-static-function (name args &key (results '(x)) translate + policy cost arg-types result-types) + `(define-vop (,name + ,(static-function-template-name (length args) + (length results))) + (:variant ',name) + (:note ,(format nil "static-function ~@(~S~)" name)) + ,@(when translate + `((:translate ,translate))) + ,@(when policy + `((:policy ,policy))) + ,@(when cost + `((:generator-cost ,cost))) + ,@(when arg-types + `((:arg-types ,@arg-types))) + ,@(when result-types + `((:result-types ,@result-types))))) diff --git a/compiler/x86/subprim.lisp b/compiler/x86/subprim.lisp new file mode 100644 index 000000000..532cd7ed4 --- /dev/null +++ b/compiler/x86/subprim.lisp @@ -0,0 +1,93 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/subprim.lisp,v 1.1 1997/01/18 14:31:23 ram Exp $") +;;; +;;; ********************************************************************** +;;; +;;; Linkage information for standard static functions, and random vops. +;;; +;;; Written by William Lott. +;;; +;;; Debugged by Paul F. Werkowski Spring/Summer 1995. +;;; +(in-package :x86) + + + +;;;; Length + +(define-vop (length/list) + (:translate length) + (:args (object :scs (descriptor-reg descriptor-stack) :target ptr)) + (:arg-types list) + (:temporary (:sc dword-reg :offset eax-offset) eax) + (:temporary (:sc dword-reg :from (:argument 0)) ptr) + (:results (count :scs (any-reg))) + (:result-types positive-fixnum) + (:policy :fast-safe) + (:vop-var vop) + (:save-p :compute-only) + (:generator 40 + ;; Move OBJECT into a temp we can bash on, and initialize the count. + (move ptr object) + (inst xor count count) + ;; If we are starting with NIL, then it's real easy. + (inst cmp ptr nil-value) + (inst jmp :e done) + ;; Note: we don't have to test to see if the original argument is a + ;; list, because this is a :fast-safe vop. + LOOP + ;; Get the CDR and boost the count. + (loadw ptr ptr cons-cdr-slot list-pointer-type) + (inst add count (fixnum 1)) + ;; If we hit NIL, then we are done. + (inst cmp ptr nil-value) + (inst jmp :e done) + ;; Otherwise, check to see if we hit the end of a dotted list. If + ;; not, loop back for more. + (move eax ptr) + (inst and al-tn lowtag-mask) + (inst cmp al-tn list-pointer-type) + (inst jmp :e loop) + ;; It's dotted all right. Flame out. + (error-call vop object-not-list-error ptr) + ;; We be done. + DONE)) + +(define-vop (fast-length/list) + (:translate length) + (:args (object :scs (descriptor-reg descriptor-stack) :target ptr)) + (:arg-types list) + (:temporary (:sc dword-reg :from (:argument 0)) ptr) + (:results (count :scs (any-reg))) + (:result-types positive-fixnum) + (:policy :fast) + (:vop-var vop) + (:save-p :compute-only) + (:generator 30 + ;; Get a copy of OBJECT in a register we can bash on, and + ;; initialize COUNT. + (move ptr object) + (inst xor count count) + ;; If we are starting with NIL, we be done. + (inst cmp ptr nil-value) + (inst jmp :e done) + ;; Indirect the next cons cell, and boost the count. + LOOP + (loadw ptr ptr cons-cdr-slot list-pointer-type) + (inst add count (fixnum 1)) + ;; If we arn't done, go back for more. + (inst cmp ptr nil-value) + (inst jmp :ne loop) + DONE)) + + +(define-static-function length (object) :translate length) + diff --git a/compiler/x86/system.lisp b/compiler/x86/system.lisp new file mode 100644 index 000000000..a6c54aa78 --- /dev/null +++ b/compiler/x86/system.lisp @@ -0,0 +1,304 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/system.lisp,v 1.1 1997/01/18 14:31:19 ram Exp $") +;;; +;;; ********************************************************************** +;;; +;;; x86 VM definitions of various system hacking operations. +;;; +;;; Written by William Lott. +;;; +;;; Debugged by Paul F. Werkowski Spring/Summer 1995. +;;; + +(in-package :x86) + + +;;;; Type frobbing VOPs + +(define-vop (get-lowtag) + (:translate get-lowtag) + (:policy :fast-safe) + (:args (object :scs (any-reg descriptor-reg immediate-stack descriptor-stack) + :target result)) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 1 + (move result object) + (inst and result lowtag-mask))) + +(define-vop (get-type) + (:translate get-type) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:temporary (:sc dword-reg :offset eax-offset :to (:result 0)) eax) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 6 + (inst mov eax object) + (inst and al-tn lowtag-mask) + (inst cmp al-tn other-pointer-type) + (inst jmp :e other-ptr) + (inst cmp al-tn function-pointer-type) + (inst jmp :e function-ptr) + + ;; pick off structures and list pointers + (inst test al-tn 1) + (inst jmp :ne done) + + ;; pick off fixnums + (inst and al-tn 3) + (inst jmp :e done) + + ;; must be an other immediate + (inst mov eax object) + (inst jmp done) + + FUNCTION-PTR + (load-type al-tn object (- vm:function-pointer-type)) + (inst jmp done) + + OTHER-PTR + (load-type al-tn object (- vm:other-pointer-type)) + + DONE + (inst movzx result al-tn))) + +(define-vop (function-subtype) + (:translate function-subtype) + (:policy :fast-safe) + (:args (function :scs (descriptor-reg))) + (:temporary (:sc byte-reg :from (:eval 0) :to (:eval 1)) temp) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 6 + (load-type temp function (- vm:function-pointer-type)) + (inst movzx result temp))) + +(define-vop (set-function-subtype) + (:translate (setf function-subtype)) + (:policy :fast-safe) + (:args (type :scs (unsigned-reg) :target eax) + (function :scs (descriptor-reg))) + (:arg-types positive-fixnum *) + (:temporary (:sc dword-reg :offset eax-offset :from (:argument 0) + :to (:result 0) :target result) + eax) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 6 + (move eax type) + (inst mov + (make-ea :byte :base function :disp (- function-pointer-type)) + al-tn) + (move result eax))) + +(define-vop (get-header-data) + (:translate get-header-data) + (:policy :fast-safe) + (:args (x :scs (descriptor-reg))) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 6 + (loadw res x 0 other-pointer-type) + (inst shr res type-bits))) + +(define-vop (get-closure-length) + (:translate get-closure-length) + (:policy :fast-safe) + (:args (x :scs (descriptor-reg))) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 6 + (loadw res x 0 function-pointer-type) + (inst shr res type-bits))) + +(define-vop (set-header-data) + (:translate set-header-data) + (:policy :fast-safe) + (:args (x :scs (descriptor-reg) :target res :to (:result 0)) + (data :scs (any-reg) :target eax)) + (:arg-types * positive-fixnum) + (:results (res :scs (descriptor-reg))) + (:temporary (:sc dword-reg :offset eax-offset + :from (:argument 1) :to (:result 0)) eax) + (:generator 6 + (move eax data) + (inst shl eax (- type-bits 2)) + (inst mov al-tn (make-ea :byte :base x :disp (- other-pointer-type))) + (storew eax x 0 other-pointer-type) + (move res x))) + +(define-vop (make-fixnum) + (:args (ptr :scs (any-reg descriptor-reg) :target res)) + (:results (res :scs (any-reg descriptor-reg))) + (:generator 1 + ;; + ;; Some code (the hash table code) depends on this returning a + ;; positive number so make sure it does. + (move res ptr) + (inst shl res 3) + (inst shr res 1))) + +(define-vop (make-other-immediate-type) + (:args (val :scs (any-reg descriptor-reg) :target res) + (type :scs (unsigned-reg immediate))) + (:results (res :scs (any-reg descriptor-reg) :from (:argument 0))) + (:generator 2 + (move res val) + (inst shl res (- type-bits 2)) + (inst or res (sc-case type + (unsigned-reg type) + (immediate (tn-value type)))))) + + +;;;; Allocation + +(define-vop (dynamic-space-free-pointer) + (:results (int :scs (sap-reg))) + (:result-types system-area-pointer) + (:translate dynamic-space-free-pointer) + (:policy :fast-safe) + (:generator 1 + (load-symbol-value int lisp::*allocation-pointer*))) + +(define-vop (binding-stack-pointer-sap) + (:results (int :scs (sap-reg))) + (:result-types system-area-pointer) + (:translate binding-stack-pointer-sap) + (:policy :fast-safe) + (:generator 1 + (load-symbol-value int lisp::*binding-stack-pointer*))) + +(define-vop (control-stack-pointer-sap) + (:results (int :scs (sap-reg))) + (:result-types system-area-pointer) + (:translate control-stack-pointer-sap) + (:policy :fast-safe) + (:generator 1 + (move int esp-tn))) + + +;;;; Code object frobbing. + +(define-vop (code-instructions) + (:translate code-instructions) + (:policy :fast-safe) + (:args (code :scs (descriptor-reg) :to (:result 0))) + (:results (sap :scs (sap-reg) :from (:argument 0))) + (:result-types system-area-pointer) + (:generator 10 + (loadw sap code 0 other-pointer-type) + (inst shr sap type-bits) + (inst lea sap (make-ea :byte :base code :index sap :scale 4 + :disp (- other-pointer-type))))) + +(define-vop (compute-function) + (:args (code :scs (descriptor-reg) :to (:result 0)) + (offset :scs (signed-reg unsigned-reg) :to (:result 0))) + (:arg-types * positive-fixnum) + (:results (func :scs (descriptor-reg) :from (:argument 0))) + (:generator 10 + (loadw func code 0 other-pointer-type) + (inst shr func type-bits) + (inst lea func + (make-ea :byte :base offset :index func :scale 4 + :disp (- function-pointer-type other-pointer-type))) + (inst add func code))) + +(defknown %function-self (function) function (flushable)) + +(define-vop (%function-self) + (:policy :fast-safe) + (:translate %function-self) + (:args (function :scs (descriptor-reg))) + (:results (result :scs (descriptor-reg))) + (:generator 3 + (loadw result function function-self-slot function-pointer-type) + (inst lea result + (make-ea :byte :base result + :disp (- function-pointer-type + (* function-code-offset word-bytes)))))) + +;;; Closure function slot is a pointer to raw code on X86 instead of +;;; a pointer to the code function object itself. This VOP is used +;;; to reference the function object given the closure object. +(def-source-transform %closure-function (closure) + `(%function-self ,closure)) + +(def-source-transform %funcallable-instance-function (fin) + `(%function-self ,fin)) + +(defknown (setf %function-self) (function function) function (unsafe)) + +(define-vop (%set-function-self) + (:policy :fast-safe) + (:translate (setf %function-self)) + (:args (new-self :scs (descriptor-reg) :target result :to :result) + (function :scs (descriptor-reg) :to :result)) + (:temporary (:sc any-reg :from (:argument 0) :to :result) temp) + (:results (result :scs (descriptor-reg))) + (:generator 3 + (inst lea temp + (make-ea :byte :base new-self + :disp (- (ash function-code-offset word-shift) + function-pointer-type))) + (storew temp function function-self-slot function-pointer-type) + (move result new-self))) + +;; Would have really liked to use a source-transform for this, but they +;; don't work with setf functions. +;; +(defknown ((setf %funcallable-instance-function)) (function function) function + (unsafe)) +(deftransform (setf %funcallable-instance-function) ((value fin)) + '(setf (%function-self fin) value)) + + + +;;;; Other random VOPs. + +(defknown unix::do-pending-interrupt () (values)) +(define-vop (unix::do-pending-interrupt) + (:policy :fast-safe) + (:translate unix::do-pending-interrupt) + (:generator 1 + (inst int 3) + (inst byte pending-interrupt-trap))) + +(define-vop (halt) + (:generator 1 + (inst int 3) + (inst byte halt-trap))) + +;;; bootstrapping +(in-package :kernel) +(export 'float-wait) +(in-package :x86) + +(defknown float-wait () (values)) +(define-vop (float-wait) + (:policy :fast-safe) + (:translate float-wait) + (:vop-var vop) + (:save-p :compute-only) + (:generator 1 + (note-next-instruction vop :internal-error) + (inst wait))) + +;;;; Dynamic vop count collection support + +(define-vop (count-me) + (:args (count-vector :scs (descriptor-reg))) + (:info index) + (:generator 0 + (inst inc (make-ea :dword :base count-vector + :disp (- (* (+ vector-data-offset index) word-bytes) + other-pointer-type))))) diff --git a/compiler/x86/type-vops.lisp b/compiler/x86/type-vops.lisp new file mode 100644 index 000000000..5d8e4ddcc --- /dev/null +++ b/compiler/x86/type-vops.lisp @@ -0,0 +1,599 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/type-vops.lisp,v 1.1 1997/01/18 14:31:23 ram Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the VM definition of type testing and checking VOPs +;;; for the x86. +;;; +;;; Written by William Lott. +;;; +;;; Debugged by Paul F. Werkowski, Spring-95. +;;; +(in-package :x86) + + + +;;;; Test generation utilities. + +(eval-when (compile eval) + +(defparameter immediate-types + (list unbound-marker-type base-char-type)) + + +(defparameter function-header-types + (list funcallable-instance-header-type dylan-function-header-type + byte-code-function-type byte-code-closure-type + function-header-type closure-function-header-type + closure-header-type)) + +(defun canonicalize-headers (headers) + (collect ((results)) + (let ((start nil) + (prev nil) + (delta (- other-immediate-1-type other-immediate-0-type))) + (flet ((emit-test () + (results (if (= start prev) + start + (cons start prev))))) + (dolist (header (sort headers #'<)) + (cond ((null start) + (setf start header) + (setf prev header)) + ((= header (+ prev delta)) + (setf prev header)) + (t + (emit-test) + (setf start header) + (setf prev header)))) + (emit-test))) + (results))) + +(defmacro test-type (value target not-p &rest type-codes) + ;; Determine what interesting combinations we need to test for. + (let* ((type-codes (mapcar #'eval type-codes)) + (fixnump (and (member even-fixnum-type type-codes) + (member odd-fixnum-type type-codes) + t)) + (lowtags (remove lowtag-limit type-codes :test #'<)) + (extended (remove lowtag-limit type-codes :test #'>)) + (immediates (intersection extended immediate-types :test #'eql)) + (headers (set-difference extended immediate-types :test #'eql)) + (function-p (if (intersection headers function-header-types) + (if (subsetp headers function-header-types) + t + (error "Can't test for mix of function subtypes ~ + and normal header types.")) + nil))) + (unless type-codes + (error "Must supply at least one type for test-type.")) + (cond + (fixnump + (when (remove-if #'(lambda (x) + (or (= x even-fixnum-type) + (= x odd-fixnum-type))) + lowtags) + (error "Can't mix fixnum testing with other lowtags.")) + (when function-p + (error "Can't mix fixnum testing with function subtype testing.")) + (when immediates + (error "Can't mix fixnum testing with other immediates.")) + (if headers + `(%test-fixnum-and-headers ,value ,target ,not-p + ',(canonicalize-headers headers)) + `(%test-fixnum ,value ,target ,not-p))) + (immediates + (when headers + (error "Can't mix testing of immediates with testing of headers.")) + (when lowtags + (error "Can't mix testing of immediates with testing of lowtags.")) + (when (cdr immediates) + (error "Can't test multiple immediates at the same time.")) + `(%test-immediate ,value ,target ,not-p ,(car immediates))) + (lowtags + (when (cdr lowtags) + (error "Can't test multiple lowtags at the same time.")) + (if headers + `(%test-lowtag-and-headers + ,value ,target ,not-p ,(car lowtags) + ,function-p ',(canonicalize-headers headers)) + `(%test-lowtag ,value ,target ,not-p ,(car lowtags)))) + (headers + `(%test-headers ,value ,target ,not-p ,function-p + ',(canonicalize-headers headers))) + (t + (error "Nothing to test?"))))) + + +); eval-when (compile eval) + +(defun %test-fixnum (value target not-p) + (inst test value 3) + (inst jmp (if not-p :nz :z) target)) + +(defun %test-fixnum-and-headers (value target not-p headers) + (let ((drop-through (gen-label))) + (inst test value 3) + (inst jmp :z (if not-p drop-through target)) + (%test-headers value target not-p nil headers drop-through))) + +(defun %test-immediate (value target not-p immediate) + (move eax-tn value) + (inst cmp al-tn immediate) + (inst jmp (if not-p :ne :e) target)) + +(defun %test-lowtag (value target not-p lowtag &optional al-loaded) + (unless al-loaded + (move eax-tn value) + (inst and al-tn lowtag-mask)) + (inst cmp al-tn lowtag) + (inst jmp (if not-p :ne :e) target)) + +(defun %test-lowtag-and-headers (value target not-p lowtag function-p headers) + (let ((drop-through (gen-label))) + (%test-lowtag value (if not-p drop-through target) nil lowtag) + (%test-headers value target not-p function-p headers drop-through t))) + + +(defun %test-headers (value target not-p function-p headers + &optional (drop-through (gen-label)) al-loaded) + (let ((lowtag (if function-p function-pointer-type other-pointer-type))) + (multiple-value-bind + (equal less-or-equal when-true when-false) + ;; EQUAL and LESS-OR-EQUAL are the conditions for branching to TARGET. + ;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when we know + ;; it's true and when we know it's false respectively. + (if not-p + (values :ne :a drop-through target) + (values :e :na target drop-through)) + (%test-lowtag value when-false t lowtag al-loaded) + (inst mov al-tn (make-ea :byte :base value :disp (- lowtag))) + (do ((remaining headers (cdr remaining))) + ((null remaining)) + (let ((header (car remaining)) + (last (null (cdr remaining)))) + (cond + ((atom header) + (inst cmp al-tn header) + (if last + (inst jmp equal target) + (inst jmp :e when-true))) + (t + (let ((start (car header)) + (end (cdr header))) + (unless (= start bignum-type) + (inst cmp al-tn start) + (inst jmp :b when-false)) ; was :l + (inst cmp al-tn end) + (if last + (inst jmp less-or-equal target) + (inst jmp :be when-true))))))) ; was :le + (emit-label drop-through)))) + +;; pw -- based on RISC version. Not sure extra hair is needed yet. +;; difference is that this one uses SUB which overwrites operand +;; both cmp and sub take 2 cycles so maybe its a wash +#+nil +(defun %test-headers (value target not-p function-p headers + &optional (drop-through (gen-label)) al-loaded) + (let ((lowtag (if function-p function-pointer-type other-pointer-type))) + (multiple-value-bind + (equal less-or-equal when-true when-false) + ;; EQUAL and LESS-OR-EQUAL are the conditions for branching to TARGET. + ;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when we know + ;; it's true and when we know it's false respectively. + (if not-p + (values :ne :a drop-through target) + (values :e :na target drop-through)) + (%test-lowtag value when-false t lowtag al-loaded) + (inst mov al-tn (make-ea :byte :base value :disp (- lowtag))) + (let ((delta 0)) + (do ((remaining headers (cdr remaining))) + ((null remaining)) + (let ((header (car remaining)) + (last (null (cdr remaining)))) + (cond + ((atom header) + (inst sub al-tn (- header delta)) + (setf delta header) + (if last + (inst jmp equal target) + (inst jmp :e when-true))) + (t + (let ((start (car header)) + (end (cdr header))) + (unless (= start bignum-type) + (inst sub al-tn (- start delta)) + (setf delta start) + (inst jmp :l when-false)) + (inst sub al-tn (- end delta)) + (setf delta end) + (if last + (inst jmp less-or-equal target) + (inst jmp :le when-true)))))))) + (emit-label drop-through)))) + + +;;;; Type checking and testing: + +(define-vop (check-type) + (:args (value :target result :scs (any-reg descriptor-reg))) + (:results (result :scs (any-reg descriptor-reg))) + (:temporary (:sc dword-reg :offset eax-offset :to (:result 0)) eax) + (:ignore eax) + (:vop-var vop) + (:save-p :compute-only)) + +(define-vop (type-predicate) + (:args (value :scs (any-reg descriptor-reg))) + (:temporary (:sc dword-reg :offset eax-offset) eax) + (:ignore eax) + (:conditional) + (:info target not-p) + (:policy :fast-safe)) + +(eval-when (compile eval) + +(defun cost-to-test-types (type-codes) + (+ (* 2 (length type-codes)) + (if (> (apply #'max type-codes) lowtag-limit) 7 2))) + +(defmacro def-type-vops (pred-name check-name ptype error-code + &rest type-codes) + (let ((cost (cost-to-test-types (mapcar #'eval type-codes)))) + `(progn + ,@(when pred-name + `((define-vop (,pred-name type-predicate) + (:translate ,pred-name) + (:generator ,cost + (test-type value target not-p ,@type-codes))))) + ,@(when check-name + `((define-vop (,check-name check-type) + (:generator ,cost + (let ((err-lab + (generate-error-code vop ,error-code value))) + (test-type value err-lab t ,@type-codes) + (move result value)))))) + ,@(when ptype + `((primitive-type-vop ,check-name (:check) ,ptype)))))) + +); eval-when (compile eval) + +(def-type-vops fixnump check-fixnum fixnum object-not-fixnum-error + even-fixnum-type odd-fixnum-type) + +(def-type-vops functionp check-function function + object-not-function-error function-pointer-type) + +(def-type-vops listp check-list list object-not-list-error + list-pointer-type) + +(def-type-vops %instancep check-instance instance object-not-instance-error + instance-pointer-type) + +(def-type-vops bignump check-bignum bignum + object-not-bignum-error bignum-type) + +(def-type-vops ratiop check-ratio ratio + object-not-ratio-error ratio-type) + +(def-type-vops complexp check-complex complex + object-not-complex-error complex-type) + +(def-type-vops single-float-p check-single-float single-float + object-not-single-float-error single-float-type) + +(def-type-vops double-float-p check-double-float double-float + object-not-double-float-error double-float-type) + +(def-type-vops simple-string-p check-simple-string simple-string + object-not-simple-string-error simple-string-type) + +(def-type-vops simple-bit-vector-p check-simple-bit-vector simple-bit-vector + object-not-simple-bit-vector-error simple-bit-vector-type) + +(def-type-vops simple-vector-p check-simple-vector simple-vector + object-not-simple-vector-error simple-vector-type) + +(def-type-vops simple-array-unsigned-byte-2-p + check-simple-array-unsigned-byte-2 + simple-array-unsigned-byte-2 + object-not-simple-array-unsigned-byte-2-error + simple-array-unsigned-byte-2-type) + +(def-type-vops simple-array-unsigned-byte-4-p + check-simple-array-unsigned-byte-4 + simple-array-unsigned-byte-4 + object-not-simple-array-unsigned-byte-4-error + simple-array-unsigned-byte-4-type) + +(def-type-vops simple-array-unsigned-byte-8-p + check-simple-array-unsigned-byte-8 + simple-array-unsigned-byte-8 + object-not-simple-array-unsigned-byte-8-error + simple-array-unsigned-byte-8-type) + +(def-type-vops simple-array-unsigned-byte-16-p + check-simple-array-unsigned-byte-16 + simple-array-unsigned-byte-16 + object-not-simple-array-unsigned-byte-16-error + simple-array-unsigned-byte-16-type) + +(def-type-vops simple-array-unsigned-byte-32-p + check-simple-array-unsigned-byte-32 + simple-array-unsigned-byte-32 + object-not-simple-array-unsigned-byte-32-error + simple-array-unsigned-byte-32-type) + +(def-type-vops simple-array-single-float-p check-simple-array-single-float + simple-array-single-float object-not-simple-array-single-float-error + simple-array-single-float-type) + +(def-type-vops simple-array-double-float-p check-simple-array-double-float + simple-array-double-float object-not-simple-array-double-float-error + simple-array-double-float-type) + +(def-type-vops base-char-p check-base-char base-char + object-not-base-char-error base-char-type) + +(def-type-vops system-area-pointer-p check-system-area-pointer + system-area-pointer object-not-sap-error sap-type) + +(def-type-vops weak-pointer-p check-weak-pointer weak-pointer + object-not-weak-pointer-error weak-pointer-type) + +(def-type-vops scavenger-hook-p nil nil nil + 0) + +(def-type-vops code-component-p nil nil nil + code-header-type) + +(def-type-vops lra-p nil nil nil + return-pc-header-type) + +(def-type-vops fdefn-p nil nil nil + fdefn-type) + +(def-type-vops funcallable-instance-p nil nil nil + funcallable-instance-header-type) + +(def-type-vops array-header-p nil nil nil + simple-array-type complex-string-type complex-bit-vector-type + complex-vector-type complex-array-type) + +(def-type-vops nil check-function-or-symbol nil + object-not-function-or-symbol-error + function-pointer-type symbol-header-type) + +(def-type-vops stringp check-string nil object-not-string-error + simple-string-type complex-string-type) + +(def-type-vops bit-vector-p check-bit-vector nil object-not-bit-vector-error + simple-bit-vector-type complex-bit-vector-type) + +(def-type-vops vectorp check-vector nil object-not-vector-error + simple-string-type simple-bit-vector-type simple-vector-type + simple-array-unsigned-byte-2-type simple-array-unsigned-byte-4-type + simple-array-unsigned-byte-8-type simple-array-unsigned-byte-16-type + simple-array-unsigned-byte-32-type simple-array-single-float-type + simple-array-double-float-type complex-string-type + complex-bit-vector-type complex-vector-type) + +(def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error + simple-array-type simple-string-type simple-bit-vector-type + simple-vector-type simple-array-unsigned-byte-2-type + simple-array-unsigned-byte-4-type simple-array-unsigned-byte-8-type + simple-array-unsigned-byte-16-type simple-array-unsigned-byte-32-type + simple-array-single-float-type simple-array-double-float-type) + +(def-type-vops arrayp check-array nil object-not-array-error + simple-array-type simple-string-type simple-bit-vector-type + simple-vector-type simple-array-unsigned-byte-2-type + simple-array-unsigned-byte-4-type simple-array-unsigned-byte-8-type + simple-array-unsigned-byte-16-type simple-array-unsigned-byte-32-type + simple-array-single-float-type simple-array-double-float-type + complex-string-type complex-bit-vector-type complex-vector-type + complex-array-type) + +(def-type-vops numberp check-number nil object-not-number-error + even-fixnum-type odd-fixnum-type bignum-type ratio-type + single-float-type double-float-type complex-type) + +(def-type-vops rationalp check-rational nil object-not-rational-error + even-fixnum-type odd-fixnum-type ratio-type bignum-type) + +(def-type-vops integerp check-integer nil object-not-integer-error + even-fixnum-type odd-fixnum-type bignum-type) + +(def-type-vops floatp check-float nil object-not-float-error + single-float-type double-float-type) + +(def-type-vops realp check-real nil object-not-real-error + even-fixnum-type odd-fixnum-type ratio-type bignum-type + single-float-type double-float-type) + + +;;;; Other integer ranges. + +;;; A (signed-byte 32) can be represented with either fixnum or a bignum with +;;; exactly one digit. + +(define-vop (signed-byte-32-p type-predicate) + (:translate signed-byte-32-p) + (:generator 45 + (multiple-value-bind + (yep nope) + (if not-p + (values not-target target) + (values target not-target)) + (inst test value #x3) + (inst jmp :e yep) + (move eax-tn value) + (inst and al-tn lowtag-mask) + (inst cmp al-tn other-pointer-type) + (inst jmp :ne nope) + (loadw eax-tn value 0 other-pointer-type) + (inst cmp eax-tn (+ (ash 1 type-bits) bignum-type)) + (inst jmp (if not-p :ne :e) target)) + NOT-TARGET)) + +(define-vop (check-signed-byte-32 check-type) + (:generator 45 + (let ((nope (generate-error-code vop + object-not-signed-byte-32-error + value))) + (inst test value #x3) + (inst jmp :e yep) + (move eax-tn value) + (inst and al-tn lowtag-mask) + (inst cmp al-tn other-pointer-type) + (inst jmp :ne nope) + (loadw eax-tn value 0 other-pointer-type) + (inst cmp eax-tn (+ (ash 1 type-bits) bignum-type)) + (inst jmp :ne nope)) + YEP + (move result value))) + +;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a +;;; bignum with exactly one positive digit, or a bignum with exactly two digits +;;; and the second digit all zeros. + +(define-vop (unsigned-byte-32-p type-predicate) + (:translate unsigned-byte-32-p) + (:generator 45 + (let ((not-target (gen-label)) + (single-word (gen-label)) + (fixnum (gen-label))) + (multiple-value-bind + (yep nope) + (if not-p + (values not-target target) + (values target not-target)) + ;; Is it a fixnum? + (inst test value 3) + (move eax-tn value) + (inst jmp :e fixnum) + + ;; If not, is it an other pointer? + (inst and al-tn lowtag-mask) + (inst cmp al-tn other-pointer-type) + (inst jmp :ne nope) + ;; Get the header. + (loadw eax-tn value 0 other-pointer-type) + ;; Is it one? + (inst cmp eax-tn (+ (ash 1 type-bits) bignum-type)) + (inst jmp :e single-word) + ;; If it's other than two, we can't be an (unsigned-byte 32) + (inst cmp eax-tn (+ (ash 2 type-bits) bignum-type)) + (inst jmp :ne nope) + ;; Get the second digit. + (loadw eax-tn value (1+ bignum-digits-offset) other-pointer-type) + ;; All zeros, its an (unsigned-byte 32). + (inst or eax-tn eax-tn) + (inst jmp :z yep) + (inst jmp nope) + + (emit-label single-word) + ;; Get the single digit. + (loadw eax-tn value bignum-digits-offset other-pointer-type) + + ;; positive implies (unsigned-byte 32). + (emit-label fixnum) + (inst or eax-tn eax-tn) + (inst jmp (if not-p :s :ns) target) + + (emit-label not-target))))) + +(define-vop (check-unsigned-byte-32 check-type) + (:generator 45 + (let ((nope + (generate-error-code vop object-not-unsigned-byte-32-error value)) + (yep (gen-label)) + (fixnum (gen-label)) + (single-word (gen-label))) + + ;; Is it a fixnum? + (inst test value 3) + (move eax-tn value) + (inst jmp :e fixnum) + + ;; If not, is it an other pointer? + (inst and al-tn lowtag-mask) + (inst cmp al-tn other-pointer-type) + (inst jmp :ne nope) + ;; Get the header. + (loadw eax-tn value 0 other-pointer-type) + ;; Is it one? + (inst cmp eax-tn (+ (ash 1 type-bits) bignum-type)) + (inst jmp :e single-word) + ;; If it's other than two, we can't be an (unsigned-byte 32) + (inst cmp eax-tn (+ (ash 2 type-bits) bignum-type)) + (inst jmp :ne nope) + ;; Get the second digit. + (loadw eax-tn value (1+ bignum-digits-offset) other-pointer-type) + ;; All zeros, its an (unsigned-byte 32). + (inst or eax-tn eax-tn) + (inst jmp :z yep) + (inst jmp nope) + + (emit-label single-word) + ;; Get the single digit. + (loadw eax-tn value bignum-digits-offset other-pointer-type) + + ;; positive implies (unsigned-byte 32). + (emit-label fixnum) + (inst or eax-tn eax-tn) + (inst jmp :s nope) + + (emit-label yep) + (move result value)))) + + +;;;; List/symbol types: +;;; +;;; symbolp (or symbol (eq nil)) +;;; consp (and list (not (eq nil))) + +(define-vop (symbolp type-predicate) + (:translate symbolp) + (:generator 12 + (let ((is-symbol-label (if not-p drop-thru target))) + (inst cmp value nil-value) + (inst jmp :e is-symbol-label) + (test-type value target not-p symbol-header-type)) + DROP-THRU)) + +(define-vop (check-symbol check-type) + (:generator 12 + (let ((error (generate-error-code vop object-not-symbol-error value))) + (inst cmp value nil-value) + (inst jmp :e drop-thru) + (test-type value error t symbol-header-type)) + DROP-THRU + (move result value))) + +(define-vop (consp type-predicate) + (:translate consp) + (:generator 8 + (let ((is-not-cons-label (if not-p target drop-thru))) + (inst cmp value nil-value) + (inst jmp :e is-not-cons-label) + (test-type value target not-p list-pointer-type)) + DROP-THRU)) + +(define-vop (check-cons check-type) + (:generator 8 + (let ((error (generate-error-code vop object-not-cons-error value))) + (inst cmp value nil-value) + (inst jmp :e error) + (test-type value error t list-pointer-type) + (move result value)))) diff --git a/compiler/x86/values.lisp b/compiler/x86/values.lisp new file mode 100644 index 000000000..59d38b64f --- /dev/null +++ b/compiler/x86/values.lisp @@ -0,0 +1,135 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/values.lisp,v 1.1 1997/01/18 14:31:23 ram Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the implementation of unknown-values VOPs. +;;; +;;; Written by William Lott. +;;; +;;; Debugged by Paul F. Werkowski Spring/Summer 1995. +;;; %more-arg-values by Douglas Thomas Crosher, March 1996. + +(in-package :x86) + +(define-vop (reset-stack-pointer) + (:args (ptr :scs (any-reg))) + (:generator 1 + (move esp-tn ptr))) + +;;; Push some values onto the stack, returning the start and number of values +;;; pushed as results. It is assumed that the Vals are wired to the standard +;;; argument locations. Nvals is the number of values to push. +;;; +;;; The generator cost is pseudo-random. We could get it right by defining a +;;; bogus SC that reflects the costs of the memory-to-memory moves for each +;;; operand, but this seems unworthwhile. +;;; +(define-vop (push-values) + (:args (vals :more t)) + (:temporary (:sc dword-reg :to (:result 0) :target start) temp) + (:results (start) (count)) + (:info nvals) + (:generator 20 + (move temp esp-tn) ; WARN pointing 1 below + (do ((val vals (tn-ref-across val))) + ((null val)) + (inst push (tn-ref-tn val))) + (move start temp) + (inst mov count (fixnum nvals)))) + +;;; Push a list of values on the stack, returning Start and Count as used in +;;; unknown values continuations. +;;; +(define-vop (values-list) + (:args (arg :scs (descriptor-reg) :target list)) + (:arg-types list) + (:policy :fast-safe) + (:results (start :scs (any-reg)) + (count :scs (any-reg))) + (:temporary (:sc descriptor-reg :from (:argument 0) :to (:result 1)) list) + (:temporary (:sc dword-reg :to (:result 1)) nil-temp) + (:temporary (:sc dword-reg :offset eax-offset :to (:result 1)) eax) + (:vop-var vop) + (:save-p :compute-only) + (:generator 0 + (move list arg) + (move start esp-tn) ; WARN pointing 1 below + (inst mov nil-temp nil-value) + + LOOP + (inst cmp list nil-temp) + (inst jmp :e done) + (pushw list cons-car-slot list-pointer-type) + (loadw list list cons-cdr-slot list-pointer-type) + (inst mov eax list) + (inst and al-tn lowtag-mask) + (inst cmp al-tn list-pointer-type) + (inst jmp :e loop) + (error-call vop bogus-argument-to-values-list-error list) + + DONE + (inst mov count start) ; start is high address + (inst sub count esp-tn))) ; stackp is low address + +;;; Copy the more arg block to the top of the stack so we can use them +;;; as function arguments. +;;; +;;; Accepts a context as produced by more-arg-context; points to the first +;;; value on the stack, not 4 bytes above as in other contexts. +;;; +;;; Return a context that is 4 bytes above the first value, suitable for +;;; defining a new stack frame. +;;; +;;; +(define-vop (%more-arg-values) + (:args (context :scs (descriptor-reg any-reg) :target src) + (skip :scs (any-reg immediate)) + (num :scs (any-reg) :target count)) + (:arg-types * positive-fixnum positive-fixnum) + (:temporary (:sc any-reg :offset esi-offset :from (:argument 0)) src) + (:temporary (:sc descriptor-reg :offset eax-offset) temp) + (:temporary (:sc dword-reg :offset ecx-offset) temp1) + (:results (start :scs (any-reg)) + (count :scs (any-reg))) + (:generator 20 + (sc-case skip + (immediate + (if (zerop (tn-value skip)) + (progn + (move src context) + (move count num)) + (progn + (inst lea src (make-ea :dword :base context + :disp (- (* (tn-value skip) word-bytes)))) + (move count num) + (inst sub count (* (tn-value skip) word-bytes))))) + + (any-reg + (move src context) + (inst sub src skip) + (move count num) + (inst sub count skip))) + + (move temp1 count) + (inst mov start esp-tn) + (inst jecxz done) ; check for 0 count? + + (inst shr temp1 word-shift) ; convert the fixnum to a count. + + (inst std) ; move down the stack as more value are copied to the bottom. + LOOP + (inst lods temp) + (inst push temp) + (inst loop loop) + + DONE)) + \ No newline at end of file diff --git a/compiler/x86/vm.lisp b/compiler/x86/vm.lisp new file mode 100644 index 000000000..e7b2b0514 --- /dev/null +++ b/compiler/x86/vm.lisp @@ -0,0 +1,496 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: python-x86 -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/vm.lisp,v 1.1 1997/01/18 14:31:20 ram Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the VM defintion noise for the x86. +;;; +;;; Written by William Lott +;;; +;;; Debugged by Paul F. Werkowski Spring/Summer 1995. +;;; + +(in-package :x86) + + +;;;; Register specs + +(eval-when (compile eval) + +(defmacro defreg (name offset size) + (let ((offset-sym (symbolicate name "-OFFSET")) + (names-vector (symbolicate "*" size "-REGISTER-NAMES*"))) + `(progn + (eval-when (compile eval load) + (defconstant ,offset-sym ,offset)) + (setf (svref ,names-vector ,offset-sym) ,(symbol-name name))))) + +(defmacro defregset (name &rest regs) + `(eval-when (compile eval load) + (defconstant ,name + (list ,@(mapcar #'(lambda (name) (symbolicate name "-OFFSET")) regs))))) + +); eval-when + +;;; Byte registers. +;;; +;;; Note: the encoding here is different then that used by the chip. We +;;; use this encoding so that the compiler thinks that AX (and EAX) overlap +;;; AL and AH instead of AL and CL. +;;; +(eval-when (compile load eval) + (defvar *byte-register-names* (make-array 8 :initial-element nil))) +;;; +(defreg al 0 :byte) +(defreg ah 1 :byte) +(defreg cl 2 :byte) +(defreg ch 3 :byte) +(defreg dl 4 :byte) +(defreg dh 5 :byte) +(defreg bl 6 :byte) +(defreg bh 7 :byte) +;;; +(defregset byte-regs al ah cl ch dl dh bl bh) + +;;; Word registers. +;;; +(eval-when (compile load eval) + (defvar *word-register-names* (make-array 16 :initial-element nil))) +;;; +(defreg ax 0 :word) +(defreg cx 2 :word) +(defreg dx 4 :word) +(defreg bx 6 :word) +(defreg sp 8 :word) +(defreg bp 10 :word) +(defreg si 12 :word) +(defreg di 14 :word) +;;; +(defregset word-regs ax cx dx bx si di) + +;;; Double Word registers. +;;; +(eval-when (compile load eval) + (defvar *dword-register-names* (make-array 16 :initial-element nil))) +;;; +(defreg eax 0 :dword) +(defreg ecx 2 :dword) +(defreg edx 4 :dword) +(defreg ebx 6 :dword) +(defreg esp 8 :dword) +(defreg ebp 10 :dword) +(defreg esi 12 :dword) +(defreg edi 14 :dword) +;;; +(defregset dword-regs eax ecx edx ebx esi edi) + +;;; added by jrd +(eval-when (compile load eval) + (defvar *float-register-names* (make-array 8 :initial-element nil))) +(defreg fr0 0 :float) +(defreg fr1 1 :float) +(defreg fr2 2 :float) +(defreg fr3 3 :float) +(defreg fr4 4 :float) +(defreg fr5 5 :float) +(defreg fr6 6 :float) +(defreg fr7 7 :float) +(defregset float-regs fr0 fr1 fr2 fr3 fr4 fr5 fr6 fr7) + +;(defvar *double-float-register-names* (make-array 8 :initial-element nil)) +;(defreg dfr0 0 :double-float) +;(defreg dfr1 1 :double-float) +;(defreg dfr2 2 :double-float) +;(defreg dfr3 3 :double-float) +;(defreg dfr4 4 :double-float) +;(defreg dfr5 5 :double-float) +;(defreg dfr6 6 :double-float) +;(defreg dfr7 7 :double-float) +;(defregset double-float-regs dfr0 dfr1 dfr2 dfr3 dfr4 dfr5 dfr6 dfr7) + + +;;;; SB definitions. + +;;; Despite the fact that there are only 8 different registers, we consider +;;; them 16 in order to describe the overlap of byte registers. The only +;;; thing we need to represent is what registers overlap. Therefore, we +;;; consider bytes to take one unit, and words or dwords to take two. We +;;; don't need to tell the difference between words and dwords, because +;;; you can't put two words in a dword. + +(define-storage-base registers :finite :size 16) + +;;; +;;; jrd changed this from size 1 to size 8. it doesn't seem to make much +;;; sense to use the 387's idea of a stack. 8 separate registers is easier +;;; to deal with. +;;; (define-storage-base float-registers :finite :size 1) +(define-storage-base float-registers :finite :size 8) + +(define-storage-base stack :unbounded :size 8) +(define-storage-base constant :non-packed) +(define-storage-base immediate-constant :non-packed) +(define-storage-base noise :unbounded :size 2) + + + +;;;; SC definitions. + +;;; +;;; Handy macro so we don't have to keep changing all the numbers whenever +;;; we insert a new storage class. +;;; +(defmacro define-storage-classes (&rest classes) + (collect ((forms)) + (let ((index 0)) + (dolist (class classes) + (let* ((sc-name (car class)) + (constant-name (symbolicate sc-name "-SC-NUMBER"))) + (forms `(define-storage-class ,sc-name ,index + ,@(cdr class))) + (forms `(defconstant ,constant-name ,index)) + (forms `(export ',constant-name)) + (incf index)))) + `(progn + ,@(forms)))) + +(define-storage-classes + + ;; Non-immediate contstants in the constant pool + (constant constant) + + ;; Some FP constants can be generated in the i387 silicon. + + (fp-single-constant immediate-constant) + (fp-double-constant immediate-constant) + + (immediate immediate-constant) + + ;; **** The stacks. + + ;; The control stack. + (descriptor-stack stack) ; may be pointers, scanned by GC + (immediate-stack stack) ; isn't pointers, ignored by GC + + ;; The non-descriptor stacks. + (signed-stack stack) ; (signed-byte 32) + (unsigned-stack stack) ; (unsigned-byte 32) + (base-char-stack stack) ; non-descriptor characters. + (sap-stack stack) ; System area pointers. + (single-stack stack) ; single-floats + (double-stack stack :element-size 2) ; double floats. + + ;; **** Magic SCs. + + (ignore-me noise) + + ;; **** Things that can go in the integer registers. + + ;; We don't have to distinguish between descriptor and non-descriptor + ;; registers, because we dump explicit information about what descriptor + ;; values are live at any potential GC point. Therefore, we only different + ;; scs to distinguish between descriptor and non-descriptor values and + ;; to specify size. + + (any-reg registers + :locations #.dword-regs + :element-size 2 + :reserve-locations (#.eax-offset) + :constant-scs (immediate) + :save-p t + :alternate-scs (immediate-stack)) + + ;; Pointer descriptor objects. Must be seen by GC. + (descriptor-reg registers + :locations #.dword-regs + :element-size 2 + :reserve-locations (#.eax-offset) + :constant-scs + (constant immediate + ;; zzz jrd added IMMEDIATE-STACK here. + ;; it seems right, and references elsewhere + ;; in the code suggest that we expect to be + ;; able to do this. see + ;; DEFINE-MOVE-VOP MOVE :MOVE in MOVE.LISP + + ;; zzz this may not be right after all + ;; immediate-stack + ) + :save-p t + :alternate-scs (descriptor-stack)) + + ;; Non-Descriptor characters + (base-char-reg registers + :locations #.byte-regs + :reserve-locations (#.ah-offset #.al-offset) + :constant-scs (immediate) + :save-p t + :alternate-scs (base-char-stack)) + + ;; Non-Descriptor SAP's (arbitrary pointers into address space) + (sap-reg registers + :locations #.dword-regs + :element-size 2 + :reserve-locations (#.eax-offset) + :constant-scs (immediate) + :save-p t + :alternate-scs (sap-stack)) + + ;; Non-Descriptor (signed or unsigned) numbers. + (signed-reg registers + :locations #.dword-regs + :element-size 2 + :reserve-locations (#.eax-offset) + :constant-scs (immediate) + :save-p t + :alternate-scs (signed-stack)) + (unsigned-reg registers + :locations #.dword-regs + :element-size 2 + :reserve-locations (#.eax-offset) + :constant-scs (immediate) + :save-p t + :alternate-scs (unsigned-stack)) + + ;; Random objects that must not be seen by GC. Used only as temporaries. + (dword-reg registers + :locations #.dword-regs + :element-size 2 + :reserve-locations (#.eax-offset)) + (word-reg registers + :locations #.word-regs + :element-size 2 + :reserve-locations (#.ax-offset)) + (byte-reg registers + :locations #.byte-regs + :reserve-locations (#.al-offset #.ah-offset)) + + ;; **** Things that can go in the floating point registers. + + ;; Non-Descriptor single-floats. + (single-reg float-registers + :locations (0 1 2 3 4 5 6 7) + :constant-scs (fp-single-constant) + :save-p t + :alternate-scs (single-stack)) + + ;; Non-Descriptor double-floats. + (double-reg float-registers + :locations (0 1 2 3 4 5 6 7) + :constant-scs (fp-double-constant) + :save-p t + :alternate-scs (double-stack)) + + ;; A catch or unwind block. + (catch-block stack :element-size vm:catch-block-size) + + ;; added by jrd. need to define non-descriptor-reg-sc-number for the + ;; debug code, among others. this doesn't actually get used in any code. + (non-descriptor-reg registers + :locations #.dword-regs + :element-size 2 + :reserve-locations ()) + ;; this one too + (interior-reg registers + :locations #.dword-regs + :element-size 2 + :reserve-locations ()) + ) + +;;; zzz added by jrd; has somebody been changing names of these things on me? +(export 'control-stack-sc-number) +(defconstant control-stack-sc-number descriptor-stack-sc-number) + + +(eval-when (compile load eval) + +(defconstant byte-sc-names '(base-char-reg byte-reg base-char-stack)) +(defconstant word-sc-names '(word-reg)) +(defconstant dword-sc-names + '(any-reg descriptor-reg sap-reg signed-reg unsigned-reg dword-reg + descriptor-stack immediate-stack signed-stack unsigned-stack + sap-stack single-stack constant)) + +;;; +;;; added by jrd. I guess the right thing to do is to treat floats +;;; as a separate size... +;;; +;;; These are used to (at least) determine operand size. +(defconstant float-sc-names '(single-reg)) +(defconstant double-sc-names '(double-reg double-stack)) +) + + + +;;;; Random TNs for the various registers. + +(eval-when (compile eval) + (defmacro def-random-reg-tns (sc-name &rest reg-names) + (collect ((forms)) + (dolist (reg-name reg-names) + (let ((reg-tn-name (symbolicate reg-name "-TN")) + (reg-offset-name (symbolicate reg-name "-OFFSET"))) + ;;(forms `(export ',reg-tn-name)) + (forms `(defparameter ,reg-tn-name + (make-random-tn :kind :normal + :sc (sc-or-lose ',sc-name) + :offset ,reg-offset-name))))) + `(progn ,@(forms))))) + +(def-random-reg-tns dword-reg eax ebx ecx edx ebp esp edi esi) +(def-random-reg-tns word-reg ax bx cx dx bp sp di si) +(def-random-reg-tns byte-reg al ah bl bh cl ch dl dh) + +;; added by jrd +(def-random-reg-tns single-reg fr0 fr1 fr2 fr3 fr4 fr5 fr6 fr7) + +;; Added by pw. + +(defparameter fp-single-constant-tn + (make-random-tn :kind :normal + :sc (sc-or-lose 'fp-single-constant) + :offset 31)) ; Offset doesn't get used. +(defparameter fp-double-constant-tn + (make-random-tn :kind :normal + :sc (sc-or-lose 'fp-single-constant) + :offset 31)) + + + + +;;; Immediate-Constant-SC +;;; +;;; Basically, if it's easier to represent the value as an immediate in +;;; some instruction instead of in the constants pool, then return +;;; the immediate SC. +;;; + +#+nil ;; pw-- the way it was. +(def-vm-support-routine immediate-constant-sc (value) + (if (or (and (symbolp value) (static-symbol-p value)) + #-cross-compiler + (typep value 'fixnum) + #+cross-compiler + (and (typep value 'integer) + (>= value (info variable constant-value 'most-negative-fixnum)) + (<= value (info variable constant-value 'most-positive-fixnum))) + #-cross-compiler + (typep value 'system-area-pointer) + (typep value + #+lispworks3 'lisp::base-character + #-lispworks3 'base-char)) + (sc-number-or-lose 'immediate *backend*) + nil)) + +;;; I probably should use double-from-bits here +;;; to avoid any compilation errors, but lets see +;;; what happens. These should be part of lisp like PI? +(defconstant i387-lg2 3.010299956639811952137389d0) +(defconstant i387-ln2 0.6931471805599453094172321d0) +(defconstant i387-l10 2.3025850929940456840179915d0) +(defconstant i387-l2e (/ i387-ln2)) +(defconstant i387-l2t (/ i387-l10 i387-ln2)) +(export '(i387-lg2 i387-ln2 i387-l10 i387-l2e i387-l2t)) + + +;;; pw-- A good try and it works, but it also results in +;;; extra consing when the constant is an argument to +;;; some function. The descriptor from the constants vector +;;; would normally be passed instead. DTC processes zero and +;;; one in move-from-single|double as static symbols to +;;; save on CV space for these common values. + +(def-vm-support-routine immediate-constant-sc (value) + (typecase value + ((or fixnum system-area-pointer character) + (sc-number-or-lose 'immediate *backend*)) + (symbol + (if (static-symbol-p value) + (sc-number-or-lose 'immediate *backend*) + nil)) + (single-float + (when (or (zerop value) + (= 1s0 value)) + (sc-number-or-lose 'fp-single-constant *backend*))) + (double-float + (when (or (zerop value) + (= value 1d0) + #| No longer! + (= value #.pi) + (= value #.i387-l2t) + (= value #.i387-ln2) + (= value #.i387-l2e) + (= value #.i387-lg2) + |#) + (sc-number-or-lose 'fp-double-constant *backend*))))) + + +;;;; Function Call Parameters + +;;; Offsets of special stack frame locations +(defconstant old-fp-save-offset 0) +(defconstant return-pc-save-offset 1) +(defconstant code-save-offset 2) + + +;;; names of these things seem to have changed. these aliases by jrd +(defconstant ocfp-save-offset old-fp-save-offset) +(defconstant lra-save-offset return-pc-save-offset) + +(defconstant cfp-offset ebp-offset) ; pfw - needed by stuff in /code + ; related to sigcontext stuff +;;; The number of arguments/return values passed in registers. +;;; +(defconstant register-arg-count 3) + +;;; Names, Offsets, and TNs to use for the argument registers. +;;; +(defconstant register-arg-names '(edx edi esi)) +(defregset register-arg-offsets edx edi esi) +(defparameter register-arg-tns (list edx-tn edi-tn esi-tn)) + +;;; SINGLE-VALUE-RETURN-BYTE-OFFSET +;;; +;;; This is used by the debugger. +;;; +(export 'single-value-return-byte-offset) +(defconstant single-value-return-byte-offset 2) + + +;;; LOCATION-PRINT-NAME -- Interface +;;; +;;; This function is called by debug output routines that want a pretty name +;;; for a TN's location. It returns a thing that can be printed with PRINC. +;;; +(def-vm-support-routine location-print-name (tn) + (declare (type tn tn)) + (let* ((sc (tn-sc tn)) + (sb (sb-name (sc-sb sc))) + (offset (tn-offset tn))) + (ecase sb + (registers + (let* ((sc-name (sc-name sc)) + (name-vec (cond ((member sc-name byte-sc-names) + *byte-register-names*) + ((member sc-name word-sc-names) + *word-register-names*) + ((member sc-name dword-sc-names) + *dword-register-names*)))) + (or (and name-vec + (< -1 offset (length name-vec)) + (svref name-vec offset)) + (format nil "<Unknown Reg: off=~D, sc=~A>" offset sc-name)))) + ;; (float-registers "FloatStackTop") + (float-registers (format nil "FR~D" offset)) + (stack (format nil "S~D" offset)) + (constant (format nil "Const~D" offset)) + (immediate-constant "Immed") + (noise (symbol-name (sc-name sc)))))) diff --git a/hemlock/diredcoms.lisp b/hemlock/diredcoms.lisp index 272390aa9..9ea2bfefc 100644 --- a/hemlock/diredcoms.lisp +++ b/hemlock/diredcoms.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/diredcoms.lisp,v 1.4 1994/10/31 04:50:12 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/diredcoms.lisp,v 1.5 1997/01/18 14:31:50 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -330,8 +330,9 @@ (declare (ignore p)) (unless (hemlock-bound-p 'dired-information) (editor-error "Not in Dired buffer.")) - (let ((dirs (pathname-directory - (dired-info-pathname (value dired-information))))) + (let ((dirs (or (pathname-directory + (dired-info-pathname (value dired-information))) + '(:relative)))) (dired-command nil (truename (make-pathname :directory (nconc dirs '(:UP))))))) diff --git a/hemlock/echo.lisp b/hemlock/echo.lisp index 6567b3110..bb4228104 100644 --- a/hemlock/echo.lisp +++ b/hemlock/echo.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/echo.lisp,v 1.7 1994/10/31 04:50:12 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/echo.lisp,v 1.8 1997/01/18 14:31:53 ram Rel $") ;;; ;;; ********************************************************************** ;;; @@ -176,6 +176,7 @@ ;;; INIT-BITMAP-SCREEN-MANAGER in bit-screen.lisp adds this hook when ;;; initializing the bitmap screen manager. ;;; +#+clx (defun raise-echo-area-when-modified (buffer modified) (when (and (value ed::raise-echo-area-when-modified) (eq buffer *echo-area-buffer*) diff --git a/hemlock/echocoms.lisp b/hemlock/echocoms.lisp index 65b79caec..41deba6da 100644 --- a/hemlock/echocoms.lisp +++ b/hemlock/echocoms.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/echocoms.lisp,v 1.5 1994/10/31 04:50:12 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/echocoms.lisp,v 1.6 1997/01/18 14:31:55 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -22,15 +22,16 @@ (defhvar "Ignore File Types" "File types to ignore when trying to complete a filename." :value - (list "fasl" "pmaxf" "sparcf" "rtf" "hpf" "axpf" "sgif" "err" ; Lisp + (list "fasl" "pmaxf" "sparcf" "rtf" "hpf" "axpf" "sgif" "err" + "x86f" "lbytef" "core" ; Lisp "BAK" "CKP" ; Backups & Checkpoints "PS" "ps" "press" "otl" "dvi" "toc" ; Formatting "bbl" "lof" "idx" "lot" "aux" ; Formatting "mo" "elc" ; Other editors "bin" "lbin" ; Obvious binary extensions. - "o" "a" "aout" ; UNIXY stuff + "o" "a" "aout" "out" ; UNIXY stuff "bm" "onx" "snf" ; X stuff - "UU" "uu" "arc" "Z" "tar" ; Binary encoded files + "UU" "uu" "arc" "Z" "gz" "tar" ; Binary encoded files )) diff --git a/hemlock/eval-server.lisp b/hemlock/eval-server.lisp index b174c5511..bc863514b 100644 --- a/hemlock/eval-server.lisp +++ b/hemlock/eval-server.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/eval-server.lisp,v 1.5 1995/02/16 23:04:48 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/eval-server.lisp,v 1.6 1997/01/18 14:31:52 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -724,7 +724,13 @@ (do ((i 0 (1+ i)) (frame (di:top-frame) (di:frame-down frame))) - ((= i 3) + (#-x86(= i 3) + #+x86 + (and (> i 6) ; get past extra cruft + (let ((name (di:debug-function-name + (di:frame-debug-function frame)))) + (and (not (string= name "Bogus stack frame")) + (not (string= name "Foreign function call land"))))) (prin1 (di:debug-function-name (di:frame-debug-function frame)) *error-output*)) (unless frame (return))) diff --git a/hemlock/input.lisp b/hemlock/input.lisp index 710fba2bd..7d4186561 100644 --- a/hemlock/input.lisp +++ b/hemlock/input.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/input.lisp,v 1.5 1995/02/17 21:10:51 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/input.lisp,v 1.6 1997/01/18 14:31:54 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -420,7 +420,7 @@ (let* ((xwindow (make-xwindow-like-hwindow window)) (window (make-window start :window xwindow))) (unless window - (xlib:destroy-window xwindow) + #+clx(xlib:destroy-window xwindow) (editor-error "Could not create random typeout window.")))))) (defun end-random-typeout (stream) diff --git a/hemlock/lisp-lib.lisp b/hemlock/lisp-lib.lisp index 8c1a60217..9b615c157 100644 --- a/hemlock/lisp-lib.lisp +++ b/hemlock/lisp-lib.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/lisp-lib.lisp,v 1.3 1994/10/31 04:50:12 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/lisp-lib.lisp,v 1.4 1997/01/18 14:31:52 ram Rel $") ;;; ;;; ********************************************************************** ;;; @@ -44,7 +44,7 @@ (with-output-to-mark (s (buffer-point *selected-library-buffer*)) (dolist (lib-spec lib-directory) (let* ((path-parts (pathname-directory lib-spec)) - (last (svref path-parts (1- (length path-parts)))) + (last (elt path-parts (1- (length path-parts)))) (raw-pathname (merge-pathnames last lib-spec))) (when (and (directoryp lib-spec) (probe-file (merge-pathnames @@ -141,17 +141,20 @@ error-msg))) (parts (pathname-directory base-name)) (load-name (concatenate 'simple-string - "load-" (svref parts (1- (length parts))))) + "load-" (elt parts (1- (length parts))))) (load-pathname (merge-pathnames load-name base-name)) (file-to-load - (or (probe-file (merge-pathnames (make-pathname :type "fasl") - load-pathname)) - (probe-file (merge-pathnames (make-pathname :type "lisp") - load-pathname)) - (probe-file (merge-pathnames (make-pathname :type "fasl") - base-name)) - (probe-file (merge-pathnames (make-pathname :type "lisp") - base-name))))) + (or + (probe-file (compile-file-pathname load-pathname)) + (probe-file (merge-pathnames (make-pathname :type "fasl") + load-pathname)) + (probe-file (merge-pathnames (make-pathname :type "lisp") + load-pathname)) + (probe-file (compile-file-pathname base-name)) + (probe-file (merge-pathnames (make-pathname :type "fasl") + base-name)) + (probe-file (merge-pathnames (make-pathname :type "lisp") + base-name))))) (unless file-to-load (editor-error "You'll have to load it yourself.")) file-to-load)) diff --git a/hemlock/lispeval.lisp b/hemlock/lispeval.lisp index 47807eea0..955ace8f8 100644 --- a/hemlock/lispeval.lisp +++ b/hemlock/lispeval.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/lispeval.lisp,v 1.4 1994/10/31 04:50:12 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/lispeval.lisp,v 1.5 1997/01/18 14:31:51 ram Rel $") ;;; ;;; ********************************************************************** ;;; @@ -757,12 +757,11 @@ (file-compile tn))))))) (defun older-or-non-existent-fasl-p (pathname &optional definitely) - (let ((obj-pn (probe-file (make-pathname :type "fasl" :defaults pathname)))) + (let ((obj-pn (probe-file (compile-file-pathname pathname)))) (or definitely (not obj-pn) (< (file-write-date obj-pn) (file-write-date pathname))))) - ;;;; Error hacking stuff. diff --git a/hemlock/rompsite.lisp b/hemlock/rompsite.lisp index 161c59695..7c01331cc 100644 --- a/hemlock/rompsite.lisp +++ b/hemlock/rompsite.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/rompsite.lisp,v 1.8 1994/10/31 04:50:12 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/rompsite.lisp,v 1.9 1997/01/18 14:31:48 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -264,7 +264,8 @@ #+clx (defconstant font-map-size 16 "The number of possible fonts in a font-map.") - +#-clx +(defconstant font-map-size 16) ;;; SETUP-FONT-FAMILY sets *default-font-family*, opening the three font names ;;; passed in. The font family structure is filled in from the first argument. @@ -934,7 +935,7 @@ (defvar old-ltchars) -#+(or hpux irix) +#+(or hpux irix freebsd) (progn (defvar old-c-iflag) (defvar old-c-oflag) @@ -945,7 +946,7 @@ (defun setup-input () (let ((fd *editor-file-descriptor*)) (when (unix:unix-isatty 0) - #+(or hpux irix) + #+(or hpux irix freebsd) (alien:with-alien ((tios (alien:struct unix:termios))) (multiple-value-bind (val err) @@ -991,7 +992,7 @@ (when (null val) (error "Could not tcsetattr, unix error ~S." (unix:get-unix-error-msg err))))) - #-(or hpux irix) + #-(or hpux irix freebsd) (alien:with-alien ((sg (alien:struct unix:sgttyb))) (multiple-value-bind (val err) @@ -1002,7 +1003,7 @@ (let ((flags (alien:slot sg 'unix:sg-flags))) (setq old-flags flags) (setf (alien:slot sg 'unix:sg-flags) - (logand #-(or hpux irix) (logior flags unix:tty-cbreak) + (logand #-(or hpux irix freebsd) (logior flags unix:tty-cbreak) (lognot unix:tty-echo) (lognot unix:tty-crmod))) (multiple-value-bind @@ -1011,7 +1012,7 @@ (if (null val) (error "Could not set tty information, unix error ~S." (unix:get-unix-error-msg err)))))) - #-(or hpux irix) + #-(or hpux irix freebsd) (alien:with-alien ((tc (alien:struct unix:tchars))) (multiple-value-bind (val err) @@ -1072,7 +1073,7 @@ (defun reset-input () (when (unix:unix-isatty 0) (let ((fd *editor-file-descriptor*)) - #+(or hpux irix) + #+(or hpux irix freebsd) (when (boundp 'old-c-lflag) (alien:with-alien ((tios (alien:struct unix:termios))) (multiple-value-bind @@ -1109,7 +1110,7 @@ (when (null val) (error "Could not tcsetattr, unix error ~S." (unix:get-unix-error-msg err)))))) - #-(or hpux irix) + #-(or hpux irix freebsd) (when (boundp 'old-flags) (alien:with-alien ((sg (alien:struct unix:sgttyb))) (multiple-value-bind @@ -1125,7 +1126,7 @@ (unless val (error "Could not set tty information, unix error ~S." (unix:get-unix-error-msg err))))))) - #-(or hpux irix) + #-(or hpux irix freebsd) (when (and (boundp 'old-tchars) (simple-vector-p old-tchars) (eq (length old-tchars) 6)) diff --git a/motif/lisp/initial.lisp b/motif/lisp/initial.lisp index a82f53c93..6358c9a53 100644 --- a/motif/lisp/initial.lisp +++ b/motif/lisp/initial.lisp @@ -3,7 +3,9 @@ ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. -;;; If you want to use this code or any part of CMU Common Lisp, please contact;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/motif/lisp/initial.lisp,v 1.3 1997/01/18 14:31:44 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -184,7 +186,7 @@ "COMPOUND-STRING-COMPARE" "COMPOUND-STRING-CONCAT" "COMPOUND-STRING-COPY" "COMPOUND-STRING-CREATE" "COMPOUND-STRING-CREATE-LTOR" "COMPOUND-STRING-CREATE-SIMPLE" - "COMPOUND-STRING-CREATE-EMPTY" "COMPOUND-STRING-CREATE-EXTENT" + "COMPOUND-STRING-CREATE-EMPTY" "COMPOUND-STRING-EXTENT" "COMPOUND-STRING-FREE" "COMPOUND-STRING-HAS-SUBSTRING" "COMPOUND-STRING-HEIGHT" "COMPOUND-STRING-LENGTH" "COMPOUND-LINE-COUNT" "COMPOUND-STRING-NCONCAT" diff --git a/motif/lisp/interface-glue.lisp b/motif/lisp/interface-glue.lisp index de2acdc22..9d0b59d48 100644 --- a/motif/lisp/interface-glue.lisp +++ b/motif/lisp/interface-glue.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/motif/lisp/interface-glue.lisp,v 1.3 1994/10/27 17:44:22 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/motif/lisp/interface-glue.lisp,v 1.4 1997/01/18 14:31:44 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -21,8 +21,7 @@ ;;;; Functions for handling server requests (defvar reply-table - (vector :confirm :values :callback :event :error :warning :protocol :action - :timeout)) + (vector :confirm :values :callback :event :error :warning :protocol :action)) (defun wait-for-server-reply (fd) (wait-for-input fd) @@ -40,7 +39,6 @@ (:protocol (handle-protocol reply)) (:action (handle-action reply)) (:event (handle-event reply)) - (:timeout (handle-timeout reply)) (:error (let ((errmsg (toolkit-read-value reply))) (destroy-message reply) diff --git a/motif/server/Config b/motif/server/Config new file mode 100644 index 000000000..01fa2bcc7 --- /dev/null +++ b/motif/server/Config @@ -0,0 +1,4 @@ +CFLAGS = -O2 -I/usr/X11R6/include -I. -I$(VPATH) +LDFLAGS = -L/usr/X11R6/lib +LIBS = -static -lXm -dynamic -lXt -lXext -lX11 -lSM -lICE +VPATH = ../../../p86/motif/server/:../../../17f/motif/server/ diff --git a/motif/server/GNUmakefile b/motif/server/GNUmakefile index e126e313c..383217e50 100644 --- a/motif/server/GNUmakefile +++ b/motif/server/GNUmakefile @@ -6,7 +6,7 @@ LDFLAGS = TARGET = motifd OBJS = main.o server.o translations.o packet.o message.o datatrans.o \ requests.o callbacks.o widgets.o resources.o tables.o motif.o \ - text.o xmstring.o list.o events.o # timer-support.o + text.o xmstring.o list.o events.o include Config @@ -14,7 +14,7 @@ $(TARGET) : $(OBJS) $(CC) -o $(TARGET) $(LDFLAGS) $(OBJS) $(LIBS) tables.o : tables.c StringTable.h ClassTable.h TypeTable.h - $(CC) $(CFLAGS) -c tables.c + $(CC) $(CFLAGS) -c $< requests.o : requests.c Interface.h - $(CC) $(CFLAGS) -c requests.c + $(CC) $(CFLAGS) -c $< diff --git a/motif/server/main.c b/motif/server/main.c index f1e0a7793..29b4a905a 100644 --- a/motif/server/main.c +++ b/motif/server/main.c @@ -1,6 +1,6 @@ /* - $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/motif/server/main.c,v 1.7 1994/10/30 22:09:49 ram Exp $ + $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/motif/server/main.c,v 1.8 1997/01/18 14:31:42 ram Exp $ This code was written as part of the CMU Common Lisp project at Carnegie Mellon University, and has been placed in the public domain. @@ -8,6 +8,7 @@ */ #include <stdio.h> +#include <sys/param.h> /* for define of BSD */ #include <ctype.h> #include <sys/types.h> #include <sys/socket.h> @@ -20,6 +21,13 @@ #include <sys/wait.h> +#ifdef __linux__ +#include <asm/posix_types.h> +#define FD_ZERO __FD_ZERO +#define FD_SET __FD_SET +#define FD_ISSET __FD_ISSET +#endif + #ifdef SVR4 #define bzero(a,n) memset(a, 0, n) #endif @@ -52,6 +60,18 @@ int use_unix_socket=1; enum { Global, Normal, Local } socket_choice = Normal; +#if defined BSD +void bury_zombie () +{ + /* This is called to handle SIGCHLD. Wait3 lets BSD lay + * the dead child process to rest. Otherwise it hangs + * around until the server dies. During development this can + * eat up a lot of swap space. + */ + int status; + wait3(&status, WNOHANG, NULL); +} +#endif void close_sockets() { close(unix_socket); @@ -223,6 +243,9 @@ main(int argc, char **argv) signal(SIGHUP, server_shutdown); signal(SIGINT, server_shutdown); signal(SIGQUIT, server_shutdown); +#if defined BSD + signal(SIGCHLD, bury_zombie); +#endif printf("Waiting for connection.\n"); fflush(stdout); @@ -233,22 +256,23 @@ main(int argc, char **argv) if( use_unix_socket ) FD_SET(unix_socket, &rfds); if( use_inet_socket ) FD_SET(inet_socket, &rfds); nfound = select(nfds, &rfds, NULL, NULL, 0); - if( nfound < 0 ) + if( nfound < 0 && errno != EINTR ) main_err("main: Unable to select on sockets."); - - if( FD_ISSET(unix_socket, &rfds) ) { - printf("Accepting client on Unix socket.\n"); - fflush(stdout); - establish_client(unix_socket); - } - if( FD_ISSET(inet_socket, &rfds) ) { - printf("Accepting client on Inet socket.\n"); - fflush(stdout); - establish_client(inet_socket); - } - /* Prevent zombie children under Mach */ + else { + if( FD_ISSET(unix_socket, &rfds) ) { + printf("Accepting client on Unix socket.\n"); + fflush(stdout); + establish_client(unix_socket); + } + if( FD_ISSET(inet_socket, &rfds) ) { + printf("Accepting client on Inet socket.\n"); + fflush(stdout); + establish_client(inet_socket); + } + /* Prevent zombie children under Mach */ #ifdef MACH - wait3(&status,WNOHANG,NULL); + wait3(&status,WNOHANG,NULL); #endif + } } } diff --git a/pcl/boot.lisp b/pcl/boot.lisp index aeb7ba960..22fd4edfe 100644 --- a/pcl/boot.lisp +++ b/pcl/boot.lisp @@ -162,7 +162,7 @@ work during bootstrapping. ;;; (defmacro defgeneric (function-specifier lambda-list &body options) (expand-defgeneric function-specifier lambda-list options)) - +#+nil ;; original version (defun expand-defgeneric (function-specifier lambda-list options) (when (listp function-specifier) (do-standard-defsetf-1 (cadr function-specifier))) (let ((initargs ())) @@ -214,6 +214,78 @@ work during bootstrapping. *defgeneric-times* `(load-defgeneric ',function-specifier ',lambda-list ,@initargs))))) +;; pw--Enhanced to support :method options. +(defun expand-defgeneric (function-specifier lambda-list options) + (when (listp function-specifier) + (do-standard-defsetf-1 (cadr function-specifier))) + (let ((initargs ()) + (methods ())) + (flet ((duplicate-option (name) + (error "The option ~S appears more than once." name)) + (define-method(gf-name q-a-b) + (let* ((arg-pos (position-if #'listp q-a-b)) + (arglist (elt q-a-b arg-pos)) + (qualifiers (subseq q-a-b 0 arg-pos)) + (body (nthcdr (1+ arg-pos) q-a-b))) + (when (not (equal (cadr (getf initargs :method-combination)) + qualifiers)) + (error "Bad method specification in defgeneric ~a~%~ + -- qualifier mismatch for lamda list ~a" + gf-name arglist)) + `(defmethod ,gf-name ,@qualifiers ,arglist ,@body)))) + ;; + ;; INITARG takes this screwy new argument to get around a bad + ;; interaction between lexical macros and setf in the Lucid + ;; compiler. + ;; + (macrolet ((initarg (key &optional new) + (if new + `(setf (getf initargs ,key) ,new) + `(getf initargs ,key)))) + (dolist (option options) + (ecase (car option) + (:argument-precedence-order + (if (initarg :argument-precedence-order) + (duplicate-option :argument-precedence-order) + (initarg :argument-precedence-order `',(cdr option)))) + (declare + (initarg :declarations + (append (cdr option) (initarg :declarations)))) + (:documentation + (if (initarg :documentation) + (duplicate-option :documentation) + (initarg :documentation `',(cadr option)))) + (:method-combination + (if (initarg :method-combination) + (duplicate-option :method-combination) + (initarg :method-combination `',(cdr option)))) + (:generic-function-class + (if (initarg :generic-function-class) + (duplicate-option :generic-function-class) + (initarg :generic-function-class `',(cadr option)))) + (:method-class + (if (initarg :method-class) + (duplicate-option :method-class) + (initarg :method-class `',(cadr option)))) + (:method + #+nil + (error + "DEFGENERIC doesn't support the :METHOD option yet.") + (push (cdr option) methods)))) + + (let ((declarations (initarg :declarations))) + (when declarations (initarg :declarations `',declarations)))) + `(progn + (proclaim-defgeneric ',function-specifier ',lambda-list) + ,(make-top-level-form + `(defgeneric ,function-specifier) + *defgeneric-times* + `(load-defgeneric ',function-specifier ',lambda-list ,@initargs)) + ,@(mapcar #'(lambda(m)(define-method `,function-specifier m)) + `,methods) + + `,(function ,function-specifier))))) + (defun load-defgeneric (function-specifier lambda-list &rest initargs) (when (listp function-specifier) (do-standard-defsetf-1 (cadr function-specifier))) (apply #'ensure-generic-function @@ -331,7 +403,8 @@ work during bootstrapping. (let ((sv (eval (cadr s)))) (or (interned-symbol-p sv) (integerp sv) - (standard-char-p sv)))) + (and (characterp sv) + (standard-char-p sv))))) (interned-symbol-p s))) specializers) (consp initargs-form) @@ -580,6 +653,9 @@ work during bootstrapping. (function #'identity :type function) call-method-args) +#+cmu +(declaim (ext:freeze-type method-call)) + (defmacro invoke-method-call1 (function args cm-args) `(let ((.function. ,function) (.args. ,args) @@ -601,6 +677,9 @@ work during bootstrapping. next-method-call arg-info) +#+cmu +(declaim (ext:freeze-type fast-method-call)) + #-akcl (defmacro fmc-funcall (fn pv-cell next-method-call &rest args) `(funcall ,fn ,pv-cell ,next-method-call ,@args)) @@ -614,6 +693,9 @@ work during bootstrapping. (defstruct fast-instance-boundp (index 0 :type fixnum)) +#+cmu +(declaim (ext:freeze-type fast-instance-boundp)) + (eval-when (compile load eval) (defvar *allow-emf-call-tracing-p* nil) (defvar *enable-emf-call-tracing-p* #-testing nil #+testing t) @@ -696,8 +778,9 @@ work during bootstrapping. (invoke-method-call ,emf ,restp ,@required-args+rest-arg)) (function ,(if restp - `(apply ,emf ,@required-args+rest-arg) - `(funcall ,emf ,@required-args+rest-arg)))))))) + `(apply (the function ,emf) ,@required-args+rest-arg) + `(funcall (the function ,emf) + ,@required-args+rest-arg)))))))) (defun invoke-emf (emf args) (trace-emf-call emf t args) @@ -1284,7 +1367,8 @@ work during bootstrapping. (funcall continuation :specialize-it)) (defvar *sgf-wrapper* - (make-wrapper (early-class-size 'standard-generic-function))) + (boot-make-wrapper (early-class-size 'standard-generic-function) + 'standard-generic-function)) (defvar *sgf-slots-init* (mapcar #'(lambda (canonical-slot) @@ -1338,6 +1422,9 @@ work during bootstrapping. (gf-info-c-a-m-emf-std-p t) gf-info-fast-mf-p) +#+cmu +(declaim (ext:freeze-type arg-info)) + (defun arg-info-valid-p (arg-info) (not (null (arg-info-number-optional arg-info)))) @@ -1351,6 +1438,13 @@ work during bootstrapping. (defun arg-info-nkeys (arg-info) (count-if #'(lambda (x) (neq x 't)) (arg-info-metatypes arg-info))) +;;; Keep pages clean by not setting if the value is already the same. +(defmacro esetf (pos val) + (let ((valsym (gensym "value"))) + `(let ((,valsym ,val)) + (unless (equal ,pos ,valsym) + (setf ,pos ,valsym))))) + (defun set-arg-info (gf &key new-method (lambda-list nil lambda-list-p) argument-precedence-order) (let* ((arg-info (if (eq *boot-state* 'complete) @@ -1378,18 +1472,19 @@ work during bootstrapping. existing methods of ~S." lambda-list gf)))) (when lambda-list-p - (setf (arg-info-lambda-list arg-info) lambda-list)) + (esetf (arg-info-lambda-list arg-info) lambda-list)) (when (or lambda-list-p argument-precedence-order (null (arg-info-precedence arg-info))) - (setf (arg-info-precedence arg-info) - (compute-precedence lambda-list nreq argument-precedence-order))) - (setf (arg-info-metatypes arg-info) (make-list nreq)) - (setf (arg-info-number-optional arg-info) nopt) - (setf (arg-info-key/rest-p arg-info) (not (null (or keysp restp)))) - (setf (arg-info-keywords arg-info) - (if lambda-list-p - (if allow-other-keys-p t keywords) - (arg-info-key/rest-p arg-info))))) + (esetf (arg-info-precedence arg-info) + (compute-precedence lambda-list nreq + argument-precedence-order))) + (esetf (arg-info-metatypes arg-info) (make-list nreq)) + (esetf (arg-info-number-optional arg-info) nopt) + (esetf (arg-info-key/rest-p arg-info) (not (null (or keysp restp)))) + (esetf (arg-info-keywords arg-info) + (if lambda-list-p + (if allow-other-keys-p t keywords) + (arg-info-key/rest-p arg-info))))) (when new-method (check-method-arg-info gf arg-info new-method)) (set-arg-info1 gf arg-info new-method methods was-valid-p first-p) @@ -1457,41 +1552,43 @@ work during bootstrapping. (setq type (cond ((null type) new-type) ((eq type new-type) type) (t nil))))) - (setf (arg-info-metatypes arg-info) metatypes) - (setf (gf-info-simple-accessor-type arg-info) type))) + (esetf (arg-info-metatypes arg-info) metatypes) + (esetf (gf-info-simple-accessor-type arg-info) type))) (when (or (not was-valid-p) first-p) (multiple-value-bind (c-a-m-emf std-p) (if (early-gf-p gf) (values t t) (compute-applicable-methods-emf gf)) - (setf (gf-info-static-c-a-m-emf arg-info) c-a-m-emf) - (setf (gf-info-c-a-m-emf-std-p arg-info) std-p) + (esetf (gf-info-static-c-a-m-emf arg-info) c-a-m-emf) + (esetf (gf-info-c-a-m-emf-std-p arg-info) std-p) (unless (gf-info-c-a-m-emf-std-p arg-info) - (setf (gf-info-simple-accessor-type arg-info) t)))) + (esetf (gf-info-simple-accessor-type arg-info) t)))) (unless was-valid-p (let ((name (if (eq *boot-state* 'complete) (generic-function-name gf) (early-gf-name gf)))) - (setf (gf-precompute-dfun-and-emf-p arg-info) - (let* ((sym (if (atom name) name (cadr name))) - (pkg-list (cons *the-pcl-package* - (package-use-list *the-pcl-package*)))) - (and sym (symbolp sym) - (not (null (memq (symbol-package sym) pkg-list))) - (not (find #\space (symbol-name sym)))))))) - (setf (gf-info-fast-mf-p arg-info) - (or (not (eq *boot-state* 'complete)) - (let* ((method-class (generic-function-method-class gf)) - (methods (compute-applicable-methods - #'make-method-lambda - (list gf (class-prototype method-class) - '(lambda) nil)))) - (and methods (null (cdr methods)) - (let ((specls (method-specializers (car methods)))) - (and (classp (car specls)) - (eq 'standard-generic-function (class-name (car specls))) - (classp (cadr specls)) - (eq 'standard-method (class-name (cadr specls))))))))) + (esetf (gf-precompute-dfun-and-emf-p arg-info) + (let* ((sym (if (atom name) name (cadr name))) + (pkg-list (cons *the-pcl-package* + (package-use-list *the-pcl-package*)))) + (and sym (symbolp sym) + (not (null (memq (symbol-package sym) pkg-list))) + (not (find #\space (symbol-name sym)))))))) + (esetf (gf-info-fast-mf-p arg-info) + (or (not (eq *boot-state* 'complete)) + (let* ((method-class (generic-function-method-class gf)) + (methods (compute-applicable-methods + #'make-method-lambda + (list gf (class-prototype method-class) + '(lambda) nil)))) + (and methods (null (cdr methods)) + (let ((specls (method-specializers (car methods)))) + (and (classp (car specls)) + (eq 'standard-generic-function + (class-name (car specls))) + (classp (cadr specls)) + (eq 'standard-method + (class-name (cadr specls))))))))) arg-info) ;;; @@ -1526,10 +1623,10 @@ work during bootstrapping. fin (or function (if (eq spec 'print-object) - #'(lambda (instance stream) + #'(#+cmu kernel:instance-lambda #-cmu lambda (instance stream) (printing-random-thing (instance stream) (format stream "std-instance"))) - #'(lambda (&rest args) + #'(#+cmu kernel:instance-lambda #-cmu lambda (&rest args) (declare (ignore args)) (error "The function of the funcallable-instance ~S~ has not been set" fin))))) @@ -2144,6 +2241,7 @@ work during bootstrapping. slots) ,@body)))) + (defmacro with-accessors (slots instance &body body) (let ((in (gensym))) `(let ((,in ,instance)) diff --git a/pcl/braid.lisp b/pcl/braid.lisp index b05bd2db4..1aea28cc0 100644 --- a/pcl/braid.lisp +++ b/pcl/braid.lisp @@ -41,8 +41,8 @@ #-new-kcl-wrapper (let ((instance (%%allocate-instance--class)) (no-of-slots (wrapper-no-of-instance-slots wrapper))) - (setf (%std-instance-wrapper instance) wrapper) - (setf (%std-instance-slots instance) + (setf (std-instance-wrapper instance) wrapper) + (setf (std-instance-slots instance) (if slots-init-p (make-array no-of-slots :initial-contents slots-init) (make-array no-of-slots :initial-element *slot-unbound*))) @@ -75,10 +75,11 @@ (defun allocate-funcallable-instance (wrapper &optional (slots-init nil slots-init-p)) (let ((fin (allocate-funcallable-instance-1))) (set-funcallable-instance-function - fin #'(lambda (&rest args) - (declare (ignore args)) - (error "The function of the funcallable-instance ~S has not been set" - fin))) + fin + #'(#+cmu kernel:instance-lambda #-cmu lambda (&rest args) + (declare (ignore args)) + (error "The function of the funcallable-instance ~S has not been set" + fin))) (setf (fsc-instance-wrapper fin) wrapper (fsc-instance-slots fin) (allocate-funcallable-instance-slots wrapper slots-init-p slots-init)) @@ -113,7 +114,12 @@ *the-pcl-package*))) `(setf ,wr ,(if (eq class 'standard-generic-function) '*sgf-wrapper* - `(make-wrapper (early-class-size ',class))) + #-cmu17 + `(make-wrapper (early-class-size ',class)) + #+cmu17 + `(boot-make-wrapper + (early-class-size ',class) + ',class)) ,class (allocate-standard-instance ,(if (eq class 'standard-generic-function) 'funcallable-standard-class-wrapper @@ -197,7 +203,11 @@ class-eq-specializer-wrapper) ((eq class standard-generic-function) standard-generic-function-wrapper) - (t (make-wrapper (length slots) class)))) + (t + #-cmu17 + (make-wrapper (length slots) class) + #+cmu17 + (boot-make-wrapper (length slots) name)))) (proto nil)) (when (eq name 't) (setq *the-wrapper-of-t* wrapper)) (set (intern (format nil "*THE-CLASS-~A*" (symbol-name name)) @@ -207,10 +217,11 @@ (unless (eq (getf slot :allocation :instance) :instance) (error "Slot allocation ~S not supported in bootstrap."))) - (setf (wrapper-instance-slots-layout wrapper) - (mapcar #'canonical-slot-name slots)) - (setf (wrapper-class-slots wrapper) - ()) + (when #+cmu17 (typep wrapper 'wrapper) #-cmu17 t + (setf (wrapper-instance-slots-layout wrapper) + (mapcar #'canonical-slot-name slots)) + (setf (wrapper-class-slots wrapper) + ())) (setq proto (if (eq meta 'funcallable-standard-class) (allocate-funcallable-instance wrapper) @@ -460,10 +471,15 @@ (dolist (e *built-in-classes*) (destructuring-bind (name supers subs cpl prototype) e (let* ((class (find-class name)) - (wrapper (make-wrapper 0 class))) + #+cmu17 + (lclass (lisp:find-class name)) + (wrapper #-cmu17(make-wrapper 0 class) + #+cmu17(kernel:class-layout lclass))) (set (get-built-in-class-symbol name) class) (set (get-built-in-wrapper-symbol name) wrapper) - + #+cmu17 + (setf (kernel:class-pcl-class lclass) class) + #-cmu17 (setf (wrapper-instance-slots-layout wrapper) () (wrapper-class-slots wrapper) ()) @@ -483,7 +499,7 @@ ;;; ;;; ;;; -#-new-kcl-wrapper +#-(or new-kcl-wrapper cmu17) (progn (defvar *built-in-or-structure-wrapper-table* (make-hash-table :test 'eq)) @@ -541,6 +557,7 @@ (built-in-or-structure-wrapper1 ,x))))) ||# +#-cmu17 (defmacro wrapper-of-macro (x) `(cond ((std-instance-p ,x) (std-instance-wrapper ,x)) @@ -551,12 +568,19 @@ #-new-kcl-wrapper built-in-or-structure-wrapper ,x)))) +#+cmu17 +(defmacro wrapper-of-macro (x) + `(kernel:layout-of ,x)) + (defun class-of (x) (wrapper-class* (wrapper-of-macro x))) +#+cmu17 +(declaim (inline wrapper-of)) (defun wrapper-of (x) (wrapper-of-macro x)) +#-cmu17 (defun structure-wrapper (x) (class-wrapper (find-class (structure-type x)))) @@ -582,13 +606,18 @@ :metaclass 'structure-class :name symbol :direct-superclasses - (when (structure-type-included-type-name symbol) - (list (structure-type-included-type-name symbol))) + (cond ((lisp:subtypep symbol 'condition) + (list (lisp:class-name + (first (kernel:class-direct-superclasses + (lisp:find-class symbol)))))) + ((structure-type-included-type-name symbol) + (list (structure-type-included-type-name symbol)))) :direct-slots (mapcar #'slot-initargs-from-structure-slotd (structure-type-slot-description-list symbol))))) (error "~S is not a legal structure class name." symbol))) +#-cmu17 (eval-when (compile eval) (defun make-built-in-class-subs () @@ -631,6 +660,7 @@ symbol))))) ) +#-cmu17 (defun built-in-wrapper-of (x) #.(when (fboundp 'make-built-in-wrapper-of-body) ; so we can at least read this file (make-built-in-wrapper-of-body))) @@ -676,6 +706,20 @@ (add-method gf class-method))) gf)) + +#+cmu17 +;;; Set inherits from CPL and register layout. This actually installs the +;;; class in the lisp type system. +;;; +(defun update-lisp-class-layout (class layout) + (unless (eq (kernel:class-layout (kernel:layout-class layout)) + layout) + (setf (kernel:layout-inherits layout) + (map 'vector #'class-wrapper + (reverse (rest (class-precedence-list class))))) + + (kernel:register-layout layout :invalidate nil))) + (eval-when (load eval) (clrhash *find-class*) (bootstrap-meta-braid) @@ -684,9 +728,29 @@ (bootstrap-accessor-definitions nil) (bootstrap-class-predicates nil) (bootstrap-built-in-classes) + + #+cmu17 + (ext:do-hash (name x *find-class*) + (let* ((class (find-class-from-cell name x)) + (layout (class-wrapper class)) + (lclass (kernel:layout-class layout)) + (lclass-pcl-class (kernel:class-pcl-class lclass)) + (olclass (lisp:find-class name nil))) + (if lclass-pcl-class + (assert (eq class lclass-pcl-class)) + (setf (kernel:class-pcl-class lclass) class)) + + (update-lisp-class-layout class layout) + + (cond (olclass + (assert (eq lclass olclass))) + (t + (setf (lisp:find-class name) lclass))))) + (setq *boot-state* 'braid) ) +#-cmu17 (deftype slot-object () '(or standard-object structure-object)) diff --git a/pcl/cmu-low.lisp b/pcl/cmu-low.lisp index 87bceaa3a..6b65568fa 100644 --- a/pcl/cmu-low.lisp +++ b/pcl/cmu-low.lisp @@ -29,6 +29,10 @@ (in-package :pcl) +#+small +(setq *optimize-speed* + '(optimize (speed 3) (safety 0) (debug 0.5) (ext:inhibit-warnings 3))) + (defmacro dotimes ((var count &optional (result nil)) &body body) `(lisp:dotimes (,var (the fixnum ,count) ,result) (declare (fixnum ,var)) @@ -40,19 +44,6 @@ (defmacro without-interrupts (&rest stuff) `(sys:without-interrupts ,@stuff)) - -;;; Print the object addr in default printers. -;;; -(defun printing-random-thing-internal (thing stream) - (format stream "{~X}" (sys:%primitive c:make-fixnum thing))) - - -(eval-when (compile load eval) - (c:def-source-transform std-instance-p (x) - (ext:once-only ((n-x x)) - `(and (ext:structurep ,n-x) - (eq (kernel:structure-ref ,n-x 0) 'std-instance))))) - (defun function-arglist (fcn) "Returns the argument list of a compiled function, if possible." (cond ((symbolp fcn) @@ -64,38 +55,59 @@ (let ((lambda-expr (function-lambda-expression fcn))) (if lambda-expr (cadr lambda-expr) - (let ((function (kernel:%closure-function fcn))) - (values (read-from-string - (kernel:%function-header-arglist function))))))))) - - -;;; We have this here and in fin.lisp, 'cause PCL wants to compile this -;;; file first. -;;; -(defsetf funcallable-instance-name set-funcallable-instance-name) + (let* ((function (kernel:%closure-function fcn)) + (arglist-string (kernel:%function-arglist function))) + (when arglist-string + (values (read-from-string arglist-string))))))))) ;;; And returns the function, not the *name*. (defun set-function-name (fcn new-name) "Set the name of a compiled function object." + (declare (special *boot-state* *the-class-standard-generic-function*)) (cond ((symbolp fcn) (set-function-name (symbol-function fcn) new-name)) ((funcallable-instance-p fcn) - (setf (funcallable-instance-name fcn) new-name) + (if (if (eq *boot-state* 'complete) + (typep fcn 'generic-function) + (eq (class-of fcn) *the-class-standard-generic-function*)) + (setf (kernel:%funcallable-instance-info fcn 1) new-name) + (typecase fcn + (kernel:byte-closure + (set-function-name (kernel:byte-closure-function fcn) new-name)) + (kernel:byte-function + (setf (kernel:byte-function-name fcn) new-name)))) fcn) ((eval:interpreted-function-p fcn) (setf (eval:interpreted-function-name fcn) new-name) fcn) (t + ;; pw-- This seems wrong and causes trouble. Tests show + ;; that loading CL-HTTP resulted in ~5400 closures being + ;; passed through this code of which ~4000 of them pointed + ;; to but 16 closure-functions, including 1015 each of + ;; DEFUN MAKE-OPTIMIZED-STD-WRITER-METHOD-FUNCTION + ;; DEFUN MAKE-OPTIMIZED-STD-READER-METHOD-FUNCTION + ;; DEFUN MAKE-OPTIMIZED-STD-BOUNDP-METHOD-FUNCTION. + ;; Since the actual functions have been moved by PURIFY + ;; to memory not seen by GC, changing a pointer there + ;; not only clobbers the last change but leaves a dangling + ;; pointer invalid after the next GC. Comments in low.lisp + ;; indicate this code need do nothing. Setting the + ;; function-name to NIL loses some info, and not changing + ;; it loses some info of potential hacking value. So, + ;; lets not do this... + #+nil (let ((header (kernel:%closure-function fcn))) #+cmu17 (setf (c::%function-name header) new-name) #-cmu17 (system:%primitive c::set-function-name header new-name)) + + ;; Maybe add better scheme here someday. fcn))) (in-package "C") -;;From compiler/ir1util (def-source-context pcl:defmethod (name &rest stuff) (let ((arg-pos (position-if #'listp stuff))) (if arg-pos @@ -104,356 +116,64 @@ (elt stuff arg-pos)))) `(pcl:defmethod ,name "<illegal syntax>")))) -(define-info-type type kind (member :primitive :defined :structure :class nil) - (if (or (info type builtin name) - (info type translator name)) - :primitive - nil)) -(define-info-type type class-info (or pcl::class symbol null) nil) - -(in-package "KERNEL") - -(export '(clos-type clos-type-class)) - -(defmacro cold-load-init (&rest forms) - `(progn ,@forms)) - -(defstruct (clos-type (:include ctype - (:class-info (type-class-or-lose 'clos)) - (:enumerable t)) - (:print-function %print-type)) - ;; - ;; The CLOS class. - (class nil)) - -(define-type-class clos) - -(define-type-method (clos :unparse) (x) - (clos-type-class x)) - -(define-type-method (clos :complex-union) (type1 type2) - (make-union-type (list type1 type2))) - -(define-type-method (clos :simple-=) (type1 type2) - (values (eq (clos-type-class type1) - (clos-type-class type2)) - t)) - -(define-type-method (clos :simple-subtypep) (type1 type2) - (let ((class1 (pcl:find-class (clos-type-class type1) nil)) - (class2 (pcl:find-class (clos-type-class type2) nil))) - (if (and class1 class2) - (values (member class2 - (pcl:class-precedence-list class2)) t) - (values nil nil)))) - -;; Add the new ctype to its supertypes. -;; -(let ((the-type-* (values-specifier-type '*))) - (pushnew 'clos (named-type-subclasses the-type-*))) -(let ((the-type-t (values-specifier-type 't))) - (pushnew 'clos (named-type-subclasses the-type-t))) - -(defun-cached (values-specifier-type - :hash-function (lambda (x) - (the fixnum - (logand (the fixnum (cache-hash-eq x)) - #x3FF))) - :hash-bits 10) - ((spec eq)) - (or (info type builtin spec) - (let ((expand (type-expand spec))) - (if (eq expand spec) - (let* ((lspec (if (atom spec) (list spec) spec)) - (fun (info type translator (car lspec)))) - (cond - (fun (funcall fun lspec)) - ((and (symbolp spec) - (eq (info type kind spec) :structure)) - (make-structure-type :name spec)) - ((and (symbolp spec) - (eq (info type kind spec) :class)) - (make-clos-type :class spec)) - ((or (and (consp spec) (symbolp (car spec))) - (symbolp spec)) - (signal 'parse-unknown-type :specifier spec) - ;; - ;; Inhibit caching... - (return-from values-specifier-type - (make-unknown-type :specifier spec))) - (t - (error "Bad thing to be a type specifier: ~S." - spec)))) - (values-specifier-type expand))))) - -(defun ctypep (obj type) - (declare (type ctype type)) - (etypecase type - ((or numeric-type named-type member-type array-type) - (values (typep obj (type-specifier type)) t)) - (structure-type - (if (structurep obj) - (let* ((name (structure-type-name type)) - (info (info type structure-info name)) - (defined-info (info type defined-structure-info name))) - (if (and info defined-info - (equal (c::dd-includes info) - (c::dd-includes defined-info))) - (values (typep obj name) t) - (values nil nil))) - (values nil t))) - (clos-type - (let ((class (clos-type-class type))) - (if (pcl::std-instance-p obj) - (values (pcl::*typep obj class) t) - (values nil t)))) - (union-type - (dolist (mem (union-type-types type) (values nil t)) - (multiple-value-bind (val win) - (ctypep obj mem) - (unless win (return (values nil nil))) - (when val (return (values t t)))))) - (function-type - (values (functionp obj) t)) - (unknown-type - (values nil nil)) - (alien-type-type - (values (alien-typep obj (alien-type-type-alien-type type)) t)) - (hairy-type - ;; Now the tricky stuff. - (let* ((hairy-spec (hairy-type-specifier type)) - (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec))) - (ecase symbol - (and - (if (atom hairy-spec) - (values t t) - (dolist (spec (cdr hairy-spec) (values t t)) - (multiple-value-bind (res win) - (ctypep obj (specifier-type spec)) - (unless win (return (values nil nil))) - (unless res (return (values nil t))))))) - (not - (multiple-value-bind - (res win) - (ctypep obj (specifier-type (cadr hairy-spec))) - (if win - (values (not res) t) - (values nil nil)))) - (satisfies - (let ((fun (second hairy-spec))) - (cond ((and (consp fun) (eq (car fun) 'lambda)) - (values (not (null (funcall (coerce fun 'function) obj))) - t)) - ((and (symbolp fun) (fboundp fun)) - (values (not (null (funcall fun obj))) t)) - (t - (values nil nil)))))))))) - -(in-package "LISP") - -(defun %%typep (object type) - (declare (type ctype type)) - (etypecase type - (named-type - (ecase (named-type-name type) - ((* t) - t) - ((nil) - nil) - (character (characterp object)) - (base-char (base-char-p object)) - (standard-char (and (characterp object) (standard-char-p object))) - (extended-char - (and (characterp object) (not (base-char-p object)))) - (function (functionp object)) - (cons (consp object)) - (symbol (symbolp object)) - (keyword - (and (symbolp object) - (eq (symbol-package object) - (symbol-package :foo)))) - (system-area-pointer (system-area-pointer-p object)) - (weak-pointer (weak-pointer-p object)) - (code-component (code-component-p object)) - (lra (lra-p object)) - (fdefn (fdefn-p object)) - (scavenger-hook (scavenger-hook-p object)) - (structure (structurep object)))) - (numeric-type - (and (numberp object) - (let ((num (if (complexp object) (realpart object) object))) - (ecase (numeric-type-class type) - (integer (integerp num)) - (rational (rationalp num)) - (float - (ecase (numeric-type-format type) - (short-float (typep object 'short-float)) - (single-float (typep object 'single-float)) - (double-float (typep object 'double-float)) - (long-float (typep object 'long-float)) - ((nil) (floatp num)))) - ((nil) t))) - (flet ((bound-test (val) - (let ((low (numeric-type-low type)) - (high (numeric-type-high type))) - (and (cond ((null low) t) - ((listp low) (> val (car low))) - (t (>= val low))) - (cond ((null high) t) - ((listp high) (< val (car high))) - (t (<= val high))))))) - (ecase (numeric-type-complexp type) - ((nil) t) - (:complex - (and (complexp object) - (bound-test (realpart object)) - (bound-test (imagpart object)))) - (:real - (and (not (complexp object)) - (bound-test object))))))) - (array-type - (and (arrayp object) - (ecase (array-type-complexp type) - ((t) (not (typep object 'simple-array))) - ((nil) (typep object 'simple-array)) - (* t)) - (or (eq (array-type-dimensions type) '*) - (do ((want (array-type-dimensions type) (cdr want)) - (got (array-dimensions object) (cdr got))) - ((and (null want) (null got)) t) - (unless (and want got - (or (eq (car want) '*) - (= (car want) (car got)))) - (return nil)))) - (or (eq (array-type-element-type type) *wild-type*) - (type= (array-type-specialized-element-type type) - (specifier-type (array-element-type object)))))) - (member-type - (if (member object (member-type-members type)) t)) - (structure-type - (structure-typep object (structure-type-name type))) - (clos-type - (pcl::*typep object (clos-type-class type))) - (union-type - (dolist (type (union-type-types type)) - (when (%%typep object type) - (return t)))) - (unknown-type - ;; Type may be unknown to the compiler (and SPECIFIER-TYPE), yet be - ;; a defined structure in the core. - (let ((orig-spec (unknown-type-specifier type))) - (if (and (symbolp orig-spec) - (info type defined-structure-info orig-spec)) - (structure-typep object orig-spec) - (error "Unknown type specifier: ~S" orig-spec)))) - (hairy-type - ;; Now the tricky stuff. - (let* ((hairy-spec (hairy-type-specifier type)) - (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec))) - (ecase symbol - (and - (or (atom hairy-spec) - (dolist (spec (cdr hairy-spec) t) - (unless (%%typep object (specifier-type spec)) - (return nil))))) - (not - (unless (and (listp hairy-spec) (= (length hairy-spec) 2)) - (error "Invalid type specifier: ~S" hairy-spec)) - (not (%%typep object (specifier-type (cadr hairy-spec))))) - (satisfies - (unless (and (listp hairy-spec) (= (length hairy-spec) 2)) - (error "Invalid type specifier: ~S" hairy-spec)) - (let ((fn (cadr hairy-spec))) - (if (funcall (typecase fn - (function fn) - (symbol (symbol-function fn)) - (t - (coerce fn 'function))) - object) - t - nil)))))) - (alien-type-type - (alien-internals:alien-typep object (alien-type-type-alien-type type))) - (function-type - (error "Function types are not a legal argument to TYPEP:~% ~S" - (type-specifier type))))) - -(defun %deftype (name expander &optional doc) - (ecase (info type kind name) - (:primitive - (error "Illegal to redefine standard type: ~S." name)) - (:structure - (warn "Redefining structure type ~S with DEFTYPE." name) - (c::undefine-structure (info type structure-info name))) - (:class - (warn "Redefining class ~S with DEFTYPE." name)) - ((nil :defined))) - (setf (info type kind name) :defined) - (setf (info type expander name) expander) - (when doc - (setf (documentation name 'type) doc)) - ;; ### Bootstrap hack -- we need to define types before %note-type-defined - ;; is defined. - (when (fboundp 'c::%note-type-defined) - (c::%note-type-defined name)) - name) - -(defun type-of (object) - "Return the type of OBJECT." - (typecase object - ;; First the ones that we can tell by testing the lowtag - (fixnum 'fixnum) - (function (type-specifier (ctype-of object))) - (null 'null) - (list 'cons) - - ;; Any other immediates. - (character - (typecase object - (standard-char 'standard-char) - (base-char 'base-char) - (t 'character))) - - ;; And now for the complicated ones. - (number - (etypecase object - (fixnum 'fixnum) - (bignum 'bignum) - (float - (etypecase object - (double-float 'double-float) - (single-float 'single-float) - (short-float 'short-float) - (long-float 'long-float))) - (ratio 'ratio) - (complex 'complex))) - (symbol - (if (eq (symbol-package object) - (symbol-package :foo)) - 'keyword - 'symbol)) - (structure - (let ((name (structure-ref object 0))) - (case name - (pcl::std-instance - (pcl:class-name (pcl:class-of object))) - (alien-internals:alien-value - `(alien:alien - ,(alien-internals:unparse-alien-type - (alien-internals:alien-value-type object)))) - (t name)))) - (array (type-specifier (ctype-of object))) - (system-area-pointer 'system-area-pointer) - (weak-pointer 'weak-pointer) - (code-component 'code-component) - (lra 'lra) - (fdefn 'fdefn) - (scavenger-hook 'scavenger-hook) - (t - (warn "Can't figure out the type of ~S" object) - t))) (in-package "PCL") + +;;;; STD-INSTANCE + +;;; Under CMU17 conditional, STD-INSTANCE-P is only used to discriminate +;;; between functions (including FINs) and normal instances, so we can return +;;; true on structures also. A few uses of (or std-instance-p fsc-instance-p) +;;; are changed to pcl-instance-p. +;;; +(defmacro std-instance-p (x) + `(kernel:%instancep ,x)) +(defmacro pcl-instance-p (x) + `(typep (kernel:layout-of ,x) 'wrapper)) + + +;;; We define this as STANDARD-INSTANCE, since we're going to clobber the +;;; layout with some standard-instance layout as soon as we make it, and we +;;; want the accesor to still be type-correct. +;;; +(defstruct (standard-instance + (:predicate nil) + (:constructor %%allocate-instance--class ()) + (:alternate-metaclass kernel:instance lisp:standard-class + kernel:make-standard-class)) + (slots nil)) + +;;; Both of these operations "work" on structures, which allows the above +;;; weakening of std-instance-p. +;;; +(defmacro std-instance-slots (x) `(kernel:%instance-ref ,x 1)) +(defmacro std-instance-wrapper (x) `(kernel:%instance-layout ,x)) + +(defmacro built-in-or-structure-wrapper (x) `(kernel:layout-of ,x)) + +(defmacro get-wrapper (inst) + (ext:once-only ((wrapper `(wrapper-of ,inst))) + `(progn + (assert (typep ,wrapper 'wrapper) () "What kind of instance is this?") + ,wrapper))) + +(defmacro get-instance-wrapper-or-nil (inst) + (ext:once-only ((wrapper `(wrapper-of ,inst))) + `(if (typep ,wrapper 'wrapper) + ,wrapper + nil))) + +;;; get-slots harmless + +(defmacro get-slots-or-nil (inst) + (ext:once-only ((n-inst inst)) + `(when (pcl-instance-p ,n-inst) + (if (std-instance-p ,n-inst) + (std-instance-slots ,n-inst) + (fsc-instance-slots ,n-inst))))) + + +;;;; Structure-instance stuff: (pushnew :structure-wrapper *features*) @@ -461,41 +181,51 @@ t) (defun structure-instance-p (x) - (and (structurep x) - (not (eq (kernel:structure-ref x 0) 'std-instance)))) + (typep x 'lisp:structure-object)) + +(defun structurep (x) + (typep x 'lisp:structure-object)) (defun structure-type (x) - (kernel:structure-ref x 0)) + (lisp:class-name (kernel:layout-class (kernel:%instance-layout x)))) + (defun structure-type-p (type) - (not (null (ext:info c::type c::defined-structure-info type)))) + (and (symbolp type) + (let ((class (lisp:find-class type nil))) + (and class + (typep (kernel:layout-info (kernel:class-layout class)) + 'kernel:defstruct-description))))) + +(defun get-structure-dd (type) + (kernel:layout-info (kernel:class-layout (lisp:find-class type)))) (defun structure-type-included-type-name (type) - (let ((include (c::dd-include (ext:info c::type c::defined-structure-info type)))) + (let ((include (kernel::dd-include (get-structure-dd type)))) (if (consp include) (car include) include))) (defun structure-type-slot-description-list (type) (nthcdr (length (let ((include (structure-type-included-type-name type))) - (and include (structure-type-slot-description-list include)))) - (c::dd-slots (ext:info c::type c::defined-structure-info type)))) + (and include (kernel:dd-slots (get-structure-dd include))))) + (kernel:dd-slots (get-structure-dd type)))) (defun structure-slotd-name (slotd) - (intern (c::dsd-%name slotd) "USER")) + (kernel:dsd-name slotd)) (defun structure-slotd-accessor-symbol (slotd) - (c::dsd-accessor slotd)) + (kernel:dsd-accessor slotd)) (defun structure-slotd-reader-function (slotd) - (fdefinition (c::dsd-accessor slotd))) + (fdefinition (kernel:dsd-accessor slotd))) (defun structure-slotd-writer-function (slotd) - (unless (c::dsd-read-only slotd) - (fdefinition `(setf ,(c::dsd-accessor slotd))))) + (unless (kernel:dsd-read-only slotd) + (fdefinition `(setf ,(kernel:dsd-accessor slotd))))) (defun structure-slotd-type (slotd) - (c::dsd-type slotd)) + (kernel:dsd-type slotd)) (defun structure-slotd-init-form (slotd) - (c::dsd-default slotd)) + (kernel::dsd-default slotd)) diff --git a/pcl/defcombin.lisp b/pcl/defcombin.lisp index 61222ad44..3680599e9 100644 --- a/pcl/defcombin.lisp +++ b/pcl/defcombin.lisp @@ -107,10 +107,14 @@ :qualifiers () :specializers specializers :lambda-list '(generic-function type options) - :function #'(lambda (gf type options) - (declare (ignore gf)) - (do-short-method-combination - type options operator ioa new-method doc)) + :function #'(lambda(args nms &rest cm-args) + (declare (ignore nms cm-args)) + (apply + #'(lambda (gf type options) + (declare (ignore gf)) + (do-short-method-combination + type options operator ioa new-method doc)) + args)) :definition-source `((define-method-combination ,type) ,truename))) (when old-method (remove-method #'find-method-combination old-method)) @@ -222,14 +226,17 @@ :qualifiers () :specializers specializers :lambda-list '(generic-function type options) - :function #'(lambda (generic-function type options) - (declare (ignore generic-function)) - (make-instance 'long-method-combination - :type type - :documentation doc - :options options)) - :definition-source `((define-method-combination ,type) - ,(load-truename))))) + :function #'(lambda (args nms &rest cm-args) + (declare (ignore nms cm-args)) + (apply + #'(lambda (generic-function type options) + (declare (ignore generic-function options)) + (make-instance 'long-method-combination + :type type + :documentation doc)) + args)) + :definition-source `((define-method-combination ,type) + ,(load-truename))))) (setf (gethash type *long-method-combination-functions*) function) (when old-method (remove-method #'find-method-combination old-method)) (add-method #'find-method-combination new-method))) diff --git a/pcl/dfun.lisp b/pcl/dfun.lisp index ef35e338c..fb4f67e4b 100644 --- a/pcl/dfun.lisp +++ b/pcl/dfun.lisp @@ -325,6 +325,10 @@ And so, we are saved. #'(lambda (new arg) (declare (pcl-fast-call)) (accessor-miss gf new arg dfun-info))))) + +#+cmu +(declaim (ext:freeze-type dfun-info)) + ;;; ;;; ONE-CLASS-ACCESSOR @@ -552,24 +556,111 @@ And so, we are saved. (defun use-dispatch-dfun-p (gf &optional (caching-p (use-caching-dfun-p gf))) (when (eq *boot-state* 'complete) (unless caching-p - (let* ((methods (generic-function-methods gf)) - (arg-info (gf-arg-info gf)) - (mt (arg-info-metatypes arg-info)) - (nreq (length mt))) - ;;Is there a position at which every specializer is eql or non-standard? - (dotimes (i nreq nil) - (when (not (eq 't (nth i mt))) - (let ((some-std-class-specl-p nil)) - (dolist (method methods) - (let ((specl (nth i (method-specializers method)))) - (when (and (not (eql-specializer-p specl)) - (let ((sclass (specializer-class specl))) - (or (null (class-finalized-p sclass)) - (member *the-class-standard-object* - (class-precedence-list sclass))))) - (setq some-std-class-specl-p t)))) - (unless some-std-class-specl-p - (return-from use-dispatch-dfun-p t))))))))) + ;; This should return T when almost all dispatching is by + ;; eql specializers or built-in classes. In other words, + ;; return NIL if we might ever need to do more than + ;; one (non built-in) typep. + ;; Otherwise, it is probably at least as fast to use + ;; a caching dfun first, possibly followed by secondary dispatching. + + #||;;; Original found in cmu 17f -- S L O W + (< (dispatch-dfun-cost gf) (caching-dfun-cost gf)) + ||# + ;; This uses improved dispatch-dfun-cost below + (let ((cdc (caching-dfun-cost gf))) ; fast + (> cdc (dispatch-dfun-cost gf cdc)))))) + +;; Try this on print-object, find-method-combination, and documentation. +;; Look at pcl/generic-functions.lisp for other potential test cases. +(defun show-dfun-costs (gf) + (when (or (symbolp gf) (consp gf)) + (setq gf (fdefinition gf))) + (format t "~&Name ~S caching cost ~D dispatch cost ~D~%" + (generic-function-name gf) + (caching-dfun-cost gf) + (dispatch-dfun-cost gf))) + +(defparameter *non-built-in-typep-cost* 1) +(defparameter *structure-typep-cost* 1) +(defparameter *built-in-typep-cost* 0) + +;; The execution time of this is exponential to some function +;; of number of gf methods and argument lists. It was taking +;; literally hours to load the presentation methods from the +;; cl-http w3p kit. +#+nil +(defun dispatch-dfun-cost (gf) + (generate-discrimination-net-internal + gf (generic-function-methods gf) nil + #'(lambda (methods known-types) + (declare (ignore methods known-types)) + 0) + #'(lambda (position type true-value false-value) + (declare (ignore position)) + (+ (max true-value false-value) + (if (eq 'class (car type)) + (let ((cpl (class-precedence-list (class-of (cadr type))))) + (cond((memq *the-class-built-in-class* cpl) + *built-in-typep-cost*) + ((memq *the-class-structure-class* cpl) + *structure-typep-cost*) + (t + *non-built-in-typep-cost*))) + 0))) + #'identity)) + +;; This version is from the pcl found in the gcl-2.1 distribution. +;; Someone added a cost limit so as to keep the execution time controlled +(defun dispatch-dfun-cost (gf &optional limit) + (generate-discrimination-net-internal + gf (generic-function-methods gf) nil + #'(lambda (methods known-types) + (declare (ignore methods known-types)) + 0) + #'(lambda (position type true-value false-value) + (declare (ignore position)) + (let* ((type-test-cost + (if (eq 'class (car type)) + (let* ((metaclass (class-of (cadr type))) + (mcpl (class-precedence-list metaclass))) + (cond ((memq *the-class-built-in-class* mcpl) + *built-in-typep-cost*) + ((memq *the-class-structure-class* mcpl) + *structure-typep-cost*) + (t + *non-built-in-typep-cost*))) + 0)) + (max-cost-so-far + (+ (max true-value false-value) type-test-cost))) + (when (and limit (<= limit max-cost-so-far)) + (return-from dispatch-dfun-cost max-cost-so-far)) + max-cost-so-far)) + #'identity)) + + +(defparameter *cache-lookup-cost* 1) +(defparameter *wrapper-of-cost* 0) +(defparameter *secondary-dfun-call-cost* 1) + +(defun caching-dfun-cost (gf) + (let* ((arg-info (gf-arg-info gf)) + (nreq (length (arg-info-metatypes arg-info)))) + (+ *cache-lookup-cost* + (* *wrapper-of-cost* nreq) + (if (methods-contain-eql-specializer-p + (generic-function-methods gf)) + *secondary-dfun-call-cost* + 0)))) + +#+cmu +(progn + (setq *non-built-in-typep-cost* 100) + (setq *structure-typep-cost* 15) + (setq *built-in-typep-cost* 5) + (setq *cache-lookup-cost* 30) + (setq *wrapper-of-cost* 15) + (setq *secondary-dfun-call-cost* 30)) + (defun make-dispatch-dfun (gf) (values (get-dispatch-function gf) nil (dispatch-dfun-info))) @@ -647,7 +738,7 @@ And so, we are saved. (defun make-initial-dfun (gf) (let ((initial-dfun - #'(lambda (&rest args) + #'(#+cmu kernel:instance-lambda #-cmu lambda (&rest args) #+copy-&rest-arg (setq args (copy-list args)) (initial-dfun gf args)))) (multiple-value-bind (dfun cache info) @@ -682,11 +773,11 @@ And so, we are saved. (let* ((methods (early-gf-methods gf)) (slot-name (early-method-standard-accessor-slot-name (car methods)))) (ecase type - (reader #'(lambda (instance) + (reader #'(#+cmu kernel:instance-lambda #-cmu lambda (instance) (let* ((class (class-of instance)) (class-name (bootstrap-get-slot 'class class 'name))) (bootstrap-get-slot class-name instance slot-name)))) - (writer #'(lambda (new-value instance) + (writer #'(#+cmu kernel:instance-lambda #-cmu lambda (new-value instance) (let* ((class (class-of instance)) (class-name (bootstrap-get-slot 'class class 'name))) (bootstrap-set-slot class-name instance slot-name new-value))))))) @@ -773,7 +864,7 @@ And so, we are saved. specls all-same-p) (cond ((null methods) (values - #'(lambda (&rest args) + #'(#+cmu kernel:instance-lambda #-cmu lambda (&rest args) (apply #'no-applicable-method gf args)) nil (no-methods-dfun-info))) @@ -830,8 +921,11 @@ And so, we are saved. (caching)) ((or invalidp (null nindex))) - ((not (or (std-instance-p object) - (fsc-instance-p object))) + ((not #-cmu17 + (or (std-instance-p object) + (fsc-instance-p object)) + #+cmu17 + (pcl-instance-p object)) (caching)) ((or (neq ntype otype) (listp wrappers)) (caching)) @@ -989,6 +1083,11 @@ And so, we are saved. (accessor-values-internal accessor-type accessor-class methods))) (defun accessor-values-internal (accessor-type accessor-class methods) + (dolist (meth methods) + (when (if (consp meth) + (early-method-qualifiers meth) + (method-qualifiers meth)) + (return-from accessor-values-internal (values nil nil)))) (let* ((meth (car methods)) (early-p (not (eq *boot-state* 'complete))) (slot-name (when accessor-class @@ -1378,10 +1477,15 @@ And so, we are saved. &optional all-applicable-p (all-sorted-p t) function-p) (if (null methods) - #'(lambda (method-alist wrappers) - (declare (ignore method-alist wrappers)) - #'(lambda (&rest args) - (apply #'no-applicable-method gf args))) + (if function-p + #'(lambda (method-alist wrappers) + (declare (ignore method-alist wrappers)) + #'(#+cmu kernel:instance-lambda #-cmu lambda (&rest args) + (apply #'no-applicable-method gf args))) + #'(lambda (method-alist wrappers) + (declare (ignore method-alist wrappers)) + #'(lambda (&rest args) + (apply #'no-applicable-method gf args)))) (let* ((key (car methods)) (ht-value (or (gethash key *effective-method-table*) (setf (gethash key *effective-method-table*) diff --git a/pcl/vector.lisp b/pcl/vector.lisp index c85aecff4..013c99fd8 100644 --- a/pcl/vector.lisp +++ b/pcl/vector.lisp @@ -53,6 +53,9 @@ (slot-name-lists nil :type list) (call-list nil :type list)) +#+cmu +(declaim (ext:freeze-type pv-table)) + (defvar *initial-pv-table* (make-pv-table-internal nil nil)) ; help new slot-value-using-class methods affect fast iv access @@ -170,12 +173,15 @@ (iterate ((slot-names (list-elements slot-name-lists))) (when slot-names (let* ((wrapper (pop wrappers)) + (std-p #+cmu17 (typep wrapper 'wrapper) + #-cmu17 t) (class (wrapper-class* wrapper)) - (class-slots (wrapper-class-slots wrapper))) + (class-slots (and std-p (wrapper-class-slots wrapper)))) (dolist (slot-name (cdr slot-names)) (gather1 - (compute-pv-slot slot-name wrapper class - class-slots not-simple-p-cell))))))))) + (when std-p + (compute-pv-slot slot-name wrapper class + class-slots not-simple-p-cell)))))))))) (if (car not-simple-p-cell) (make-permutation-vector (cons t elements)) (or (gethash elements *pvs*) @@ -271,13 +277,15 @@ (defun update-all-pv-table-caches (class slot-names) (let* ((cwrapper (class-wrapper class)) - (class-slots (wrapper-class-slots cwrapper)) + (std-p #+cmu17 (typep cwrapper 'wrapper) #-cmu17 t) + (class-slots (and std-p (wrapper-class-slots cwrapper))) (class-slot-p-cell (list nil)) (new-values (mapcar #'(lambda (slot-name) (cons slot-name - (compute-pv-slot - slot-name cwrapper class - class-slots class-slot-p-cell))) + (when std-p + (compute-pv-slot + slot-name cwrapper class + class-slots class-slot-p-cell)))) slot-names)) (pv-tables nil)) (dolist (slot-name slot-names) @@ -290,7 +298,7 @@ (let* ((cache (pv-table-cache pv-table)) (slot-name-lists (pv-table-slot-name-lists pv-table)) (pv-size (pv-table-pv-size pv-table)) - (pv-map (make-array pv-size))) + (pv-map (make-array pv-size :initial-element nil))) (let ((map-index 1)(param-index 0)) (dolist (slot-name-list slot-name-lists) (dolist (slot-name (cdr slot-name-list)) @@ -864,7 +872,7 @@ ,@forms)) (defvar *non-variable-declarations* - '(method-name method-lambda-list + '(#+cmu values method-name method-lambda-list optimize ftype inline notinline)) (defvar *variable-declarations-with-argument* @@ -1029,15 +1037,18 @@ (pv-wrappers (make-list nkeys)) w (w-t pv-wrappers)) (dolist (arg args) - (setq w (cond ((std-instance-p arg) - (std-instance-wrapper arg)) - ((fsc-instance-p arg) - (fsc-instance-wrapper arg)) - (t - #+new-kcl-wrapper - (built-in-wrapper-of arg) - #-new-kcl-wrapper - (built-in-or-structure-wrapper arg)))) + (setq w + #+cmu17 (wrapper-of arg) + #-cmu17 + (cond ((std-instance-p arg) + (std-instance-wrapper arg)) + ((fsc-instance-p arg) + (fsc-instance-wrapper arg)) + (t + #+new-kcl-wrapper + (built-in-wrapper-of arg) + #-new-kcl-wrapper + (built-in-or-structure-wrapper arg)))) (unless (eq 't (wrapper-state w)) (setq w (check-wrapper-validity arg))) (setf (car w-t) w)) diff --git a/pcl/walk.lisp b/pcl/walk.lisp index c400fcb19..40a066074 100644 --- a/pcl/walk.lisp +++ b/pcl/walk.lisp @@ -1806,7 +1806,8 @@ (defun walk-symbol-macrolet (form context old-env) (declare (ignore context)) - (let* ((bindings (cadr form))) + (let* ((bindings (cadr form)) + (body (cddr form))) (walker-environment-bind (new-env old-env :lexical-variables @@ -1816,7 +1817,7 @@ bindings) (env-lexical-variables old-env))) (relist* form 'symbol-macrolet bindings - (walk-repeat-eval (cddr form) new-env))))) + (walk-declarations body #'walk-repeat-eval new-env))))) (defun walk-tagbody (form context env) (recons form (car form) (walk-tagbody-1 (cdr form) context env))) diff --git a/tools/comcom.lisp b/tools/comcom.lisp index f65f1afcb..84e7f36fa 100644 --- a/tools/comcom.lisp +++ b/tools/comcom.lisp @@ -18,6 +18,7 @@ old-c::defstruct-slot-description) "C") + (with-compiler-log-file ("target:compile-compiler.log" :optimize @@ -37,13 +38,19 @@ (declare (optimize (speed 0)))) (:external (declare (optimize-interface (safety 2) (debug 1)))))) + (comf "target:compiler/macros" :load *load-stuff* :byte-compile *byte-compile*) -(comf "target:compiler/generic/vm-macs" :load *load-stuff* :proceed t) -(comf "target:compiler/backend" :load *load-stuff* :proceed t) + +(comf "target:compiler/generic/vm-macs" :load *load-stuff* :proceed t + :byte-compile #+bootstrap t #-bootstrap nil) + +(comf "target:compiler/backend" :load *load-stuff* :proceed t + :byte-compile #+bootstrap t #-bootstrap nil) (defvar c::*target-backend* (c::make-backend)) (comf (vmdir "target:compiler/parms") :proceed t) + (comf "target:compiler/generic/objdef" :proceed t) (comf "target:compiler/generic/interr") @@ -57,10 +64,12 @@ (comf "target:compiler/ctype") (comf "target:compiler/vop" :proceed t) (comf "target:compiler/vmdef") + (comf "target:compiler/meta-vmdef" :proceed t) +#+bootstrap ;; pw adds +(comf "target:compiler/meta-vmdef" :byte-compile t) (when *load-stuff* (load "target:compiler/meta-vmdef")) - (comf "target:compiler/disassem" :byte-compile *byte-compile*) (comf "target:compiler/new-assem") (comf "target:compiler/alloc") @@ -79,19 +88,21 @@ (comf "target:compiler/ir1opt")) (comf "target:compiler/ir1final") -(comf "target:compiler/srctran") +;;try(comf "target:compiler/srctran") (comf "target:compiler/array-tran" :byte-compile *byte-compile*) (comf "target:compiler/seqtran" :byte-compile *byte-compile*) (comf "target:compiler/typetran" :byte-compile *byte-compile*) (comf "target:compiler/generic/vm-typetran" :byte-compile *byte-compile*) (comf "target:compiler/float-tran" :byte-compile *byte-compile*) (comf "target:compiler/saptran" :byte-compile *byte-compile*) +(comf "target:compiler/srctran") ;; try (comf "target:compiler/locall") (comf "target:compiler/dfo") (comf "target:compiler/checkgen") (comf "target:compiler/constraint") (comf "target:compiler/envanal") + (comf "target:compiler/tn") (comf "target:compiler/life") @@ -100,16 +111,35 @@ (comf "target:compiler/debug-dump") (comf "target:compiler/generic/utils") (comf "target:assembly/assemfile") +#+bootstrap +(comf "target:assembly/assemfile" :byte-compile t) (when *load-stuff* (load "target:assembly/assemfile")) - + + (with-compilation-unit (:optimize '(optimize (safety #+small 0 #-small 1) #+small (debug 0))) -(comf (vmdir "target:compiler/insts")) -(comf (vmdir "target:compiler/macros") :load *load-stuff*) -(comf (vmdir "target:compiler/vm")) + #-x86 + (progn ; this is distributed order + (comf (vmdir "target:compiler/insts")) + (comf (vmdir "target:compiler/macros") :load *load-stuff*) + (comf (vmdir "target:compiler/vm"))) + #+nil + (progn ; this works for x86 + (comf (vmdir "target:compiler/vm")) + (comf (vmdir "target:compiler/macros") :load *load-stuff*) + (comf (vmdir "target:compiler/insts"))) + #+x86 + (progn ; this is needed for cross compile + (comf (vmdir "target:compiler/vm")) + (comf (vmdir "target:compiler/insts")) + (comf (vmdir "target:compiler/macros") :load *load-stuff* + :byte-compile #+bootstrap t #-bootstrap nil) + ) + (comf "target:compiler/generic/primtype") -(comf (vmdir "target:assembly/support") :load *load-stuff*) +(comf (vmdir "target:assembly/support") :load *load-stuff* + :byte-compile #+bootstrap t #-bootstrap nil) ; pw (comf (vmdir "target:compiler/move")) (comf (vmdir "target:compiler/float") :byte-compile *byte-compile*) (comf (vmdir "target:compiler/sap") :byte-compile *byte-compile*) @@ -119,6 +149,7 @@ (comf (vmdir "target:compiler/static-fn")) (comf (vmdir "target:compiler/arith")) (comf (vmdir "target:compiler/subprim") :byte-compile *byte-compile*) + (comf (vmdir "target:compiler/debug") :byte-compile *byte-compile*) (comf (vmdir "target:compiler/c-call") :byte-compile *byte-compile*) (comf (vmdir "target:compiler/cell")) @@ -141,6 +172,7 @@ ); with-compilation-unit for back end. (comf "target:compiler/aliencomp" :byte-compile *byte-compile*) + (comf "target:compiler/ltv") (comf "target:compiler/gtn") (with-compilation-unit diff --git a/tools/worldbuild.lisp b/tools/worldbuild.lisp index 9460fc0dc..892307e5c 100644 --- a/tools/worldbuild.lisp +++ b/tools/worldbuild.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldbuild.lisp,v 1.34 1994/10/24 19:09:08 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldbuild.lisp,v 1.35 1997/01/18 14:31:46 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -118,6 +118,10 @@ '("target:code/osf1-os")) ,@(when (c:backend-featurep :irix) '("target:code/irix-os")) + ,@(when (c:backend-featurep :FreeBSD) + '("target:code/bsd-os")) + ,@(when (c:backend-featurep :Linux) + '("target:code/linux-os")) "target:code/serve-event" "target:code/stream" "target:code/fd-stream" diff --git a/tools/worldcom.lisp b/tools/worldcom.lisp index 7f01abe36..61f3f8b03 100644 --- a/tools/worldcom.lisp +++ b/tools/worldcom.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldcom.lisp,v 1.71 1994/10/24 19:11:24 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldcom.lisp,v 1.72 1997/01/18 14:31:46 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -147,6 +147,10 @@ (comf "target:code/osf1-os")) (when (c:backend-featurep :irix) (comf "target:code/irix-os")) +(when (c:backend-featurep :BSD) + (comf "target:code/bsd-os")) +(when (c:backend-featurep :Linux) + (comf "target:code/linux-os")) (when (c:backend-featurep :pmax) (comf "target:code/pmax-vm")) diff --git a/tools/worldload.lisp b/tools/worldload.lisp index 3af120fa9..f49e7071c 100644 --- a/tools/worldload.lisp +++ b/tools/worldload.lisp @@ -6,7 +6,7 @@ ;;; If you want to use this code or any part of CMU Common Lisp, please contact ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldload.lisp,v 1.80 1994/10/04 12:26:38 ram Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldload.lisp,v 1.81 1997/01/18 14:31:47 ram Exp $ ;;; ;;; ********************************************************************** ;;; @@ -96,7 +96,7 @@ #-(or gengc runtime) (maybe-byte-load "code:room") ;;; Overwrite some cold-loaded stuff with byte-compiled versions, if any. -#-gengc +#-(or x86 gengc) ; x86 has stuff in static space (progn (byte-load-over "target:code/debug") (byte-load-over "target:code/error") -- GitLab