Commit c0c98ded authored by ram's avatar ram
Browse files

Werkowskis source kit 1.03.7

parent 30e750a1
:propagate-float-type :cmu18 :cmu17 :small :cgc :x86-lra
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.
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
or to
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
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.
(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))))
;;; -*- 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))
(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 @@
(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.
(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))))
(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.
(alien:def-alien-routine ("connect_to_server" xlib::connect-to-server)
(host c-call:c-string)
(port c-call:int))
(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.
(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))
(cond ((and (and timeout (= timeout 0))
(cond ((and (eql timeout 0)
(not (listen (display-input-stream display))))
......@@ -1464,6 +1490,7 @@
vector start (- end start))
;;; 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))))))
(defun buffer-write-default (vector display start end)
(declare (type buffer-bytes vector)
(type display display)
(type array-index start end))
(system:output-raw-bytes (display-output-stream display) vector start end)
;;; buffer-force-output-default - force output to the X stream
......@@ -1580,7 +1616,7 @@
;; buffer-write-default does the actual writing.
(declare (ignore display)))
#-(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 @@
(excl::filesys-checking-close (display-output-stream display)))
#-(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 @@
(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)
(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.
#-(or excl)
(defun buffer-listen-default (display)
(declare (type display display))
(let ((stream (display-input-stream display)))
......@@ -2114,21 +2150,13 @@
(defun x-error (condition &rest keyargs)
(let ((condx (apply #'make-condition condition keyargs)))
(typecase condx
;; This condition no longer exists.
(let ((disp (server-disconnect-display condx)))
(warn "Disabled event handling on ~S." disp)
(ext::disable-clx-event-handling disp)))
(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 @@
#-(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))
;;; 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)
(declare (ignore start end))
;;; 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))
(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))))
#+(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)))
(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 @@
#+(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))
(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))
(error "Invalid pixarray: ~S." pixarray)))))
;;; 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))
(lisp::with-array-data ((sdata source)
(declare (ignore send))
(lisp::with-array-data ((ddata dest)
(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)))))
(defun fast-read-pixarray-using-bitblt
(bbuf boffset pixarray x y width height padded-bytes-per-line
(declare (type (array * 2) pixarray))
(copy-bit-rect bbuf
(index* padded-bytes-per-line vm:byte-bits)
(index* boffset vm:byte-bits) 0
(index* (array-dimension pixarray 1) bits-per-pixel)
x y
(index* width bits-per-pixel))
#+(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 @@
(and (index= (pixarray-element-size pixarray) bits-per-pixel)
#+(or lcl3.0 excl)
(and (index= bits-per-pixel 1)
#+(or lcl3.0 excl)
(and (index= bits-per-pixel 4)
#+(or Genera lcl3.0 excl)
#+(or Genera lcl3.0 excl CMU)
(and (index= bits-per-pixel 24)
(when function
......@@ -3321,7 +3425,7 @@
(aref vector (index+ x 1))))))))