common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Merge remote-tracking branch 'upstream/master' into xml-test-results

Browse source
This commit is contained in:
Jan Moringen 2023-02-01 19:30:53 +01:00
parent b04dffb42d 66b3c634b6
commit 0159ebf2aa
950 changed files with 108621 additions and 70882 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
.cirrus.yml
View file

@ -2,9 +2,9 @@ freebsd_build_task:
freebsd_instance:
matrix:
image_family: freebsd-11-3-snap
image_family: freebsd-12-1-snap
# image_family: freebsd-13-0-snap
image_family: freebsd-12-3
image_family: freebsd-13-0
image_family: freebsd-14-0-snap
cpu: 1
memory: 1G

37
.github/workflows/cl-host.yml vendored
View file

@ -48,11 +48,20 @@ jobs:
- name: instal host clisp
run: |
sudo apt-get -qq update | true
sudo apt-get -qq install clisp
sudo apt-get -qq install clisp git-restore-mtime
- name: build
env:
SBCL_MAKE_TARGET_2_OPTIONS: --disable-ldb --disable-debugger
run: ./make.sh --xc-host='clisp -on-error exit'
run: |
git restore-mtime
./make.sh --xc-host='clisp -on-error exit'
- name: archive clisp-xc fasls
run: tar --transform 's,^,clisp-host/,' -cf clisp-host-fasls.tgz obj/from-xc/
- name: upload clisp-xc archive
uses: actions/upload-artifact@v3
with:
name: xc-host-fasls
path: clisp-host-fasls.tgz
ccl:
@ -95,11 +104,22 @@ jobs:
wget -q https://github.com/sbcl/sbcl/releases/download/sbcl-1.4.14/cmucl.tar.bz2
tar xf cmucl.tar.bz2
echo '(setf ext:*gc-verbose* nil)' > ~/.cmucl-init.lisp
sudo apt-get -qq update | true
sudo apt-get -qq install git-restore-mtime
working-directory: /tmp/
- name: build
env:
SBCL_MAKE_TARGET_2_OPTIONS: --disable-ldb --disable-debugger
run: ./make.sh --xc-host='/tmp/cmucl/bin/lisp -batch'
run: |
git restore-mtime
./make.sh --xc-host='/tmp/cmucl/bin/lisp -batch'
- name: archive cmucl-xc fasls
run: tar --transform 's,^,cmucl-host/,' -cf cmucl-host-fasls.tgz obj/from-xc/
- name: upload cmucl-xc archive
uses: actions/upload-artifact@v3
with:
name: xc-host-fasls
path: cmucl-host-fasls.tgz
sbcl:
@ -117,7 +137,7 @@ jobs:
SBCL_MAKE_TARGET_2_OPTIONS: --disable-ldb --disable-debugger
run: |
git restore-mtime
./make.sh --xc-host='sbcl --dynamic-space-size 500MB --lose-on-corruption --disable-ldb --disable-debugger'
./make.sh --xc-host='sbcl --dynamic-space-size 600MB --lose-on-corruption --disable-ldb --disable-debugger'
- name: archive sbcl-xc fasls
run: tar --transform 's,^,sbcl-host/,' -cf sbcl-host-fasls.tgz obj/from-xc/
- name: upload sbcl-xc archive
@ -130,7 +150,7 @@ jobs:
runs-on: ubuntu-latest
timeout-minutes: 5
needs: [ccl, sbcl]
needs: [ccl, sbcl, cmucl, clisp]
steps:
- name: download xc-host fasls
@ -141,5 +161,10 @@ jobs:
run: |
tar xf ccl-host-fasls.tgz
tar xf sbcl-host-fasls.tgz
tar xf clisp-host-fasls.tgz
tar xf cmucl-host-fasls.tgz
- name: compare xc-host fasls
run: diff -ur sbcl-host/ ccl-host/
run: |
diff -ur sbcl-host/ ccl-host/
diff -ur sbcl-host/ clisp-host/ || true
diff -ur sbcl-host/ cmucl-host/ || true

2
.github/workflows/linux.yml vendored
View file

@ -35,7 +35,7 @@ jobs:
- name: build
env:
SBCL_MAKE_TARGET_2_OPTIONS: --disable-ldb --disable-debugger
run: ./make.sh ${{ matrix.options }} --xc-host='sbcl --dynamic-space-size 500MB --lose-on-corruption --disable-ldb --disable-debugger' --arch=${{ matrix.arch }}
run: ./make.sh ${{ matrix.options }} --xc-host='sbcl --dynamic-space-size 600MB --lose-on-corruption --disable-ldb --disable-debugger' --arch=${{ matrix.arch }}
- name: test
run: cd tests; ./run-tests.sh
- name: test

2
.github/workflows/mac.yml vendored
View file

@ -18,7 +18,7 @@ jobs:
- name: build
env:
SBCL_MAKE_TARGET_2_OPTIONS: --disable-ldb --disable-debugger
run: ./make.sh ${{ matrix.options }} --xc-host='sbcl --dynamic-space-size 500MB --lose-on-corruption --disable-ldb --disable-debugger'
run: ./make.sh ${{ matrix.options }} --xc-host='sbcl --dynamic-space-size 600MB --lose-on-corruption --disable-ldb --disable-debugger'
- name: make binary
run: |
name=sbcl-`cat version.lisp-expr | ./run-sbcl.sh --noinform --noprint --eval '(write-line (read))'`-darwin-x86-64

4
.gitignore vendored
View file

@ -40,15 +40,13 @@ tests/*.so
tests/run-tests-*
tests/last-random-state.lisp-expr
tests/ansi-test/
tools-for-build/avx2*
tools-for-build/determine-endianness
tools-for-build/determine-endianness.exe
tools-for-build/grovel-headers
tools-for-build/grovel-headers.exe
tools-for-build/mmap-rwx
tools-for-build/where-is-mcontext
contrib/*/test-passed
contrib/*/test-output
contrib/asdf/asdf-upstream
contrib/sb-cover/test-output
doc/manual/*.html
version.lisp-expr

2
INSTALL
View file

@ -179,7 +179,7 @@ INSTALLING SBCL
:SB-CORE-COMPRESSION (--with-sb-core-compression)
Adds zlib as a build-dependency, and makes SBCL able to save
Adds zstd as a build-dependency, and makes SBCL able to save
compressed cores. Not enabled by default.
:SB-XREF-FOR-INTERNALS (--with-sb-xref-for-internals)

235
NEWS
View file

@ -1,6 +1,239 @@
;;;; -*- coding: utf-8; fill-column: 78 -*-
changes relative to sbcl-2.2.3:
changes relative to sbcl-2.3.1:
* incompatible change: the :ORDER long-form-option in
DEFINE-METHOD-COMBINATION accepts NIL as well as :MOST-SPECIFIC-FIRST and
:MOST-SPECIFIC-LAST. A value of NIL implies no particular ordering of the
methods, and so disables checks of multiple methods with the same
specializers in that group.
* bug fix: evaluate the :ORDER long-form-option in DEFINE-METHOD-COMBINATION
properly, avoiding an infinite loop in DEFINE-METHOD-COMBINATION if the
:ORDER argument leads to a cycle of compile-time constants.
changes in sbcl-2.3.1 relative to sbcl-2.3.0:
* sb-graph has been removed. To visualize IR1 in sbcl, it is recommended to
use the function IR1-TO-DOT (which only survives the final tree shake if
the feature :sb-devel is enabled at build time).
* platform support:
** implement some peephole optimizations on arm64;
** support float traps on arm64;
* bug fix: package-manipulation operations within fasls work as expected in
the absence of explicit block compilation requests. (lp#2000004, reported
by Shubhamkar Ayare)
* bug fix: incorrect type simplification of certain CONS types.
(lp#1999352, reported by Paul Dietz)
* bug fix: method combination group selection interprets the symbol * as
a wildcard element within proper qualifier-pattern lists. (reported by
Maciej Katafiasz and by Daniel Kochmański)
* bug fix: &WHOLE can be used without error in define-method-combination
arguments lambda lists. (reported by Daniel Kochmański)
* bug fix: bogus debug variables generated for closure variables whose value
cell had not yet been allocated could cause segfaults and gc crashes
(reported by _death on #sbcl)
* bug fix: handling of float NaNs in two-arg numeric comparison functions is
more consistent with the required semantics in IEEE 754 when comparing
with rationals.
* bug fix: ensure that the hide-packages test passes even when the system
retains internal cross-reference metadata. (lp#2002896, reported by 3b)
* bug fix: don't trip an internal assertion in weak hash tables with
finalizers. (lp#1998064)
* optimization: load-time only code is no longer retained at runtime when
functions close over top level bindings.
* optimization: GO and RETURN-FROM now elide out-of-extent tag checks when
the compiler can prove it's safe even on high safety.
* optimization: addition of a fixnum to a bignum generates less garbage.
* optimization: in many cases, type inference and code generation is
improved for and around numerical comparison functions.
changes in sbcl-2.3.0 relative to sbcl-2.2.11:
* enhancement: support for SLOT-VALUE and friends has been extended to
structure and condition instances.
* enhancement: the error message for invalid array index conditions is clearer.
(lp#1999337, reported by Hadrien Lacour)
* minor incompatible change: COMPILED-FUNCTION-P now returns false for
generic functions.
* minor incompatible change: the compiler emit STYLE-WARNING conditions for
FIND and POSITION where the item sought can never be present in the
sequence.
* optimization: support computing the remainder of a constant division by
multiplication.
* optimization: faster out of line float truncation routines.
* optimization: faster RATIONAL on 64-bit platforms.
* optimization: more compact testing of widetags on x86-64 and arm64.
* bug fix: type intersections of RATIONAL ranges with (NOT INTEGER) are
computed more consistently. (lp#1998008)
* bug fix: fix miscompilation of integer/fixnum comparisons where both
arguments are on the stack.
changes in sbcl-2.2.11 relative to sbcl-2.2.10:
* platform support:
** arm64: allow the use of CLISP as a build host. (lp#1996942, reported
by Andrew Patterson)
* enhancement: improvements to constraint propagation around comparison
functions.
* optimization: conditional move VOPs can work on boxed values and
produce less consing.
* optimization: NUNION and UNION are generally faster.
* bug fix: slot-makunbound-using-class can be redefined without redefining
the other slot methods. (lp#1956621, reported by Michał Herda)
* bug fix: GETHASH on a table created without ":synchronized t" when run
concurrently in multiple threads could have returned incorrect results.
* bug fix: build of contributed modules assumed that 'cat' was always
in /bin/cat on POSIX systems. (lp#1995224, reported by Kasper Gałkowski)
* bug fix: INSPECT on an (ARRAY NIL) no longer hangs. (lp#1995639, reported
by Michał Herda)
* bug fix: Fix miscompilation of FILE-STRING-LENGTH when the first argument
has a known FILE-STREAM type. (lp#1995881)
changes in sbcl-2.2.10 relative to sbcl-2.2.9:
* platform support:
** win32: improved handling of stack overflow exceptions. (lp#1302866)
** Mac OS X: enforce stronger alignment when building the runtime.
(lp#1991485, reported by Yan)
** arm64: support for building the system without the sb-unicode feature
(i.e. with 8-bit characters) is restored.
* bug fix: do not elide the GC store barrier in closures. (lp#1982608,
reported by Andrew Berkley)
* bug fix: make sb-introspect tests pass when the system is built without
support for source locations. (lp#1635349, reported by Tomas Hlavaty)
* bug fix: erroneous assumption that the format-control of a simple condition
was a string. (lp#1803727)
* bug fix: compiler consistency failure in modular arithmetic widening.
(lp#1990715)
* bug fix: provide a stub for a helper function (lp#1992316)
changes in sbcl-2.2.9 relative to sbcl-2.2.8:
* platform support:
** fix build on Darwin platforms with -fno-common. (lp#1980570, thanks to
Sergei Trofimovich)
** include /usr/local paths when building on FreeBSD. (lp#1981112,
reported by William G Lederer)
** several micro-optimizations on x86-64, including: better use of
INC/SUB, better SAP+, shorter KEYWORDP, better argument count
verification
** arm64: better KEYWORDP, better argument count verification
** fix build on 32-bit Windows. (lp#1988534, thanks to Alexis Rivera)
** x86-64: WITH-PINNED-OBJECTS can pin constants. (lp#1989037)
* bug fix: make sb-simd build in compiler-only SBCL. (thanks to Tonas
Hlavaty)
* bug fix: SB-SPROF:WITH-PROFILING now returns the value of its body (as was
advertised in its documentation).
* bug fix: catch malformed LET* forms in DEFMETHOD bodies. (lp#1988880,
reported by Patrick Poitras)
* enhancement: better source form tracking for atoms in LET bindings.
* optimization: reader character macro lookup is simpler and faster.
* optimization: FILL-POINTER (and its setter) are more compact.
changes in sbcl-2.2.8 relative to sbcl-2.2.7:
* minor incompatible change: support for 32-bit x86/Darwin has been removed.
* bug fix: fix miscompilation related to empty infinite loops preceded by
conditional expressions. (lp#1986810, reported by Artyom Bologov)
* bug fix: fix gc invariant violations. (lp#1983218, reported by Marius
Gerbershagen; lp#1983248, reported by Vasily Postnicov)
* bug fix: use CC to compile SBCL as a shared library. (lp#1976148,
reported by Pierre Neidhardt)
* bug fix: don't crash the system completely if RUN-PROGRAM fails to create
a pipe. (lp#1979841, reported by Thor Kristofferson)
* bug fix: be more disciplined about use of C system includes. (lp#1981799,
reported by Mark Evenson)
* bug fix: STRING/= returning wrong results for some cases when :END1/:END2
were not compile-time constants. (lp#1983284)
* bug fix: compile-time checking of :START and :END keyword arguments to
FILL is more complete.
* optimization: adjacent type tests on the same value are more compact
(arm64, x86-64).
* optimization: the compiler can inline COPY-STRUCTURE in more cases.
* optimization: type checks for non-simple arrays are shorter.
* optimization: printing strings (as Lisp data) is faster.
changes in sbcl-2.2.7 relative to sbcl-2.2.6:
* minor incompatible change: the compiler emits full WARNINGs for undefined
references to variables in TYPE and DYNAMIC-EXTENT declarations, and for
SETQ of an undefined variable. (This was the historic behaviour for
everything except the DYNAMIC-EXTENT case, which used to emit a
STYLE-WARNING, but these diagnostics got lost in a refactoring since
sbcl-2.2.2)
* minor incompatible change: literal objects (strings, in particular)
in compiled code may at the discretion of the runtime be placed in
read-only memory. Violations of CLHS 3.7.1 could produce memory faults.
If ":PURIFY NIL" is given to SAVE-LISP-AND-DIE then no read-only memory
will be used.
* enhancement: Unicode support has been updated to support version 10.0.0 of
the Unicode standard, including addition of characters and refinements to
breaking and collation algorithms.
* bug fix: AVX is no longer used for loading simd-pack-256 constants.
(lp#1928097)
* bug fix: fix building the manual when some contribs are blocked or
otherwise disabled. (lp#1979821, thanks to Robert Schiele)
* bug fix: fix type derivation of sequence functions with highly-specific
declared argument types. (lp#1980292, reported by James Kalenius)
* bug fix: internal error when optimizing chains of conditionals in local
functions. (lp#1981607, reported by Pasha K)
* bug fix: fix comparison of negative floats with bignums.
* optimization: faster TRUNCATE with float arguments.
* optimization: EQUALP hashing of large floating point values should
generate less garbage.
changes in sbcl-2.2.6 relative to sbcl-2.2.5:
* minor incompatible change: support for 32-bit x86 on macOS has been
removed.
* new contrib: sb-simd, to provide a convenient interface for SIMD
programming on x86-64. (Thanks to Marco Heisig and other sb-simd
contributors)
* enhancement: core compression now uses zstd instead of zlib. (lp#1881089)
* enhancement: provide compiler warnings for specialized array type
mismatches in CONCATENATE.
* enhancement: provide compiler warnings for bad sequence bounding index
designator arguments to sequence functions.
* enhancement: The sb-mpfr contrib now allows coercion from MPFR-FLOATs
to CL:RATIONAL. (Thanks to Robert Smith)
* bug fix: fix compilation failure related to declaiming types of constants.
(lp#1977726, reported by Pierre Neidhardt)
* bug fix: fix race condition in CLOS optimized constructors. (lp#1951341)
* bug fix: fix too-eager elision of allocation barriers when initializing
closure and structure objects.
* optimization: fasl files are now usually smaller (up to 10% on default
policy) and may load faster, especially on high debug.
* optimization: faster string comparisons on arm64, x86-64.
* optimization: faster [n]string-down/upcase on arm64, x86-64.
* optimization: faster [n]reverse for 8- and 32-bit element vectors on
arm64, x86-64.
* optimization: faster type tests for (CONS (EQL symbol)) on x86-64.
changes in sbcl-2.2.5 relative to sbcl-2.2.4:
* minor incompatible change: SB-EXT:*DERIVE-FUNCTION-TYPES* being NIL now
means that function calls will strictly only use type information from
proclaimed ftypes. The previous behavior (still the default) of using
derived type information from the same file is specified with :SAME-FILE.
(lp#1393302)
* minor incompatible change: RENAME-FILE now overwrites the target file on
Windows too, making its behaviour consistent with other platforms.
* minor incompatible change: inlining of local function is inhibited if
policy DEBUG = 3.
* platform support:
** single-stepping is now supported on 64-bit PowerPC platforms. (thanks
to Thomas Fitzsimmons)
** the :SB-LINKABLE-RUNTIME feature is now supported on 32-bit and 64-bit
PowerPC platforms. (thanks to Thomas Fitzsimmons)
* optimization: improved type derivation of REDUCE with some known reducing
functions.
* enhancement: debug source locations now work correctly for top level forms
with policy DEBUG = 1, as well as for block compiled files.
* enhancement: TRACE now supports tracing macro functions, compiler-macro
functions, individual methods and local functions. See the user manual for
more details. (lp#375314)
* bug fix: fix integer comparisons on x86-64 and arm64 (lp#1971088, reported
by Guillaume LE VAILLANT)
* bug fix: coverage instrumentation behaves correctly with respect to
non-local exits.
* bug fix: ftype proclamations now take effect immediately during block
compilation.
* bug fix: block compilation of top-level closures now work. (lp#1931730,
reported by Sean Maher)
* bug fix: streams opened from RUN-PROGRAM but left unclosed because of a
non-local exit no longer cause unrelated streams to be closed later.
changes in sbcl-2.2.4 relative to sbcl-2.2.3:
* enhancement: better constraint propagation in the compiler. Specifically,
the compiler can now derive the type of X in control flow join situations
such as

27
TODO
View file

@ -47,11 +47,6 @@ PEEPHOLE OPTIMIZER
Have you ever read SBCL disassembly?
DEFGLOBAL
Global lexical variables. Esp. since with threads special variable
accesses is no speed daemon.
FINISHING EXTERNAL FORMATS
Byte order marks. Newline conventions. A way to specify an external
@ -75,11 +70,6 @@ ADVICE/FWRAP
latter returns the underlying definition, whereas the first returns
the encapsulation.
GENERIC FUNCTION TRACING
This sucks currently. It would also be good to be able to trace
individual methods.
POLICY MADNESS
The interactions between various optimization policies are far from
@ -88,11 +78,6 @@ POLICY MADNESS
FAST-SAFE, FAST-UNSAFE) "dominant" policies, and expose the rest
as separately declarable optimization toggles.
MAYBE-INLINE is also nice, but it would be good if someone could
figure out how to get rid of it while retaining the semantics it
provides. Inlining recursive functions is also something to think
about.
INHIBIT-WARNINGS really needs to go away.
WINDOWS
@ -101,13 +86,10 @@ WINDOWS
DARWIN
Needs love, particularly threads and exceptions/signals. slam.sh is
also broken there.
Needs love, particularly threads and exceptions/signals.
DRAGONFLY
Multithreading does not work. Possibly because of bug in mmap/munmap.
Hint: Comment out call to os_invalidate in perform_thread_post_mortem
and threads will work, but space will not be freed, of course.
MISC CLEANUPS
@ -120,13 +102,6 @@ MISC CLEANUPS
** use %COMPILE where COMPILE-TOP-LEVEL used to be used
** remove redundant COMPILE-TOP-LEVEL and
FUNCTIONAL-KIND=:TOP-LEVEL stuff from the compiler
* outstanding embarrassments
** :IGNORE-ERRORS-P cruft in stems-and-flags.lisp-expr. (It's
reasonable to support this as a crutch when initially
bootstrapping from balky xc hosts with their own
idiosyncratic ideas of what merits FAILURE-P, but it's
embarrassing to have to use it when bootstrapping
under SBCL!),
* miscellaneous simple refactoring
* belated renaming:
** rename %PRIMITIVE to %VOP

81
benchmarks/bbtrees.lisp Normal file
View file

@ -0,0 +1,81 @@
(setq *evaluator-mode* :compile)
(load "src/code/redblack.lisp")
(in-package "SB-RBTREE.WORD")
(defun height (tree)
(sb-int:named-let recurse ((tree tree))
(if (not tree)
0
(1+ (max (recurse (left tree)) (recurse (right tree)))))))
(compile 'height)
(in-package "SB-BROTHERTREE")
(defmacro binary-node-parts (node)
`(let ((n ,node))
(if (fringe-binary-node-p n)
(values nil (binary-node-key n) nil) ; has only one data slot
;; has left + right
(values (binary-node-%left n) (binary-node-key n) (binary-node-%right n)))))
(defun height (tree &aux (n 0))
(loop
(unless tree (return n))
(incf n)
;; We're assuming that the brothertree invariant holds-
;; the left and right heights are the same.
(typecase tree
(binary-node (setq tree (values (binary-node-parts tree))))
(unary-node (setq tree (child tree))))))
(compile 'height)
(in-package "CL-USER")
(defvar *brothertree* nil)
(defvar *rbtree* nil)
(defvar *lotta-strings*
(mapcar (lambda (x)
(sb-kernel:%make-lisp-obj
(logandc2 (sb-kernel:get-lisp-obj-address x)
sb-vm:lowtag-mask)))
(sb-vm:list-allocated-objects
:read-only
:type sb-vm:simple-base-string-widetag)))
(defun insert-all-brothertree ()
(let ((tree nil))
(dolist (str *lotta-strings*)
(setq tree (sb-brothertree:insert str tree)))
(setq *brothertree* tree)))
(defun insert-all-redblack ()
(let ((tree nil))
(dolist (str *lotta-strings*)
;; because OF COURSE the arg orders are opposite
(setq tree (sb-rbtree.word:insert tree str)))
(setq *rbtree* tree)))
(gc)
(time (insert-all-redblack))
(gc)
(time (insert-all-brothertree))
(format t "~&Tree heights: redblack=~D brother=~D~%"
(sb-rbtree.word::height *rbtree*)
(sb-brothertree::height *brothertree*))
#|
* (load"benchmarks/bbtrees")
Evaluation took:
0.012 seconds of real time
0.012138 seconds of total run time (0.012086 user, 0.000052 system)
100.00% CPU
29,126,552 processor cycles
21,916,768 bytes consed
Evaluation took:
0.007 seconds of real time
0.007634 seconds of total run time (0.007550 user, 0.000084 system)
114.29% CPU
18,334,338 processor cycles
18,640,080 bytes consed
Tree heights: redblack=25 brother=16
|#

41
benchmarks/finalize.lisp Normal file
View file

@ -0,0 +1,41 @@
(defun make-threads (semaphore nwriters nobjects)
(loop for i below nwriters
collect
(let ((list (loop repeat nobjects for j from 1
collect (cons i j))))
(sb-thread:make-thread
(lambda (things)
(sb-thread:wait-on-semaphore semaphore)
(dolist (thing things)
(finalize thing #'+)) ; a no-op finalizer
(mapc #'cancel-finalization things))
:arguments (list list)
:name (format nil "worker ~D" i)))))
(defun test-finalize+cancel (ntrials nwriters nobjects)
(dotimes (i ntrials)
(let* ((sem (sb-thread:make-semaphore))
(threads (make-threads sem nwriters nobjects)))
(sb-thread:signal-semaphore sem nwriters)
(mapc #'sb-thread:join-thread threads))))
(time (test-finalize+cancel 100 4 10000)) ; 100 trials, 4 threads, 10k objects per thread
#|
;; Old:
Evaluation took:
4.100 seconds of real time
10.704615 seconds of total run time (10.585181 user, 0.119434 system)
[ Run times consist of 0.017 seconds GC time, and 10.688 seconds non-GC time. ]
261.10% CPU
9,841,747,312 processor cycles
203,244,640 bytes consed
;; New:
Evaluation took:
1.179 seconds of real time
2.874184 seconds of total run time (2.756504 user, 0.117680 system)
[ Run times consist of 0.041 seconds GC time, and 2.834 seconds non-GC time. ]
243.77% CPU
2,830,553,292 processor cycles
353,720,608 bytes consed
|#

60
benchmarks/find-symbol.lisp Normal file
View file

@ -0,0 +1,60 @@
(in-package sb-impl)
(defun find-sym-timing (niter &aux (res 0))
(let* ((pkg (find-package "KEYWORD"))
(externals (package-external-symbols pkg))
(vect (remove-if-not #'symbolp (symtbl-cells externals))))
(dotimes (i niter)
(dovector (sym vect)
(let ((str (symbol-name (truly-the symbol sym))))
(when (find-symbol str pkg)
(incf res))))))
res)
(find-sym-timing 5000)
#|
;; This benchmarks shows just how large the effect is of removing
;; one IDIV instruction from the hash -> bin calculation in SYMBOL-HASHSET.
;; As expected, we take a bunch more branches and run more instructions,
;; but the overall instructions/cycle is higher, and CPU time is lower.
;; These results are completely repeatable.
% perf stat path/to/sbcl --noinform --noprint --no-sysinit --no-userinit < benchmarks/find-symbol.lisp
Without fast remainder vop
==========================
1,963.00 msec task-clock:u # 0.999 CPUs utilized
0 context-switches:u # 0.000 /sec
0 cpu-migrations:u # 0.000 /sec
1,094 page-faults:u # 557.311 /sec
5,433,686,072 cycles:u # 2.768 GHz
2,067,083,081 stalled-cycles-frontend:u # 38.04% frontend cycles idle
8,180,495,043 instructions:u # 1.51 insn per cycle
# 0.25 stalled cycles per insn
1,648,928,710 branches:u # 840.006 M/sec
36,906,902 branch-misses:u # 2.24% of all branches
1.965377442 seconds time elapsed
1.956049000 seconds user
0.008000000 seconds sys
With fast remainder vop
=======================
1,689.64 msec task-clock:u # 0.999 CPUs utilized
0 context-switches:u # 0.000 /sec
0 cpu-migrations:u # 0.000 /sec
1,018 page-faults:u # 602.494 /sec
4,670,096,246 cycles:u # 2.764 GHz
1,540,757,518 stalled-cycles-frontend:u # 32.99% frontend cycles idle
8,636,783,323 instructions:u # 1.85 insn per cycle
# 0.18 stalled cycles per insn
1,707,772,211 branches:u # 1.011 G/sec
38,296,405 branch-misses:u # 2.24% of all branches
1.691727650 seconds time elapsed
1.678228000 seconds user
0.011958000 seconds sys
|#

7
binary-distribution.sh
View file

@ -11,6 +11,9 @@ set -e
b=${1:?"missing base directory name argument"}
# FIXME: why include each Makefile in the binary distribution
# if by definition everything is already built?
tar -cf $b-binary.tar \
$b/output/sbcl.core $b/src/runtime/sbcl $b/output/prefix.def \
$b/src/runtime/sbcl.mk \
@ -22,10 +25,8 @@ tar -cf $b-binary.tar \
$b/contrib/asdf-module.mk \
`for contrib in $(cd $b/contrib && echo *); do
src_dir=$b/contrib/$contrib
cache_dir=$b/obj/asdf-cache/$contrib
if test -d $src_dir && test -f $cache_dir/test-passed.test-report; then
if test -d $src_dir && test -f $b/obj/sbcl-home/contrib/$contrib.fasl; then
echo $src_dir/Makefile
echo $cache_dir/test-passed.test-report
fi
done` \
$b/obj/sbcl-home

6
clean.sh
View file

@ -27,7 +27,7 @@ for d in tools-for-build; do
# I hope the -s option is standard. At least GNU make and BSD make
# support it. It silences make, since otherwise the output from
# this script is just the operations done by these make's, which
# is misleading when this script does lotso other operations too.
# is misleading when this script does lots of other operations too.
# -- WHN
$GNUMAKE -I ../src/runtime -s clean
cd "$original_pwd" > /dev/null
@ -70,8 +70,6 @@ done
# *.tmp, *.lisp-temp
# conventional names for temporary files autogenerated in
# building or testing
# test-passed
# generated by automatic directory-test-thyself procedure
find . \( \
-name _darcs -o \
-name '{arch}' -o \
@ -105,7 +103,6 @@ find . \( \
-name '*.so' -o \
-name '*.d' -o \
-name 'foo.c' -o \
-name 'test-output' -o \
-name 'test-lab' -o \
-name 'encodings.texi-temp' -o \
-name 'stack-alignment-offset' -o \
@ -120,7 +117,6 @@ find . \( \
-name 'depend' -o \
-name 'TAGS' -o \
-name 'tags' -o \
-name 'test-passed' -o \
-name 'local-target-features.lisp-expr' \) -print | \
if test -f .cleanignore; then
# Because this file deletes all symlinks, it prevents building

79
contrib/Makefile
View file

@ -1,46 +1,37 @@
vpath %.fasl ../obj/sbcl-home/contrib/
all: asdf.fasl sb-posix.fasl sb-bsd-sockets.fasl sb-introspect.fasl sb-cltl2.fasl \
sb-aclrepl.fasl sb-sprof.fasl sb-capstone.fasl sb-md5.fasl sb-capstone.fasl \
sb-executable.fasl sb-gmp.fasl sb-mpfr.fasl sb-queue.fasl sb-rotate-byte.fasl \
sb-simple-streams.fasl sb-concurrency.fasl sb-cover.fasl sb-graph.fasl
asdf.fasl:
sh ./build-contrib $(basename $(@F))
sb-grovel.fasl: asdf.fasl
sh ./build-contrib $(basename $(@F))
sb-rt.fasl: asdf.fasl
sh ./build-contrib $(basename $(@F))
sb-posix.fasl: asdf.fasl sb-grovel.fasl sb-rt.fasl
sh ./build-contrib $(basename $(@F))
sb-bsd-sockets.fasl: asdf.fasl sb-grovel.fasl sb-posix.fasl sb-rt.fasl
sh ./build-contrib $(basename $(@F))
sb-cltl2.fasl: asdf.fasl sb-rt.fasl
sh ./build-contrib $(basename $(@F))
sb-aclrepl.fasl: asdf.fasl sb-rt.fasl
sh ./build-contrib $(basename $(@F))
sb-concurrency.fasl: asdf.fasl sb-rt.fasl
sh ./build-contrib $(basename $(@F))
sb-sprof.fasl: asdf.fasl
sh ./build-contrib $(basename $(@F))
sb-introspect.fasl: asdf.fasl sb-rt.fasl
sh ./build-contrib $(basename $(@F))
sb-capstone.fasl: asdf.fasl sb-rt.fasl
sh ./build-contrib $(basename $(@F))
sb-md5.fasl: asdf.fasl sb-rotate-byte.fasl sb-rt.fasl
sh ./build-contrib $(basename $(@F))
sb-cover.fasl: asdf.fasl sb-md5.fasl
sh ./build-contrib $(basename $(@F))
sb-executable.fasl: asdf.fasl
sh ./build-contrib $(basename $(@F))
sb-gmp.fasl: asdf.fasl sb-rt.fasl
sh ./build-contrib $(basename $(@F))
sb-mpfr.fasl: asdf.fasl sb-gmp.fasl sb-rt.fasl
sh ./build-contrib $(basename $(@F))
sb-queue.fasl: asdf.fasl sb-concurrency.fasl
sh ./build-contrib $(basename $(@F))
sb-rotate-byte.fasl: asdf.fasl
sh ./build-contrib $(basename $(@F))
sb-simple-streams.fasl: asdf.fasl sb-posix.fasl sb-bsd-sockets.fasl sb-rt.fasl
sh ./build-contrib $(basename $(@F))
sb-graph.fasl: asdf.fasl sb-rt.fasl
sh ./build-contrib $(basename $(@F))
contribs = sb-posix sb-bsd-sockets sb-introspect sb-cltl2 sb-aclrepl \
sb-sprof sb-capstone sb-md5 sb-capstone sb-executable sb-gmp sb-mpfr \
sb-queue sb-rotate-byte sb-rt sb-simple-streams sb-concurrency sb-cover \
sb-simd sb-grovel asdf
active_contribs = $(filter-out $(SBCL_CONTRIB_BLOCKLIST),$(contribs))
fasls = $(active_contribs:=.fasl)
all: $(fasls)
# Inter-module dependencies are declared here but not in the per-directory Makefile.
# This way we don't have to state them twice.
sb-md5.fasl: sb-rotate-byte.fasl
sb-cover.fasl: sb-md5.fasl
sb-mpfr.fasl: sb-gmp.fasl
sb-queue.fasl: sb-concurrency.fasl
sb-simple-streams.fasl: sb-posix.fasl sb-bsd-sockets.fasl
sb-grovel.fasl: asdf.fasl # for building the module, not for our build
# Notes:
# 1. Invoking $(MAKE) for nested make eliminates a warning about jobserver mode.
# 2. This could be made to 'tee' into output/{something} as it used to,
# but it would be more Lispy if not elegant to have 'make-contrib.lisp' bind
# *ERROR-OUTPUT* to a broadcast stream of SYS:*STDERR* and a file stream.
# 3. The massively overapproximates the set of inputs needed to compile any given contrib
# which avoids using per-target lists of files, or any power-user tricks such
# as .SECONDEXPANSION and $(wildcard) in this makefile.
# I tried all kinds of variations on "%/*.lisp" and nothing worked easily.
# I suspect the right solution involves eliminating the other level of Makefile.
# Also: a motivated person might be able to figure out how to express a dependence
# on src/runtime/sbcl or src/runtime/sbcl.exe depending on the OS.
# I'm going to assume that the depending on the core is enough.
%.fasl: */*.lisp */*/*.lisp ../output/sbcl.core
$(MAKE) MODULE_REQUIRES="$(filter %.fasl, $^)" -C $*

32
contrib/asdf-module.mk
View file

@ -6,7 +6,8 @@
# ones as dependencies.
UNAME:=$(shell uname -s)
DEST=$(SBCL_TOP)/obj/sbcl-home/contrib/
# no trailing slash on DEST. Don't want a "//" in FASL and ASD
DEST=$(SBCL_TOP)/obj/sbcl-home/contrib
FASL=$(DEST)/$(SYSTEM).fasl
ASD=$(DEST)/$(SYSTEM).asd
@ -26,22 +27,15 @@ endif
export CC SBCL EXTRA_CFLAGS
all: $(FASL) $(ASD)
all: $(FASL)
$(FASL)::
$(SBCL) --eval '(setf (sb-ext:readtable-base-char-preference *readtable*) :both)' \
--eval '(declaim (muffle-conditions (and compiler-note (not sb-c::unknown-typep-note))))' \
--load ../asdf-stub.lisp \
--eval '(asdf::build-asdf-contrib "$(SYSTEM)")'
$(ASD)::
echo "(defsystem :$(SYSTEM) :class require-system)" > $@
test: $(FASL) $(ASD)
$(SBCL) --load ../asdf-stub.lisp \
--eval '(asdf::test-asdf-contrib "$(SYSTEM)")'
# KLUDGE: There seems to be no portable way to tell tar to not to
# preserve owner, so chown after installing for the current user.
install:
cp $(FASL) $(ASD) "$(BUILD_ROOT)$(INSTALL_DIR)"
# The explicit use of $wildcard is necessary here. While rules do expand
# wildcards implicitly (so that just "$(FASL): *.lisp" mostly works),
# that specification would fail on the contribs which have no .lisp file
# in the current directory.
# The prerequisite of sb-grovel might be spurious, but I don't want to detect
# whether sb-grovel is actually needed.
# This produces $(ASD) as a side-effect.
$(FASL): $(SBCL_TOP)/output/sbcl.core $(wildcard *.lisp) $(wildcard */*.lisp) \
../sb-grovel/*.lisp
$(SBCL) --load ../make-contrib.lisp "$(SYSTEM)" $(MODULE_REQUIRES) </dev/null

77
contrib/asdf-stub.lisp
View file

@ -1,77 +0,0 @@
(setq *compile-print* nil)
sb-ext::(declaim (muffle-conditions compiler-note))
(require :asdf)
(in-package :asdf)
(defun keywordize (x)
(intern (string-upcase x) :keyword))
sb-ext::(declaim (muffle-conditions sb-kernel:redefinition-warning))
(defun wrapping-source-registry ()
'(:source-registry (:tree #p"SYS:CONTRIB;") :ignore-inherited-configuration))
sb-ext::(declaim (unmuffle-conditions sb-kernel:redefinition-warning))
(defun setup-asdf-contrib ()
;;(setf *resolve-symlinks* nil)
(let* ((sbcl-top (merge-pathnames (getenv-pathname "SBCL_TOP" :ensure-directory t)))
(src-contrib (subpathname sbcl-top "contrib/"))
(asdf-cache (subpathname sbcl-top "obj/asdf-cache/"))
(source-registry '(:source-registry :ignore-inherited-configuration))
(output-translations `(:output-translations (,(namestring src-contrib)
,(namestring asdf-cache))
:ignore-inherited-configuration))
(src.pat (wilden src-contrib))
(src.dir.pat (merge-pathnames* *wild-inferiors* src-contrib))
(out.pat (wilden asdf-cache)))
(ensure-directories-exist asdf-cache)
(setf (logical-pathname-translations "SYS")
`(("CONTRIB;**;*.*.*" ,src.pat))) ;; this makes recursive tree search work.
(initialize-source-registry source-registry)
(initialize-output-translations output-translations)
(setf (logical-pathname-translations "SYS")
(labels ((typepat (type base)
`(,(format nil "CONTRIB;**;*.~:@(~A~).*" type)
,(make-pathname :type (string-downcase type) :defaults base)))
(outpat (type) (typepat type out.pat))
(srcpat (type) (typepat type src.pat))
(outpats (&rest types) (mapcar #'outpat types))
(srcpats (&rest types) (mapcar #'srcpat types)))
`(,@(srcpats :lisp :asd)
,@(outpats :fasl :sbcl-warnings :build-report
:out :exe :lisp-temp :o :c :test-report :html)
("CONTRIB;**;" ,src.dir.pat)
#|("CONTRIB;**;*.*.*" ,src.pat)|#)))
(setf *central-registry* nil)))
(defun build-asdf-contrib (system)
(setq *features*
(append '(:sb-building-contrib) sb-impl:+internal-features+ *features*))
(setup-asdf-contrib)
(let* ((name (string-downcase system))
(sbcl-top (merge-pathnames (getenv-pathname "SBCL_TOP" :ensure-directory t)))
(out-contrib (subpathname sbcl-top "obj/sbcl-home/contrib/"))
(cache-module (subpathname sbcl-top (format nil "obj/asdf-cache/~a/" name)))
(system (find-system name))
(system.fasl (output-file 'compile-bundle-op system))
(module.fasl (subpathname out-contrib (strcat name ".fasl")))
(module-setup.lisp (subpathname cache-module "module-setup.lisp"))
(module-setup.fasl (subpathname cache-module "module-setup.fasl"))
(dependencies (mapcar 'keywordize (component-sideway-dependencies system)))
(input-fasls (list module-setup.fasl system.fasl)))
(ensure-directories-exist out-contrib)
(ensure-directories-exist cache-module)
(with-open-file (o module-setup.lisp
:direction :output :if-exists :rename-and-delete)
(format o "(provide :~A)~%~{(require ~(~S~))~%~}" name dependencies))
(compile-file module-setup.lisp :output-file module-setup.fasl)
(operate 'compile-bundle-op system)
(let ((s (find-symbol "DUMP/RESTORE-INTERESTING-TYPES" "SB-C")))
(when s (funcall s 'write)))
(concatenate-files input-fasls module.fasl)))
(defun test-asdf-contrib (system)
(setq *features*
(append '(:sb-testing-contrib) sb-impl:+internal-features+ *features*))
(setup-asdf-contrib)
(asdf:test-system system))

5
contrib/asdf/Makefile
View file

@ -4,7 +4,7 @@ UIOP_FASL=$(DEST)/uiop.fasl
FASL=$(UIOP_FASL) $(ASDF_FASL)
FROB_READTABLE='(setf (sb-ext:readtable-base-char-preference *readtable*) :both)'
fasl:: $(UIOP_FASL) $(ASDF_FASL)
all:: $(UIOP_FASL) $(ASDF_FASL)
$(UIOP_FASL):: uiop.lisp ../../output/sbcl.core
mkdir -p $(DEST)
$(SBCL) --eval $(FROB_READTABLE) --eval '(compile-file #p"SYS:CONTRIB;ASDF;UIOP.LISP" :print nil :output-file (merge-pathnames (parse-native-namestring "$@")))' </dev/null
@ -17,9 +17,6 @@ $(ASDF_FASL):: asdf.lisp ../../output/sbcl.core $(UIOP_FASL)
install::
cp $(FASL) "$(BUILD_ROOT)$(INSTALL_DIR)"
test:: $(FASL)
true
UPSTREAM=../../obj/asdf-upstream
up::
sh pull-asdf.sh

1
contrib/asdf/uiop.lisp
View file

@ -4925,6 +4925,7 @@ This can help you produce more deterministic output for FASLs."))
(defun sb-grovel-unknown-constant-condition-p (c)
"Detect SB-GROVEL unknown-constant conditions on older versions of SBCL"
(and (typep c 'sb-int:simple-style-warning)
(stringp (simple-condition-format-control c))
(string-enclosed-p
"Couldn't grovel for "
(simple-condition-format-control c)

9
contrib/build-contrib
View file

@ -1,9 +0,0 @@
#!/bin/sh
mkdir -p ../obj/asdf-cache/$@/
if $GNUMAKE -j1 -C $@ test < /dev/null 2>&1 && touch ../obj/asdf-cache/$@/test-passed.test-report ; then
:
else
exit $?
fi | tee ../output/building-contrib.$@

150
contrib/make-contrib.lisp Normal file
View file

@ -0,0 +1,150 @@
(setf (sb-ext:readtable-base-char-preference *readtable*) :both)
(defvar *system* (second sb-ext:*posix-argv*))
;; Convert dep filenames into module names. Depending on whether each Make step
;; saw the fasls as already-existing, or is making them, the dep is either the
;; unadorned fasl name, or containing the 'vpath' in it already.
(defvar *deps*
(mapcar 'string-upcase (mapcar 'pathname-name (cddr sb-ext:*posix-argv*))))
(format t "; Note: Building ~S~@[, deps=~S~]~%" *system* *deps*)
(mapc 'require *deps*)
(declaim (muffle-conditions (and compiler-note (not sb-c::unknown-typep-note))))
(defun run-defs-to-lisp (inputs output)
(flet ((invoke (string &rest args)
(apply (find-symbol string "SB-GROVEL") args)))
(let ((c-file (merge-pathnames "runme.c" output))
(all-headers)
(all-definitions)
(package))
(dolist (input inputs)
(if package
(assert (eq (cdr input) package))
(setf package (cdr input)))
;; Combine input specifications so that we run the C compiler once only
(multiple-value-bind (headers definitions)
(with-open-file (stream (merge-pathnames (make-pathname :type "lisp")
(car input))
:direction :input)
(values (read stream) (read stream)))
(setf all-headers (nconc all-headers headers)) ; can be order-sensitive!
(setf all-definitions (nconc all-definitions definitions))))
(with-open-file (stream c-file :direction :output :if-exists :supersede)
(invoke "PRINT-C-SOURCE" stream all-headers all-definitions package))
(let* ((c-compiler-output (merge-pathnames #+unix "a.out" #+win32 "a.exe" output))
(result (invoke "RUN-C-COMPILER" c-file c-compiler-output)))
(unless (= result 0) (error "C compilation failed"))
(let ((result
(process-exit-code
(run-program (namestring c-compiler-output) (list (namestring output))
:search nil :input nil :output *trace-output*))))
(unless (= result 0) (error "C execution failed")))))))
(defparameter +genfile+ "generated-constants")
(defun perform (defsystem)
(let* ((specified-sources (getf defsystem :components))
;; This path is basically arbitrary. I wanted to avoid creating
;; another directory under "obj/" but alas ...
(objdir (format nil "../../obj/from-self/contrib/~A/" *system*))
(*features* (append '(:sb-building-contrib) *features*
sb-impl:+internal-features+)))
(ensure-directories-exist objdir)
;; For source locations.
;; Even though generated files are not shipped as sources it's
;; better to hide the original pathnames.
(push (list "SYS:OBJ;**;*.*.*"
(merge-pathnames "**/*.*" (truename "../../obj/")))
(logical-pathname-translations "SYS"))
(sb-int:collect ((alien-constants) (flattened-sources) (fasls))
(with-open-file (f (merge-pathnames "module-setup.lisp" objdir)
:direction :output :if-exists :supersede)
(format f "~{(require \"~A\")~%~}" *deps*))
(flattened-sources `(t "module-setup"))
;; Compile all files serially. :depends-on is just documentation for the user
(sb-int:named-let flatten ((prefix "") (sources specified-sources))
(dolist (source sources)
(ecase (car source)
(:module
(let* ((subdir (cadr source))
(pathname (getf source :pathname subdir))
(newprefix (if (string= pathname "")
prefix
(concatenate 'string prefix subdir "/"))))
(unless (string= pathname "")
(ensure-directories-exist (format nil "~A~A" objdir newprefix)))
(flatten newprefix (getf source :components))))
(:file
(let ((if-feature (getf source :if-feature)))
(when (or (not if-feature) (sb-int:featurep if-feature))
(flattened-sources
`(nil ,(concatenate 'string prefix (cadr source)))))))
(:sb-grovel-constants-file
;; We don't run sb-grovel as a contrib module for building other modules.
;; sb-grovel interacts with ASDF when REQUIREd, but this script doesn't.
(destructuring-bind (specfile &key package if-feature &allow-other-keys)
(cdr source)
(assert package)
(when (or (not if-feature) (sb-int:featurep if-feature))
(unless (alien-constants) ; add in a source file
(flattened-sources `(t ,+genfile+)))
(alien-constants (cons specfile package))))))))
(with-open-file (f (merge-pathnames "module-provide.lisp" objdir)
:direction :output :if-exists :supersede)
(format f "(provide \"~A\")~%" (string-upcase *system*)))
(flattened-sources `(t "module-provide"))
(when (alien-constants)
(load "../sb-grovel/defpackage") ; faster to interpret than compile
(let ((*evaluator-mode* :compile)) (load "../sb-grovel/def-to-lisp"))
(run-defs-to-lisp (alien-constants) ; specification files
(format nil "~A~A.lisp" objdir +genfile+)) ; file to generate
;; foreign-glue contains macros needed to compile the generated file
(let ((*evaluator-mode* :compile)) (load "../sb-grovel/foreign-glue")))
(flet ((logicalize (path generated)
(make-pathname :host "SYS"
:directory
(append '(:absolute)
(if generated
(list "OBJ" "FROM-SELF" "CONTRIB" *system*)
(list* "CONTRIB"
(append (last (pathname-directory *default-pathname-defaults*))
(cdr (pathname-directory path))))))
:name (pathname-name path)
:type (pathname-type path))))
(with-compilation-unit ()
(loop for (generated-p stem) in (flattened-sources)
do
(format t "Compile-File ~S~%" stem)
(multiple-value-bind (output warnings errors)
(compile-file (logicalize stem generated-p)
:output-file (format nil "~A~A.fasl" objdir stem))
(declare (ignore warnings))
(when errors (sb-sys:os-exit 1))
(fasls output)
(load output)))))
(let ((outputs (mapcar 'namestring (fasls)))
(joined (format nil "../../obj/sbcl-home/contrib/~A.fasl" *system*)))
(ensure-directories-exist joined)
(with-open-file (asd (merge-pathnames (make-pathname :type "asd") joined)
:direction :output :if-exists :supersede
:if-does-not-exist :create)
(format asd "(defsystem :~A :class require-system)~%" *system*))
(sb-sys:os-exit
(process-status
;; for #+win32 it's probably /usr/bin/cat.exe,
;; for #+unix it's supposed to be /bin/cat, but lp#1995224 says otherwise
(run-program "cat" outputs :search t
:output joined :if-output-exists :supersede)))))))
(compile 'perform)
(let ((form (with-open-file (f (format nil "~A.asd" *system*))
(let ((form (read f)))
;; each .asd file has an ERROR form preventing users from LOADing it
(assert (eq (car form) 'error))
(read f)))))
(let ((eval (getf form :eval)))
(when eval (eval eval)))
(let ((bindings (getf form :bind))
(*compile-verbose* nil)) ; set the default
(progv (mapcar 'first bindings) (mapcar 'second bindings)
(perform form))))

15
contrib/sb-aclrepl/sb-aclrepl.asd
View file

@ -1,24 +1,11 @@
;;; -*- Lisp -*-
#-(or sb-testing-contrib sb-building-contrib)
(error "Can't build contribs with ASDF")
(defsystem "sb-aclrepl"
:author "Kevin Rosenberg <kevin@rosenberg.net>"
:description "An AllegroCL compatible REPL"
#+sb-building-contrib :pathname
#+sb-building-contrib #p"SYS:CONTRIB;SB-ACLREPL;"
:components ((:file "toplevel")
(:file "repl" :depends-on ("toplevel"))
(:file "inspect" :depends-on ("repl"))
(:file "debug" :depends-on ("repl")))
:perform (load-op :after (o c) (provide 'sb-aclrepl))
:in-order-to ((test-op (test-op "sb-aclrepl/tests"))))
(defsystem "sb-aclrepl/tests"
:depends-on ("sb-rt")
:components ((:file "tests")))
(defmethod perform ((o test-op) (c (eql (find-system "sb-aclrepl/tests"))))
(or (funcall (intern "DO-TESTS" (find-package "SB-RT")))
(error "test-op failed")))
(:file "debug" :depends-on ("repl"))))

7
contrib/sb-aclrepl/tests.lisp
View file

@ -1,16 +1,13 @@
;; Tests for sb-aclrepl
(defpackage #:aclrepl-tests
(:use #:sb-aclrepl #:cl #:sb-rt))
(:import-from #:test-util #:deftest)
(:use #:sb-aclrepl #:cl))
(in-package #:aclrepl-tests)
(declaim (special sb-aclrepl::*skip-address-display*
sb-aclrepl::*inspect-unbound-object-marker*))
(setf sb-rt::*catch-errors* nil)
(rem-all-tests)
(deftest hook.1 (boundp 'sb-impl::*inspect-fun*) t)
(deftest hook.2 (boundp 'sb-int:*repl-prompt-fun*) t)
(deftest hook.3 (boundp 'sb-int:*repl-read-form-fun*) t)

38
contrib/sb-bsd-sockets/sb-bsd-sockets.asd
View file

@ -1,19 +1,16 @@
;;; -*- Lisp -*-
#-(or sb-testing-contrib sb-building-contrib)
(error "Can't build contribs with ASDF")
;;; gethostbyname/gethostbyaddr are generally not thread safe. POSIX
;;; 1003.1-2003 defines an alternative API, which is specified in the
;;; RFC to be thread-safe. If it seems to be available, use it.
(when (sb-alien::find-dynamic-foreign-symbol-address "getaddrinfo")
(pushnew :sb-bsd-sockets-addrinfo *features*))
(defsystem "sb-bsd-sockets"
:version "0.59"
:defsystem-depends-on ("sb-grovel")
#+sb-building-contrib :pathname
#+sb-building-contrib #p"SYS:CONTRIB;SB-BSD-SOCKETS;"
;; We don't process random toplevel forms
:eval (when (sb-alien::find-dynamic-foreign-symbol-address "getaddrinfo")
(pushnew :sb-bsd-sockets-addrinfo *features*))
:serial t
:components
((:file "defpackage")
@ -44,31 +41,4 @@
(:file "local" :if-feature (:not :win32))
(:file "name-service")
(:file "misc"))
:perform (load-op :after (o c) (provide 'sb-bsd-sockets))
:in-order-to ((test-op (test-op "sb-bsd-sockets/tests"))))
(defsystem "sb-bsd-sockets/tests"
:depends-on ("sb-rt"
"sb-bsd-sockets"
(:feature (:not :win32) "sb-posix"))
:components ((:file "tests"))
:perform (test-op (o c)
(multiple-value-bind (soft strict pending)
(funcall (intern "DO-TESTS" (find-package "SB-RT")))
(declare (ignorable pending))
(fresh-line)
(unless strict
#+sb-testing-contrib
;; We create TEST-PASSED from a shell script if tests passed. But
;; since the shell script only `touch'es it, we can actually create
;; it ahead of time -- as long as we're certain that tests truly
;; passed, hence the check for SOFT.
(when soft
(with-open-file (s #p"SYS:CONTRIB;SB-BSD-SOCKETS;TEST-PASSED.TEST-REPORT"
:direction :output)
(dolist (pend pending)
(format s "Expected failure: ~A~%" pend))))
(warn "ignoring expected failures in test-op"))
(unless soft
(error "test-op failed with unexpected failures")))))
(:file "misc")))

54
contrib/sb-bsd-sockets/tests.lisp
View file

@ -1,14 +1,9 @@
(defpackage "SB-BSD-SOCKETS-TEST"
(:use "CL" "SB-BSD-SOCKETS" "SB-RT"))
(:import-from #:test-util #:deftest)
(:use "CL" "SB-BSD-SOCKETS"))
(in-package :sb-bsd-sockets-test)
(defmacro deftest* ((name &key fails-on) form &rest results)
`(progn
(when (sb-impl::featurep ',fails-on)
(pushnew ',name sb-rt::*expected-failures*))
(deftest ,name ,form ,@results)))
;;; a real address
(deftest make-inet-address
(equalp (make-inet-address "127.0.0.1") #(127 0 0 1))
@ -56,6 +51,7 @@
:protocol (get-protocol-by-name "tcp"))
(error nil)
(:no-error (x) x))
(format t "~&Will test IPv4~%")
(push :ipv4-support *features*)))
#+ipv4-support
@ -73,7 +69,7 @@
t)
#+ipv4-support
(deftest* (make-inet-socket-wrong)
(deftest make-inet-socket-wrong
;; fail to make a socket: check correct error return. There's no nice
;; way to check the condition stuff on its own, which is a shame
(handler-case
@ -91,7 +87,7 @@
t)
#+ipv4-support
(deftest* (make-inet-socket-keyword-wrong)
(deftest make-inet-socket-keyword-wrong
;; same again with keywords
(handler-case
(make-instance 'inet-socket :type :stream :protocol :udp)
@ -123,18 +119,21 @@
t)
#+ipv4-support
(deftest* (non-block-socket)
(deftest non-block-socket
(let ((s (make-instance 'inet-socket :type :stream :protocol :tcp)))
(setf (non-blocking-mode s) t)
(non-blocking-mode s))
t)
#+ipv4-support
(deftest inet-socket-bind
(test-util:with-test (:name :inet-socket-bind)
(let* ((tcp (get-protocol-by-name "tcp"))
(address (make-inet-address "127.0.0.1"))
(s1 (make-instance 'inet-socket :type :stream :protocol tcp))
(s2 (make-instance 'inet-socket :type :stream :protocol tcp)))
(s2 (make-instance 'inet-socket :type :stream :protocol tcp))
(failure)
(got-addrinuse))
(format t "~&::: INFO: made sockets~%")
(unwind-protect
;; Given the functions we've got so far, if you can think of a
;; better way to make sure the bind succeeded than trying it
@ -143,19 +142,25 @@
(socket-bind s1 address 0)
(handler-case
(let ((port (nth-value 1 (socket-name s1))))
(socket-bind s2 address port)
(socket-bind s2 address port) ; should fail
nil)
(address-in-use-error () t)))
(address-in-use-error () (setq got-addrinuse t))
(condition (c) (setq failure c))))
(socket-close s1)
(socket-close s2)))
t)
(socket-close s2))
(cond (failure (error "BIND failed with ~A" failure))
((not got-addrinuse) (error "Expected ADDRESS-IN-USE err")))))
(deftest inet6-socket-bind
(test-util:with-test (:name :inet6-socket-bind)
(let ((notsupp)
(failure)
(got-addrinuse))
(handler-case
(let* ((tcp (get-protocol-by-name "tcp"))
(address (make-inet6-address "::1"))
(s1 (make-instance 'inet6-socket :type :stream :protocol tcp))
(s2 (make-instance 'inet6-socket :type :stream :protocol tcp)))
(format t "~&::: INFO: made sockets~%")
(unwind-protect
;; Given the functions we've got so far, if you can think of a
;; better way to make sure the bind succeeded than trying it
@ -170,16 +175,20 @@
(declare (ignore x))
(handler-case
(let ((port (nth-value 1 (socket-name s1))))
(socket-bind s2 address port)
(socket-bind s2 address port) ; should fail
nil)
(address-in-use-error () t))))
(address-in-use-error () (setq got-addrinuse t))
(condition (c) (setq failure c)))))
(socket-close s1)
(socket-close s2)))
((or address-family-not-supported protocol-not-supported-error) () t))
t)
((or address-family-not-supported protocol-not-supported-error) ()
(setq notsupp t)))
(cond (notsupp (format t "~&INFO: not supported~%"))
(failure (error "BIND failed with ~A" failure))
((not got-addrinuse) (error "Expected ADDRESS-IN-USE err")))))
#+ipv4-support
(deftest* (simple-sockopt-test)
(deftest simple-sockopt-test
;; test we can set SO_REUSEADDR on a socket and retrieve it, and in
;; the process that all the weird macros in sockopt happened right.
(let ((s (make-instance 'inet-socket :type :stream :protocol (get-protocol-by-name "tcp"))))
@ -367,6 +376,7 @@
(lambda ()
(socket-connect client-sock #(127 0 0 1) port)
(socket-close client-sock)))))
(sb-thread:join-thread client-connect-thread :timeout 20)
(setf server-sock (socket-accept listen-sock)))
;; Wait for input. This should return when we get EOF

16
contrib/sb-capstone/sb-capstone.asd
View file

@ -1,4 +1,3 @@
#-(or sb-testing-contrib sb-building-contrib)
(error "Can't build contribs with ASDF")
(defsystem "sb-capstone"
@ -6,17 +5,4 @@
:version "0.1"
:description "Multi-target disassembly for SBCL using Capstone library"
:serial t
:components ((:file "capstone"))
:perform (load-op :after (o c) (provide 'sb-capstone))
:in-order-to ((test-op (test-op "sb-capstone/tests"))))
(defsystem "sb-capstone/tests"
:depends-on ("sb-capstone" "sb-rt")
:version "0.1"
:components ((:file "tests")))
(defmethod perform ((o test-op) (c (eql (find-system "sb-capstone/tests"))))
(if (member :sb-capstone *features*)
(or (funcall (intern "DO-TESTS" (find-package "SB-RT")))
(error "test-op failed"))
(warn "Could not test sb-capstone")))
:components ((:file "capstone")))

5
contrib/sb-capstone/tests.lisp
View file

@ -58,6 +58,10 @@
(every #'(lambda (instruction) (search instruction instructions))
instructions-to-check))))))
#|
;;; Someone needs to fix these.
;;; See https://groups.google.com/g/sbcl-help-archive/c/FxDjTHaPnik/m/mIFJTe9-AQAJ
(deftest x86-64 (capstone-check '(#x8F #x45 #x08 #x48 #x8B #xF0)
'(:x86-64 :little-endian)
'("MOV RSI, RAX"
@ -75,3 +79,4 @@
'(:ppc64 :big-endian)
'("MFLR R0"))
t)
|#

2
contrib/sb-cltl2/compiler-let.lisp
View file

@ -51,7 +51,7 @@
#+sb-fasteval
(sb-interpreter::defspecial compiler-let (bindings &body body)
:deferred (env)
(funcall (info :function :interpreter 'let)
(funcall (car (sb-interpreter::special-form-handler 'let))
`(,bindings
(declare (special
,@(mapcar (lambda (binding)

17
contrib/sb-cltl2/env.lisp
View file

@ -80,7 +80,7 @@
(dolist (name function)
(clambdas
(sb-c::make-lambda
(sb-c::make-clambda
:lexenv *null-lexenv*
:%source-name name
:allow-instrumenting nil)))
@ -123,11 +123,10 @@
(when env
(let ((ret nil))
(dolist (entry (sb-c::lexenv-user-data env))
(destructuring-bind
(entry-keyword entry-var entry-binding &rest entry-cons)
entry
(when (and (eq keyword entry-keyword)
(typecase binding
(when (eq (car entry) keyword)
(destructuring-bind (entry-var entry-binding &rest entry-cons)
(cdr entry)
(when (typecase binding
(sb-c::global-var
(and (eq var entry-var)
(typecase entry-binding
@ -137,8 +136,8 @@
(null t)
(t nil))))
(t
(eq binding entry-binding))))
(push entry-cons ret))))
(eq binding entry-binding)))
(push entry-cons ret)))))
(nreverse ret))))
(defun maybe-deprecation-entry (info)
@ -443,7 +442,7 @@ appear."
(info :variable :deprecated name))
(extra-pairs :variable name var *lexenv*)))))
;;; Unlike policy-related declarations which the interpeter itself needs
;;; Unlike policy-related declarations which the interpreter itself needs
;;; for correct operation of some macros, muffled conditions are irrelevant,
;;; since warnings are not signaled much, if at all.
;;; This is even more useless than env-package-locks.

15
contrib/sb-cltl2/sb-cltl2.asd
View file

@ -1,21 +1,8 @@
;;; -*- Lisp -*-
#-(or sb-testing-contrib sb-building-contrib)
(error "Can't build contribs with ASDF")
(defsystem "sb-cltl2"
:description "Functionality mentioned in CLtL2 but not present in ANSI."
#+sb-building-contrib :pathname
#+sb-building-contrib #p"SYS:CONTRIB;SB-CLTL2;"
:components ((:file "defpackage")
(:file "compiler-let" :depends-on ("defpackage"))
(:file "env" :depends-on ("defpackage")))
:perform (load-op :after (o c) (provide 'sb-cltl2))
:in-order-to ((test-op (test-op "sb-cltl2/tests"))))
(defsystem "sb-cltl2/tests"
:depends-on ("sb-rt")
:components ((:file "tests")))
(defmethod perform ((o test-op) (c (eql (find-system "sb-cltl2/tests"))))
(or (funcall (find-symbol "DO-TESTS" "SB-RT"))
(error "test-op failed")))
(:file "env" :depends-on ("defpackage"))))

112
contrib/sb-cltl2/tests.lisp
View file

@ -5,24 +5,23 @@
;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.
;; Undo default contribs mufflage so that DECLARATION-INFORMATION tests pass.
sb-ext::(declaim (unmuffle-conditions compiler-note))
;; These tests pass under sb-interpreter but not sb-eval
#+interpreter (unless (find-package "SB-INTERPRETER") (invoke-restart 'run-tests::skip-file))
(defpackage :sb-cltl2-tests
(:use :sb-cltl2 :cl :sb-rt :sb-ext :sb-kernel :sb-int))
(:import-from #:test-util #:deftest)
(:use :sb-cltl2 :cl :sb-ext :sb-kernel :sb-int))
(in-package :sb-cltl2-tests)
(rem-all-tests)
(defmacro *x*-value ()
(declare (special *x*))
*x*)
(defmacro x-value ()
(declare (special x))
x)
(deftest compiler-let.1
(let ((*x* :outer))
(compiler-let ((*x* :inner))
(list *x* (*x*-value))))
(let ((x :outer))
(compiler-let ((x :inner))
(list x (x-value))))
;; See the X3J13 writeup for why the interpreter
;; might return (and does return) a different answer.
#.(if (eq sb-ext:*evaluator-mode* :compile)
@ -105,6 +104,7 @@ sb-ext::(declaim (unmuffle-conditions compiler-note))
t)
(deftest macroexpand-all.9
(let ((global-symbol-macro 3))
(declare (ignore global-symbol-macro))
(macrolet ((frob (&environment env form)
`',(macroexpand-all form env)))
(equalp (frob global-symbol-macro) 'global-symbol-macro)))
@ -284,6 +284,7 @@ sb-ext::(declaim (unmuffle-conditions compiler-note))
(deftest variable-info.local-special/shadows-lexical
(let ((x 3))
(declare (ignore x))
(let ((x 3))
(declare (special x))
(var-info x)))
@ -291,12 +292,14 @@ sb-ext::(declaim (unmuffle-conditions compiler-note))
(deftest variable-info.lexical
(let ((x 8))
x
(var-info x))
(:lexical t nil))
(deftest variable-info.lexical.type
(let ((x 42))
(declare (fixnum x))
x
(var-info x))
(:lexical t ((type . fixnum))))
@ -310,6 +313,7 @@ sb-ext::(declaim (unmuffle-conditions compiler-note))
(deftest variable-info.lexical.type.3
(let ((x 42))
x
(locally (declare (fixnum x))
(var-info x)))
(:lexical t ((type . fixnum))))
@ -533,17 +537,17 @@ sb-ext::(declaim (unmuffle-conditions compiler-note))
'foo
(augment-environment nil
:function '(foo)
:declare '((ftype (sfunction (integer) integer) foo))))
:declare '((ftype (sfunction () integer) foo))))
:function
t
((ftype function (integer) (values integer &optional))))
((ftype function () (values integer &optional))))
(deftest augment-environment.macro
(macroexpand '(mac feh)
(augment-environment
nil
:macro (list (list 'mac #'(lambda (form benv)
:macro (list (list 'mac #'(lambda (form env)
(declare (ignore env))
`(quote ,form ,form ,form))))))
(quote (mac feh) (mac feh) (mac feh))
@ -567,6 +571,7 @@ sb-ext::(declaim (unmuffle-conditions compiler-note))
(deftest augment-environment.nest
(let ((x 1))
(declare (ignore x))
(ct
(let* ((e (augment-environment lexenv :variable '(y))))
(list
@ -601,11 +606,11 @@ sb-ext::(declaim (unmuffle-conditions compiler-note))
(declare (ignore ,a ,b))
,c)))
(deftest define-declaration.declare
(progn
(define-declaration zaphod (spec env)
(declare (ignore env))
(values :declare (cons 'zaphod spec)))
(deftest define-declaration.declare
(progn
(locally (declare (zaphod beblebrox))
(locally (declare (zaphod and ford))
(ct (declaration-information 'zaphod lexenv)))))
@ -614,20 +619,17 @@ sb-ext::(declaim (unmuffle-conditions compiler-note))
(deftest define-declaration.declare2
(progn
(define-declaration zaphod (spec env)
(declare (ignore env))
(values :declare (cons 'zaphod spec)))
(locally
(declare (zaphod beblebrox)
(special x))
(ct (declaration-information 'zaphod lexenv))))
(zaphod beblebrox))
(deftest define-declaration.variable
(progn
(define-declaration vogon (spec env)
(declare (ignore env))
(values :variable `((,(cadr spec) vogon-key vogon-value))))
(deftest define-declaration.variable
(progn
(locally (declare (vogon poetry))
(ct
(assoc 'vogon-key
@ -640,9 +642,6 @@ sb-ext::(declaim (unmuffle-conditions compiler-note))
(deftest define-declaration.variable.special
(progn
(define-declaration vogon (spec env)
(declare (ignore env))
(values :variable `((,(cadr spec) vogon-key vogon-value))))
(let (x)
(declare (vogon x))
(declare (special x))
@ -654,9 +653,6 @@ sb-ext::(declaim (unmuffle-conditions compiler-note))
(deftest define-declaration.variable.special2
(progn
(define-declaration vogon (spec env)
(declare (ignore env))
(values :variable `((,(cadr spec) vogon-key vogon-value))))
(let (x)
(declare (special x))
(declare (vogon x))
@ -668,12 +664,11 @@ sb-ext::(declaim (unmuffle-conditions compiler-note))
(deftest define-declaration.variable.mask
(progn
(define-declaration vogon (spec env)
(declare (ignore env))
(values :variable `((,(cadr spec) vogon-key vogon-value))))
(let (x)
(declare (vogon x))
(declare (vogon x)
(ignore x))
(let (x)
(declare (ignore x))
(ct
(assoc
'vogon-key
@ -682,11 +677,9 @@ sb-ext::(declaim (unmuffle-conditions compiler-note))
(deftest define-declaration.variable.macromask
(progn
(define-declaration vogon (spec env)
(declare (ignore env))
(values :variable `((,(cadr spec) vogon-key vogon-value))))
(let (x)
(declare (vogon x))
(declare (vogon x)
(ignore x))
(symbol-macrolet ((x 42))
(ct
(assoc
@ -696,13 +689,12 @@ sb-ext::(declaim (unmuffle-conditions compiler-note))
(deftest define-declaration.variable.macromask2
(progn
(define-declaration vogon (spec env)
(declare (ignore env))
(values :variable `((,(cadr spec) vogon-key vogon-value))))
(symbol-macrolet ((x 42))
(declare (vogon x))
(declare (vogon x)
(ignore x))
(list
(let (x)
(declare (ignore x))
(ct
(assoc
'vogon-key
@ -713,18 +705,21 @@ sb-ext::(declaim (unmuffle-conditions compiler-note))
(third (multiple-value-list (variable-information 'x lexenv))))))))
(nil (vogon-key . vogon-value)))
(deftest define-declaration.variable.mask2
(progn
(define-declaration vogon-a (spec env)
(declare (ignore env))
(values :variable `((,(cadr spec) vogon-key a))))
(define-declaration vogon-b (spec env)
(declare (ignore env))
(values :variable `((,(cadr spec) vogon-key b))))
(values :variable `((,(cadr spec) vogon-key b)))))
(deftest define-declaration.variable.mask2
(progn
(let (x)
(declare (vogon-a x))
(declare (vogon-a x)
(ignore x))
(let (x)
(declare (vogon-b x)))
(declare (vogon-b x)
(ignore x)))
(ct
(assoc
'vogon-key
@ -747,11 +742,11 @@ sb-ext::(declaim (unmuffle-conditions compiler-note))
(deftest define-declaration.function
(progn
(define-declaration sad (spec env)
(declare (ignore env))
(values :function `((,(cadr spec) emotional-state sad))))
(deftest define-declaration.function
(progn
(locally (declare (zaphod beblebrox))
(locally (declare (sad robot))
(ct
@ -763,9 +758,6 @@ sb-ext::(declaim (unmuffle-conditions compiler-note))
(deftest define-declaration.function.lexical
(progn
(define-declaration sad (spec env)
(declare (ignore env))
(values :function `((,(cadr spec) emotional-state sad))))
(flet ((robot nil))
(locally (declare (sad robot))
(ct
@ -778,9 +770,6 @@ sb-ext::(declaim (unmuffle-conditions compiler-note))
(deftest define-declaration.function.lexical2
(progn
(define-declaration sad (spec env)
(declare (ignore env))
(values :function `((,(cadr spec) emotional-state sad))))
(labels ((robot nil))
(declare (sad robot))
(ct
@ -792,9 +781,6 @@ sb-ext::(declaim (unmuffle-conditions compiler-note))
(deftest define-declaration.function.mask
(progn
(define-declaration sad (spec env)
(declare (ignore env))
(values :function `((,(cadr spec) emotional-state sad))))
(labels ((robot nil))
(declare (sad robot))
(labels ((robot nil))
@ -808,9 +794,6 @@ sb-ext::(declaim (unmuffle-conditions compiler-note))
(deftest define-declaration.function.mask2
(progn
(define-declaration sad (spec env)
(declare (ignore env))
(values :function `((,(cadr spec) emotional-state sad))))
(locally
(declare (sad robot))
(labels ((robot nil))
@ -821,11 +804,11 @@ sb-ext::(declaim (unmuffle-conditions compiler-note))
lexenv)))))))
nil)
(deftest define-declaration.function2
(progn
(define-declaration happy (spec env)
(declare (ignore env))
(values :function `((,(cadr spec) emotional-state happy))))
(deftest define-declaration.function2
(progn
(locally (declare (zaphod beblebrox))
(locally (declare (sad robot))
(locally (declare (happy robot))
@ -857,3 +840,14 @@ sb-ext::(declaim (unmuffle-conditions compiler-note))
(list (eval form)
(eval (sb-cltl2:macroexpand-all form))))
(:good :good))
(deftest with-a-compiler-macro
(multiple-value-bind (fun w f)
(compile nil '(lambda ()
(define-compiler-macro #1=#:cm ()
(macrolet ((env (&environment env)
(sb-cltl2:function-information '#1# env)))
(env)))))
(declare (ignore fun))
(or w f))
nil)

49
contrib/sb-concurrency/queue.lisp
View file

@ -144,3 +144,52 @@ must walk the entire queue."
(defun queue-empty-p (queue)
"Returns T if QUEUE is empty, NIL otherwise."
(null (cdr (queue-head queue))))
;;; Experimental support for compiling in the background.
;;; The use-case is that you have some functions which you'll need later,
;;; but want to pass them around now as compiled-functions without waiting
;;; for COMPILE. If the timing is right, the compiler will be done by the time
;;; of the call to such functions, but if not, that's OK - it just works.
#+(and x86-64 sb-thread)
(progn
(define-load-time-global *compilation-queue* (make-queue :name "compiler"))
(defun run-background-compile (&aux compiled)
(loop
(let ((item (dequeue *compilation-queue*)))
(unless item (return compiled))
(setq compiled t)
(let ((fin (elt (the (simple-vector 3) item) 0))
(lexpr (elt item 1)))
(multiple-value-bind (compiled-function warnings errors) (compile nil lexpr)
(declare (ignore warnings))
;; It's OK for a closure's raw addr slot to point directly to an address
;; within a code blob, but I'm not sure if it's legal in a funinstance.
;; Probably need to tweak the GC to allow it. Then we would bypass
;; the embedded trampoline for anonymous call; the caller would jump
;; directly to where the call is intended to end up.
(setf (sb-kernel:%funcallable-instance-fun fin)
(if errors
(lambda (&rest args)
(declare (ignore args))
(error "Compiling ~S failed" fin))
(lambda (&rest args)
(apply compiled-function args))))
(signal-semaphore (elt item 2) (ash most-positive-fixnum -1)))))))
(setq sb-impl::*bg-compiler-function* #'run-background-compile)
(defun promise-compile (lexpr)
(let ((fin (%primitive sb-vm::fixed-alloc 'fin 5
sb-vm:funcallable-instance-widetag
sb-vm:fun-pointer-lowtag nil))
(sem (make-semaphore)))
(sb-kernel:%set-fun-layout fin (sb-kernel:find-layout 'function))
(sb-vm::write-funinstance-prologue fin)
(setf (sb-kernel:%funcallable-instance-fun fin)
(lambda (&rest args)
(wait-on-semaphore sem)
(apply fin args)))
(enqueue (vector fin lexpr sem) *compilation-queue*)
(sb-impl::finalizer-thread-notify)
fin)))

38
contrib/sb-concurrency/sb-concurrency.asd
View file

@ -9,7 +9,6 @@
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
#-(or sb-testing-contrib sb-building-contrib)
(error "Can't build contribs with ASDF")
(defsystem "sb-concurrency"
@ -17,39 +16,4 @@
(:file "frlock" :depends-on ("package"))
(:file "queue" :depends-on ("package"))
(:file "mailbox" :depends-on ("package" "queue"))
(:file "gate" :depends-on ("package")))
:perform (load-op :after (o c) (provide 'sb-concurrency))
:in-order-to ((test-op (test-op "sb-concurrency/tests"))))
(defsystem "sb-concurrency/tests"
:depends-on ("sb-concurrency" "sb-rt")
:components
((:module tests
:components
((:file "package")
(:file "test-utils" :depends-on ("package"))
(:file "test-frlock" :depends-on ("package" "test-utils"))
(:file "test-queue" :depends-on ("package" "test-utils"))
(:file "test-mailbox" :depends-on ("package" "test-utils"))
(:file "test-gate" :depends-on ("package" "test-utils"))))))
(defmethod perform ((o test-op)
(c (eql (find-system "sb-concurrency/tests"))))
(multiple-value-bind (soft strict pending)
(funcall (intern "DO-TESTS" (find-package "SB-RT")))
(declare (ignorable pending))
(fresh-line)
(unless strict
#+sb-testing-contrib
;; We create TEST-PASSED from a shell script if tests passed. But
;; since the shell script only `touch'es it, we can actually create
;; it ahead of time -- as long as we're certain that tests truly
;; passed, hence the check for SOFT.
(when soft
(with-open-file (s #p"SYS:CONTRIB;SB-CONCURRENCY;TEST-PASSED"
:direction :output)
(dolist (pend pending)
(format s "Expected failure: ~A~%" pend))))
(warn "ignoring expected failures in test-op"))
(unless soft
(error "test-op failed with unexpected failures"))))
(:file "gate" :depends-on ("package"))))

3
contrib/sb-concurrency/tests/package.lisp
View file

@ -2,4 +2,5 @@
(in-package :cl-user)
(defpackage :sb-concurrency-test
(:use :cl :sb-thread :sb-concurrency :sb-rt))
(:import-from #:test-util #:deftest)
(:use :cl :sb-thread :sb-concurrency))

8
contrib/sb-concurrency/tests/test-frlock.lisp
View file

@ -11,12 +11,6 @@
(in-package :sb-concurrency-test)
(defmacro deftest* ((name &key fails-on) form &rest results)
`(progn
(when (sb-impl::featurep ',fails-on)
(pushnew ',name sb-rt::*expected-failures*))
(deftest ,name ,form ,@results)))
;; XXX something like clock_getres(CLOCK_REALTIME, ...) would be better
(defvar *minimum-sleep*
#+(or openbsd netbsd sunos) 0.01
@ -87,7 +81,7 @@
(values (cdr w-e!) (cdr r-e!))))
#+sb-thread
(deftest* (frlock.1)
(deftest frlock.1
(handler-case
(sb-ext:with-timeout 40
(test-frlocks #+win32 :outer-write-pause #+win32 t ))

2
contrib/sb-concurrency/tests/test-gate.lisp
View file

@ -72,7 +72,6 @@
;; once the gate is closed.
(deftest gate.2
(let* ((gate (make-gate))
(cont (make-gate))
(marks (make-array (if (> *cpus* 1) 100 50) :initial-element nil))
(threads (loop for i from 0 below (length marks)
collect (make-thread (lambda (n)
@ -109,6 +108,7 @@
(block nil
(handler-bind ((sb-sys:deadline-timeout
#'(lambda (c)
(declare (ignore c))
(return :deadline))))
(sb-sys:with-deadline (:seconds 0.1)
(wait-on-gate gate))))))))

1
contrib/sb-concurrency/tests/test-mailbox.lisp
View file

@ -219,6 +219,7 @@
repeat 99
do (kill-thread victim)
(sleep (random 0.0001)))))
(declare (ignore errors))
(values
;; We may have killed a receiver before it got to incrementing
;; the counter.

35
contrib/sb-concurrency/tests/test-queue.lisp
View file

@ -260,3 +260,38 @@
(= n cc (1+ c))
(= n dc (1+ d)))))))
t)
;;; I don't remember if funcallable instances with #-immobile-space
;;; work the way I need them to for this test.
#+(and sb-thread x86-64 immobile-space)
(progn
(defvar *bigfun*
'(lambda (arg)
(macrolet ((foo (x)
(sleep .2) ; brute-force the "slow-to-compile" aspect
`(list ,x)))
(foo arg)))
"A hypothetical function that is slow to compile")
(defun test-non-bg-compile ()
(let ((f (compile nil *bigfun*)))
(sleep .2)
(funcall f 'x)))
(defun test-bg-compile ()
(let ((f (sb-concurrency::promise-compile *bigfun*)))
(sleep .2)
(funcall f 'x)))
(defun seconds-to-call (f label)
(let ((before (get-internal-real-time)))
(funcall f)
(let* ((after (get-internal-real-time))
(sec (float (/ (- after before) internal-time-units-per-second))))
(format t "~&::: INFO: ~A time = ~F~%" label sec)
sec)))
(test-util:with-test (:name :compilation-queue :skipped-on :sbcl)
(when (>= *cpus* 2)
;; serial execution should take at least .2 + .2 sec = .4 sec
(assert (>= (seconds-to-call 'test-non-bg-compile "Serial") .39))
;; concurrent execution should take about .2 sec
;; but again leave some wiggle room
(assert (<= (seconds-to-call 'test-bg-compile "Parallel") .25)))))

8
contrib/sb-concurrency/tests/test-utils.lisp
View file

@ -15,13 +15,7 @@
#+sb-thread
(progn
(defvar *cpus*
(max 1
#-win32 (sb-alien:alien-funcall
(sb-alien:extern-alien "sysconf"
(function sb-alien:long sb-alien:int))
sb-unix::sc-nprocessors-onln)
#+win32 (sb-alien:extern-alien "os_number_of_processors" sb-alien:int)))
(defvar *cpus* test-util:*n-cpus*)
(defparameter +timeout+ 30.0)

9
contrib/sb-cover/cover.lisp
View file

@ -672,9 +672,10 @@ The source locations are stored in SOURCE-MAP."
(return-from return
(sb-impl::read-list stream ignore)))
(let* ((thelist (list nil))
(rt *readtable*)
(listtail thelist))
(do ((firstchar (sb-impl::flush-whitespace stream)
(sb-impl::flush-whitespace stream)))
(do ((firstchar (sb-impl::flush-whitespace stream rt)
(sb-impl::flush-whitespace stream rt)))
((char= firstchar #\) ) (cdr thelist))
(when (char= firstchar #\.)
(let ((nextchar (read-char stream t)))
@ -684,8 +685,8 @@ The source locations are stored in SOURCE-MAP."
(sb-int:simple-reader-error
stream
"Nothing appears before . in list.")))
((sb-impl::whitespace[2]p nextchar)
(setq nextchar (sb-impl::flush-whitespace stream))))
((sb-impl::whitespace[2]p nextchar rt)
(setq nextchar (sb-impl::flush-whitespace stream rt))))
(rplacd listtail
(sb-impl::read-after-dot
stream nextchar (if *read-suppress* 0 -1)))

13
contrib/sb-cover/sb-cover.asd
View file

@ -1,18 +1,7 @@
;;; -*- Lisp -*-
#-(or sb-testing-contrib sb-building-contrib)
(error "Can't build contribs with ASDF")
(defsystem "sb-cover"
#+sb-building-contrib :pathname
#+sb-building-contrib #p"SYS:CONTRIB;SB-COVER;"
:depends-on ("sb-md5")
:components ((:file "cover"))
:perform (load-op :after (o c) (provide 'sb-cover))
:in-order-to ((test-op (test-op "sb-cover/tests"))))
(defsystem "sb-cover/tests"
#+sb-building-contrib :pathname
#+sb-building-contrib #p"SYS:CONTRIB;SB-COVER;"
:depends-on ("sb-cover" "asdf")
:components ((:file "tests")))
:components ((:file "cover")))

14
contrib/sb-cover/test-data-5.lisp Normal file
View file

@ -0,0 +1,14 @@
(declaim (optimize sb-c:store-coverage-data))
(defun outer ()
(catch 'tag
(inner)
(print "returned from inner")))
(defun inner ()
(print "inside inner")
(thrower)
(print "after thrower"))
(defun thrower ()
(throw 'tag :good))

8
contrib/sb-cover/test-data-6.lisp Normal file
View file

@ -0,0 +1,8 @@
(declaim (optimize sb-c:store-coverage-data))
(defun nlx-from-flet ()
(flet ((foo (x)
(return-from nlx-from-flet x)))
(foo 3)
(print "reached")
(foo 4)))

48
contrib/sb-cover/tests.lisp
View file

@ -1,19 +1,13 @@
(defpackage sb-cover-test (:use :cl :asdf :uiop))
(defpackage sb-cover-test (:use :cl))
(in-package sb-cover-test)
(defparameter *source-directory*
(system-source-directory :sb-cover))
(defparameter *output-directory*
(apply-output-translations *source-directory*))
(setf *default-pathname-defaults* (translate-logical-pathname *default-pathname-defaults*))
(defparameter *source-directory* cl-user::*source-directory*)
(defparameter *output-directory* cl-user::*coverage-report-directory*)
(defun compile-load (x)
(flet ((in-dir (dir type)
(translate-logical-pathname (subpathname dir x :type type))))
(load (compile-file (in-dir *source-directory* "lisp")
:output-file (in-dir *output-directory* "fasl")))))
(load (compile-file (merge-pathnames (merge-pathnames x ".*lisp") *source-directory*)
:output-file *output-directory*)))
(defun report ()
(handler-case
@ -41,13 +35,14 @@
(catch 'ok
(handler-case
(sb-cover:report #p"/tmp/foo")
(error ()
(throw 'ok nil)))
(error (c)
(when (search "does not designate a directory" (princ-to-string c))
(throw 'ok nil))))
(error "REPORT with a non-pathname directory did not signal an error."))
(report)
(assert (probe-file (subpathname *output-directory* "cover-index.html")))
(assert (probe-file (merge-pathnames "cover-index.html" *output-directory*)))
;;; Only the top level forms have been executed
(assert (zerop (sb-cover::ok-of (getf sb-cover::*counts* :branch))))
@ -133,6 +128,25 @@
(assert (= (sb-cover::ok-of (getf sb-cover::*counts* :expression))
(sb-cover::all-of (getf sb-cover::*counts* :expression))))
;; Clean up after the tests
(map nil #'delete-file
(directory (merge-pathnames #p"*.html" *output-directory*)))
;; Make sure we handle non-local exits from function calls correctly.
(sb-cover:clear-coverage)
(compile-load "test-data-5")
(outer)
(report)
(assert (zerop (sb-cover::ok-of (getf sb-cover::*counts* :branch))))
(assert (zerop (sb-cover::all-of (getf sb-cover::*counts* :branch))))
(assert (= 12 (sb-cover::ok-of (getf sb-cover::*counts* :expression))))
(assert (= 16 (sb-cover::all-of (getf sb-cover::*counts* :expression))))
;; And then ensure that non-local exits from local calls are handled
;; correctly as well.
(sb-cover:clear-coverage)
(compile-load "test-data-6")
(nlx-from-flet)
(report)
(assert (zerop (sb-cover::ok-of (getf sb-cover::*counts* :branch))))
(assert (zerop (sb-cover::all-of (getf sb-cover::*counts* :branch))))
(assert (= 7 (sb-cover::ok-of (getf sb-cover::*counts* :expression))))
(assert (= 11 (sb-cover::all-of (getf sb-cover::*counts* :expression))))

7
contrib/sb-executable/sb-executable.asd
View file

@ -1,10 +1,5 @@
#-(or sb-testing-contrib sb-building-contrib)
(error "Can't build contribs with ASDF")
(defsystem "sb-executable"
:description "Concatenate FASLs into an executable file."
#+sb-building-contrib :pathname
#+sb-building-contrib #p"SYS:CONTRIB;SB-EXECUTABLE;"
:components ((:file "sb-executable"))
:perform (load-op :after (o c) (provide 'sb-executable))
:perform (test-op (o c) t))
:components ((:file "sb-executable")))

23
contrib/sb-gmp/gmp.lisp
View file

@ -428,6 +428,16 @@ pre-allocated bignum. The allocated bignum-length must be (1+ COUNT)."
,@clears
(values ,@results)))))))
(defun mpz->bignum (z)
"Convert a GMP MPZ Z into a Lisp BIGNUM."
(let* ((size (abs (sb-alien:slot z 'mp_size)))
(neg? (minusp (sb-alien:slot z 'mp_size)))
(bigint (allocate-bignum (1+ size))))
(sb-sys:with-pinned-objects (bigint)
(* (if neg? -1 1)
(gmp-z-to-bignum (slot z 'mp_d) bigint size)))))
;;; function definition and foreign function relationships
(defmacro defgmpfun (name args &body body)
`(progn
@ -766,6 +776,19 @@ pre-allocated bignum. The allocated bignum-length must be (1+ COUNT)."
(bignum-data-sap ad))
,@body))))))
(defun mpq->rational (q)
"Convert a GMP MPQ into a Lisp RATIONAL."
(sb-kernel:build-ratio (mpz->bignum (slot q 'mp_num))
(mpz->bignum (slot q 'mp_den))))
(declaim (inline __gmpq_init))
(define-alien-routine __gmpq_init void
(x (* (struct gmprat))))
(declaim (inline __gmpq_clear))
(define-alien-routine __gmpq_clear void
(x (* (struct gmprat))))
(defmacro defmpqfun (name gmpfun)
`(progn
(declaim (sb-ext:maybe-inline ,name))

21
contrib/sb-gmp/sb-gmp.asd
View file

@ -1,4 +1,3 @@
#-(or sb-testing-contrib sb-building-contrib)
(error "Can't build contribs with ASDF")
(defsystem "sb-gmp"
@ -6,22 +5,4 @@
:version "0.1"
:description "bignum calculations for SBCL using the GMP library"
:serial t
:components ((:file "gmp"))
:perform (load-op :after (o c) (provide 'sb-gmp))
:in-order-to ((test-op (test-op "sb-gmp/tests"))))
(defsystem "sb-gmp/tests"
:depends-on ("sb-rt" "sb-gmp")
:components ((:file "tests")))
(defmethod perform ((o test-op) (c (eql (find-system "sb-gmp/tests"))))
(if (not (member :sb-gmp *features*))
(warn "unable to test sb-gmp: libgmp unavailable")
(multiple-value-bind (soft strict pending)
(funcall (intern "DO-TESTS" (find-package "SB-RT")))
(declare (ignorable pending))
(fresh-line)
(unless strict
(warn "ignoring expected failures in sb-gmp-tests"))
(unless soft
(error "sb-gmp-tests failed with unexpected failures")))))
:components ((:file "gmp")))

3
contrib/sb-gmp/tests.lisp
View file

@ -1,5 +1,6 @@
(defpackage "SB-GMP-TESTS"
(:use "COMMON-LISP" "SB-GMP" "SB-RT"))
(:import-from #:test-util #:deftest)
(:use "COMMON-LISP" "SB-GMP"))
(in-package "SB-GMP-TESTS")

5
contrib/sb-graph/example/testfile.lisp
View file

@ -1,5 +0,0 @@
(defun foo (a b)
(+ a b))
(defun bar (b c d)
(* (foo b c) d))

367
contrib/sb-graph/example/trace-1-DEFUNFOO.dot
View file

@ -1,367 +0,0 @@
digraph {
"{0} COMPONENT [NIL]: ''DEFUN FOO''" -> "{1} CBLOCK [3101743450240528196]"[label="head"];
"{0} COMPONENT [NIL]: ''DEFUN FOO''" -> "{2} CBLOCK [2506100549378885246]"[label="tail"];
"{1} CBLOCK [3101743450240528196]" -> "{0} COMPONENT [NIL]: ''DEFUN FOO''"[label="component"];
"{1} CBLOCK [3101743450240528196]" -> "{3} CBLOCK [3432958294353052646]"[label="succ[# 0]"];
"{1} CBLOCK [3101743450240528196]" -> "{4} CBLOCK [1030293972324225963]"[label="succ[# 1]"];
"{3} CBLOCK [3432958294353052646]" -> "{0} COMPONENT [NIL]: ''DEFUN FOO''"[label="component"];
"{3} CBLOCK [3432958294353052646]" -> "{5} CBLOCK [3418937811103477267]"[label="succ[# 0]"];
"{3} CBLOCK [3432958294353052646]" -> "{4} CBLOCK [1030293972324225963]"[label="pred[# 0]"];
"{3} CBLOCK [3432958294353052646]" -> "{1} CBLOCK [3101743450240528196]"[label="pred[# 1]"];
"{3} CBLOCK [3432958294353052646]" -> "{6} BIND [3685440732622309514]"[label="start[ctran: BLOCK-START]"color="blue"];
"{5} CBLOCK [3418937811103477267]" -> "{0} COMPONENT [NIL]: ''DEFUN FOO''"[label="component"];
"{5} CBLOCK [3418937811103477267]" -> "{7} CBLOCK [577634977173467407]"[label="succ[# 0]"];
"{5} CBLOCK [3418937811103477267]" -> "{3} CBLOCK [3432958294353052646]"[label="pred[# 0]"];
"{5} CBLOCK [3418937811103477267]" -> "{8} ENTRY [1798174669859920552]:
"[label="start[ctran: BLOCK-START]"color="blue"];
"{7} CBLOCK [577634977173467407]" -> "{0} COMPONENT [NIL]: ''DEFUN FOO''"[label="component"];
"{7} CBLOCK [577634977173467407]" -> "{2} CBLOCK [2506100549378885246]"[label="succ[# 0]"];
"{7} CBLOCK [577634977173467407]" -> "{5} CBLOCK [3418937811103477267]"[label="pred[# 0]"];
"{7} CBLOCK [577634977173467407]" -> "{9} CRETURN [3318805410236664255]:
result-type: #<VALUES-TYPE (VALUES NUMBER &OPTIONAL)>"[label="start[ctran: BLOCK-START]"color="blue"];
"{2} CBLOCK [2506100549378885246]" -> "{0} COMPONENT [NIL]: ''DEFUN FOO''"[label="component"];
"{2} CBLOCK [2506100549378885246]" -> "{7} CBLOCK [577634977173467407]"[label="pred[# 0]"];
"{9} CRETURN [3318805410236664255]:
result-type: #<VALUES-TYPE (VALUES NUMBER &OPTIONAL)>" -> "{A} CLAMBDA [1548640143404685150]:
%debug-name: NIL
source-name: FOO
kind: NIL"[label="lambda"];
"{9} CRETURN [3318805410236664255]:
result-type: #<VALUES-TYPE (VALUES NUMBER &OPTIONAL)>" -> "{B} LVAR [3332062336230889072]:
%derived-type: NIL
dynamic-extent: NIL"[label="result"];
"{A} CLAMBDA [1548640143404685150]:
%debug-name: NIL
source-name: FOO
kind: NIL" -> "{A} CLAMBDA [1548640143404685150]:
%debug-name: NIL
source-name: FOO
kind: NIL"[label="home"];
"{A} CLAMBDA [1548640143404685150]:
%debug-name: NIL
source-name: FOO
kind: NIL" -> "{C} LAMBDA-VAR [427626644569905684]:
arg-info: NIL
flags: 0"[label="vars[# 0]"];
"{A} CLAMBDA [1548640143404685150]:
%debug-name: NIL
source-name: FOO
kind: NIL" -> "{D} LAMBDA-VAR [2146378094944416105]:
arg-info: NIL
flags: 0"[label="vars[# 1]"];
"{C} LAMBDA-VAR [427626644569905684]:
arg-info: NIL
flags: 0" -> "{A} CLAMBDA [1548640143404685150]:
%debug-name: NIL
source-name: FOO
kind: NIL"[label="home"];
"{D} LAMBDA-VAR [2146378094944416105]:
arg-info: NIL
flags: 0" -> "{A} CLAMBDA [1548640143404685150]:
%debug-name: NIL
source-name: FOO
kind: NIL"[label="home"];
"{B} LVAR [3332062336230889072]:
%derived-type: NIL
dynamic-extent: NIL" -> "{9} CRETURN [3318805410236664255]:
result-type: #<VALUES-TYPE (VALUES NUMBER &OPTIONAL)>"[label="dest"color="brown"];
"{B} LVAR [3332062336230889072]:
%derived-type: NIL
dynamic-extent: NIL" -> "{E} COMBINATION [4470851417157717636]:
kind: KNOWN
info: #<VOP-INFO
:NAME SB-VM::GENERIC-+
:ARG-TYPES (* *)
:RESULT-TYPES (*)
:LTN-POLICY :SAFE
:COST 10>"[label="uses"];
"{E} COMBINATION [4470851417157717636]:
kind: KNOWN
info: #<VOP-INFO
:NAME SB-VM::GENERIC-+
:ARG-TYPES (* *)
:RESULT-TYPES (*)
:LTN-POLICY :SAFE
:COST 10>" -> "{F} LVAR [880522709123618192]:
%derived-type: #<VALUES-TYPE (VALUES
(FUNCTION (&REST NUMBER)
(VALUES NUMBER &OPTIONAL))
&OPTIONAL)>
dynamic-extent: NIL"[label="fun"];
"{E} COMBINATION [4470851417157717636]:
kind: KNOWN
info: #<VOP-INFO
:NAME SB-VM::GENERIC-+
:ARG-TYPES (* *)
:RESULT-TYPES (*)
:LTN-POLICY :SAFE
:COST 10>" -> "{10} LVAR [1971775294085688999]:
%derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>
dynamic-extent: NIL"[label="args[# 0]"];
"{E} COMBINATION [4470851417157717636]:
kind: KNOWN
info: #<VOP-INFO
:NAME SB-VM::GENERIC-+
:ARG-TYPES (* *)
:RESULT-TYPES (*)
:LTN-POLICY :SAFE
:COST 10>" -> "{11} LVAR [2437848309170464037]:
%derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>
dynamic-extent: NIL"[label="args[# 1]"];
"{F} LVAR [880522709123618192]:
%derived-type: #<VALUES-TYPE (VALUES
(FUNCTION (&REST NUMBER)
(VALUES NUMBER &OPTIONAL))
&OPTIONAL)>
dynamic-extent: NIL" -> "{E} COMBINATION [4470851417157717636]:
kind: KNOWN
info: #<VOP-INFO
:NAME SB-VM::GENERIC-+
:ARG-TYPES (* *)
:RESULT-TYPES (*)
:LTN-POLICY :SAFE
:COST 10>"[label="dest"color="brown"];
"{F} LVAR [880522709123618192]:
%derived-type: #<VALUES-TYPE (VALUES
(FUNCTION (&REST NUMBER)
(VALUES NUMBER &OPTIONAL))
&OPTIONAL)>
dynamic-extent: NIL" -> "{12} REF [2322685304030638494]:
derived-type: #<VALUES-TYPE (VALUES
(FUNCTION (&REST NUMBER)
(VALUES NUMBER &OPTIONAL))
&OPTIONAL)>"[label="uses"];
"{12} REF [2322685304030638494]:
derived-type: #<VALUES-TYPE (VALUES
(FUNCTION (&REST NUMBER)
(VALUES NUMBER &OPTIONAL))
&OPTIONAL)>" -> "{13} NOT SUPPORTED YET:
#<GLOBAL-VAR
:%SOURCE-NAME +
:TYPE #<SB-KERNEL:FUN-TYPE (FUNCTION (&REST NUMBER)
(VALUES NUMBER &OPTIONAL))>
:DEFINED-TYPE #<SB-KERNEL:FUN-TYPE (FUNCTION (&REST NUMBER)
(VALUES NUMBER &OPTIONAL))>
:WHERE-FROM :DECLARED
:KIND :GLOBAL-FUNCTION {1001D90B33}>"[label="leaf"];
"{12} REF [2322685304030638494]:
derived-type: #<VALUES-TYPE (VALUES
(FUNCTION (&REST NUMBER)
(VALUES NUMBER &OPTIONAL))
&OPTIONAL)>" -> "{14} REF [2214161050784690650]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>"[label="next[ctran: INSIDE-BLOCK]"color="blue"];
"{12} REF [2322685304030638494]:
derived-type: #<VALUES-TYPE (VALUES
(FUNCTION (&REST NUMBER)
(VALUES NUMBER &OPTIONAL))
&OPTIONAL)>" -> "{F} LVAR [880522709123618192]:
%derived-type: #<VALUES-TYPE (VALUES
(FUNCTION (&REST NUMBER)
(VALUES NUMBER &OPTIONAL))
&OPTIONAL)>
dynamic-extent: NIL"[label="lvar"];
"{14} REF [2214161050784690650]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>" -> "{C} LAMBDA-VAR [427626644569905684]:
arg-info: NIL
flags: 0"[label="leaf"];
"{14} REF [2214161050784690650]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>" -> "{15} REF [1478297276934534521]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>"[label="next[ctran: INSIDE-BLOCK]"color="blue"];
"{14} REF [2214161050784690650]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>" -> "{10} LVAR [1971775294085688999]:
%derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>
dynamic-extent: NIL"[label="lvar"];
"{15} REF [1478297276934534521]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>" -> "{D} LAMBDA-VAR [2146378094944416105]:
arg-info: NIL
flags: 0"[label="leaf"];
"{15} REF [1478297276934534521]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>" -> "{E} COMBINATION [4470851417157717636]:
kind: KNOWN
info: #<VOP-INFO
:NAME SB-VM::GENERIC-+
:ARG-TYPES (* *)
:RESULT-TYPES (*)
:LTN-POLICY :SAFE
:COST 10>"[label="next[ctran: INSIDE-BLOCK]"color="blue"];
"{15} REF [1478297276934534521]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>" -> "{11} LVAR [2437848309170464037]:
%derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>
dynamic-extent: NIL"[label="lvar"];
"{11} LVAR [2437848309170464037]:
%derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>
dynamic-extent: NIL" -> "{E} COMBINATION [4470851417157717636]:
kind: KNOWN
info: #<VOP-INFO
:NAME SB-VM::GENERIC-+
:ARG-TYPES (* *)
:RESULT-TYPES (*)
:LTN-POLICY :SAFE
:COST 10>"[label="dest"color="brown"];
"{11} LVAR [2437848309170464037]:
%derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>
dynamic-extent: NIL" -> "{15} REF [1478297276934534521]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>"[label="uses"];
"{10} LVAR [1971775294085688999]:
%derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>
dynamic-extent: NIL" -> "{E} COMBINATION [4470851417157717636]:
kind: KNOWN
info: #<VOP-INFO
:NAME SB-VM::GENERIC-+
:ARG-TYPES (* *)
:RESULT-TYPES (*)
:LTN-POLICY :SAFE
:COST 10>"[label="dest"color="brown"];
"{10} LVAR [1971775294085688999]:
%derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>
dynamic-extent: NIL" -> "{14} REF [2214161050784690650]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>"[label="uses"];
"{8} ENTRY [1798174669859920552]:
" -> "{16} NOT SUPPORTED YET:
#<CLEANUP :KIND :BLOCK :MESS-UP #<SB-C::ENTRY {1001D909C3}> {1001D90A13}>"[label="cleanup"];
"{8} ENTRY [1798174669859920552]:
" -> "{12} REF [2322685304030638494]:
derived-type: #<VALUES-TYPE (VALUES
(FUNCTION (&REST NUMBER)
(VALUES NUMBER &OPTIONAL))
&OPTIONAL)>"[label="next[ctran: INSIDE-BLOCK]"color="blue"];
"{8} ENTRY [1798174669859920552]:
" -> "{8} ENTRY [1798174669859920552]:
"[label="prev[ctran: BLOCK-START]"color="blue"];
"{4} CBLOCK [1030293972324225963]" -> "{0} COMPONENT [NIL]: ''DEFUN FOO''"[label="component"];
"{4} CBLOCK [1030293972324225963]" -> "{3} CBLOCK [3432958294353052646]"[label="succ[# 0]"];
"{4} CBLOCK [1030293972324225963]" -> "{1} CBLOCK [3101743450240528196]"[label="pred[# 0]"];
"{4} CBLOCK [1030293972324225963]" -> "{17} BIND [831277122367414297]"[label="start[ctran: BLOCK-START]"color="blue"];
"{17} BIND [831277122367414297]" -> "{18} CLAMBDA [2262455371626719506]:
%debug-name: (XEP FOO)
source-name: .ANONYMOUS.
kind: EXTERNAL"[label="lambda"];
"{17} BIND [831277122367414297]" -> "{19} REF [3619795511931107142]:
derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>"[label="next[ctran: INSIDE-BLOCK]"color="green"];
"{17} BIND [831277122367414297]" -> "{17} BIND [831277122367414297]"[label="prev[ctran: BLOCK-START]"color="red"];
"{18} CLAMBDA [2262455371626719506]:
%debug-name: (XEP FOO)
source-name: .ANONYMOUS.
kind: EXTERNAL" -> "{18} CLAMBDA [2262455371626719506]:
%debug-name: (XEP FOO)
source-name: .ANONYMOUS.
kind: EXTERNAL"[label="home"];
"{18} CLAMBDA [2262455371626719506]:
%debug-name: (XEP FOO)
source-name: .ANONYMOUS.
kind: EXTERNAL" -> "{1A} LAMBDA-VAR [1619988245174222653]:
arg-info: NIL
flags: 1"[label="vars[# 0]"];
"{18} CLAMBDA [2262455371626719506]:
%debug-name: (XEP FOO)
source-name: .ANONYMOUS.
kind: EXTERNAL" -> "{1B} LAMBDA-VAR [1302633028662760541]:
arg-info: NIL
flags: 0"[label="vars[# 1]"];
"{18} CLAMBDA [2262455371626719506]:
%debug-name: (XEP FOO)
source-name: .ANONYMOUS.
kind: EXTERNAL" -> "{1C} LAMBDA-VAR [4271800902626008186]:
arg-info: NIL
flags: 0"[label="vars[# 2]"];
"{1A} LAMBDA-VAR [1619988245174222653]:
arg-info: NIL
flags: 1" -> "{18} CLAMBDA [2262455371626719506]:
%debug-name: (XEP FOO)
source-name: .ANONYMOUS.
kind: EXTERNAL"[label="home"];
"{1B} LAMBDA-VAR [1302633028662760541]:
arg-info: NIL
flags: 0" -> "{18} CLAMBDA [2262455371626719506]:
%debug-name: (XEP FOO)
source-name: .ANONYMOUS.
kind: EXTERNAL"[label="home"];
"{1C} LAMBDA-VAR [4271800902626008186]:
arg-info: NIL
flags: 0" -> "{18} CLAMBDA [2262455371626719506]:
%debug-name: (XEP FOO)
source-name: .ANONYMOUS.
kind: EXTERNAL"[label="home"];
"{19} REF [3619795511931107142]:
derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>" -> "{A} CLAMBDA [1548640143404685150]:
%debug-name: NIL
source-name: FOO
kind: NIL"[label="leaf"];
"{19} REF [3619795511931107142]:
derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>" -> "{1D} REF [255745217795967635]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>"[label="next[ctran: INSIDE-BLOCK]"color="blue"];
"{19} REF [3619795511931107142]:
derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>" -> "{1E} LVAR [2622378942754528345]:
%derived-type: NIL
dynamic-extent: NIL"[label="lvar"];
"{1D} REF [255745217795967635]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>" -> "{1B} LAMBDA-VAR [1302633028662760541]:
arg-info: NIL
flags: 0"[label="leaf"];
"{1D} REF [255745217795967635]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>" -> "{1F} REF [3667387203345186464]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>"[label="next[ctran: INSIDE-BLOCK]"color="blue"];
"{1D} REF [255745217795967635]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>" -> "{20} LVAR [2092324786633111792]:
%derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>
dynamic-extent: NIL"[label="lvar"];
"{1F} REF [3667387203345186464]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>" -> "{1C} LAMBDA-VAR [4271800902626008186]:
arg-info: NIL
flags: 0"[label="leaf"];
"{1F} REF [3667387203345186464]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>" -> "{21} COMBINATION [3204626948301471823]:
kind: LOCAL
info: LOCAL"[label="next[ctran: INSIDE-BLOCK]"color="blue"];
"{1F} REF [3667387203345186464]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>" -> "{22} LVAR [4442925413727114980]:
%derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>
dynamic-extent: NIL"[label="lvar"];
"{21} COMBINATION [3204626948301471823]:
kind: LOCAL
info: LOCAL" -> "{1E} LVAR [2622378942754528345]:
%derived-type: NIL
dynamic-extent: NIL"[label="fun"];
"{21} COMBINATION [3204626948301471823]:
kind: LOCAL
info: LOCAL" -> "{20} LVAR [2092324786633111792]:
%derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>
dynamic-extent: NIL"[label="args[# 0]"];
"{21} COMBINATION [3204626948301471823]:
kind: LOCAL
info: LOCAL" -> "{22} LVAR [4442925413727114980]:
%derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>
dynamic-extent: NIL"[label="args[# 1]"];
"{1E} LVAR [2622378942754528345]:
%derived-type: NIL
dynamic-extent: NIL" -> "{21} COMBINATION [3204626948301471823]:
kind: LOCAL
info: LOCAL"[label="dest"color="brown"];
"{1E} LVAR [2622378942754528345]:
%derived-type: NIL
dynamic-extent: NIL" -> "{19} REF [3619795511931107142]:
derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>"[label="uses"];
"{20} LVAR [2092324786633111792]:
%derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>
dynamic-extent: NIL" -> "{21} COMBINATION [3204626948301471823]:
kind: LOCAL
info: LOCAL"[label="dest"color="brown"];
"{20} LVAR [2092324786633111792]:
%derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>
dynamic-extent: NIL" -> "{1D} REF [255745217795967635]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>"[label="uses"];
"{22} LVAR [4442925413727114980]:
%derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>
dynamic-extent: NIL" -> "{21} COMBINATION [3204626948301471823]:
kind: LOCAL
info: LOCAL"[label="dest"color="brown"];
"{22} LVAR [4442925413727114980]:
%derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>
dynamic-extent: NIL" -> "{1F} REF [3667387203345186464]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>"[label="uses"];
"{6} BIND [3685440732622309514]" -> "{A} CLAMBDA [1548640143404685150]:
%debug-name: NIL
source-name: FOO
kind: NIL"[label="lambda"];
"{6} BIND [3685440732622309514]" -> "{6} BIND [3685440732622309514]"[label="prev[ctran: BLOCK-START]"color="red"];
}

128
contrib/sb-graph/example/trace-2-toplevelform.dot
View file

@ -1,128 +0,0 @@
digraph {
"{0} COMPONENT [TOPLEVEL]: ''top level form''" -> "{1} CBLOCK [1943264620861609727]"[label="head"];
"{0} COMPONENT [TOPLEVEL]: ''top level form''" -> "{2} CBLOCK [1731306899775915608]"[label="tail"];
"{1} CBLOCK [1943264620861609727]" -> "{0} COMPONENT [TOPLEVEL]: ''top level form''"[label="component"];
"{1} CBLOCK [1943264620861609727]" -> "{3} CBLOCK [3908410932650914907]"[label="succ[# 0]"];
"{3} CBLOCK [3908410932650914907]" -> "{0} COMPONENT [TOPLEVEL]: ''top level form''"[label="component"];
"{3} CBLOCK [3908410932650914907]" -> "{2} CBLOCK [1731306899775915608]"[label="succ[# 0]"];
"{3} CBLOCK [3908410932650914907]" -> "{1} CBLOCK [1943264620861609727]"[label="pred[# 0]"];
"{3} CBLOCK [3908410932650914907]" -> "{4} BIND [3628153076315219959]"[label="start[ctran: BLOCK-START]"color="blue"];
"{2} CBLOCK [1731306899775915608]" -> "{0} COMPONENT [TOPLEVEL]: ''top level form''"[label="component"];
"{2} CBLOCK [1731306899775915608]" -> "{3} CBLOCK [3908410932650914907]"[label="pred[# 0]"];
"{4} BIND [3628153076315219959]" -> "{5} CLAMBDA [1883614179857431325]:
%debug-name: (TOP-LEVEL-FORM
(%DEFUN 'FOO
(NAMED-LAMBDA FOO
(A B)
(DECLARE (TOP-LEVEL-FORM))
(BLOCK FOO (+ A B)))))
source-name: .ANONYMOUS.
kind: TOPLEVEL"[label="lambda"];
"{4} BIND [3628153076315219959]" -> "{6} REF [1814276436352168607]:
derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>"[label="next[ctran: INSIDE-BLOCK]"color="green"];
"{4} BIND [3628153076315219959]" -> "{4} BIND [3628153076315219959]"[label="prev[ctran: BLOCK-START]"color="red"];
"{5} CLAMBDA [1883614179857431325]:
%debug-name: (TOP-LEVEL-FORM
(%DEFUN 'FOO
(NAMED-LAMBDA FOO
(A B)
(DECLARE (TOP-LEVEL-FORM))
(BLOCK FOO (+ A B)))))
source-name: .ANONYMOUS.
kind: TOPLEVEL" -> "{5} CLAMBDA [1883614179857431325]:
%debug-name: (TOP-LEVEL-FORM
(%DEFUN 'FOO
(NAMED-LAMBDA FOO
(A B)
(DECLARE (TOP-LEVEL-FORM))
(BLOCK FOO (+ A B)))))
source-name: .ANONYMOUS.
kind: TOPLEVEL"[label="home"];
"{6} REF [1814276436352168607]:
derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>" -> "{7} NOT SUPPORTED YET:
#<GLOBAL-VAR
:%SOURCE-NAME SB-IMPL::%DEFUN
:TYPE #<SB-KERNEL:BUILT-IN-CLASSOID FUNCTION (read-only)>
:DEFINED-TYPE #<SB-KERNEL:FUN-TYPE (FUNCTION (T FUNCTION &OPTIONAL T T)
(VALUES (OR SYMBOL CONS) &OPTIONAL))>
:WHERE-FROM :DEFINED
:KIND :GLOBAL-FUNCTION {1001D6DA43}>"[label="leaf"];
"{6} REF [1814276436352168607]:
derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>" -> "{8} REF [3898086476392545619]:
derived-type: #<VALUES-TYPE (VALUES (MEMBER FOO) &OPTIONAL)>"[label="next[ctran: INSIDE-BLOCK]"color="blue"];
"{6} REF [1814276436352168607]:
derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>" -> "{9} LVAR [4022411708127746323]:
%derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>
dynamic-extent: NIL"[label="lvar"];
"{8} REF [3898086476392545619]:
derived-type: #<VALUES-TYPE (VALUES (MEMBER FOO) &OPTIONAL)>" -> "{A} CONSTANT [405874115581245099]:
value: FOO"[label="leaf"];
"{8} REF [3898086476392545619]:
derived-type: #<VALUES-TYPE (VALUES (MEMBER FOO) &OPTIONAL)>" -> "{B} NOT SUPPORTED YET:
#<ENCLOSE
:FUNS (#<SB-C::CLAMBDA
:%SOURCE-NAME FOO
:%DEBUG-NAME NIL
:KIND NIL
:TYPE #<SB-KERNEL:FUN-TYPE (FUNCTION (T T)
(VALUES NUMBER &OPTIONAL))>
:WHERE-FROM :DEFINED
:VARS (A B) {1001D90353}>) {1001D96AE3}>"[label="next[ctran: INSIDE-BLOCK]"color="blue"];
"{8} REF [3898086476392545619]:
derived-type: #<VALUES-TYPE (VALUES (MEMBER FOO) &OPTIONAL)>" -> "{C} LVAR [1186859114169146565]:
%derived-type: #<VALUES-TYPE (VALUES (MEMBER FOO) &OPTIONAL)>
dynamic-extent: NIL"[label="lvar"];
"{C} LVAR [1186859114169146565]:
%derived-type: #<VALUES-TYPE (VALUES (MEMBER FOO) &OPTIONAL)>
dynamic-extent: NIL" -> "{D} COMBINATION [1475360876084922324]:
kind: FULL
info: FULL"[label="dest"color="brown"];
"{C} LVAR [1186859114169146565]:
%derived-type: #<VALUES-TYPE (VALUES (MEMBER FOO) &OPTIONAL)>
dynamic-extent: NIL" -> "{8} REF [3898086476392545619]:
derived-type: #<VALUES-TYPE (VALUES (MEMBER FOO) &OPTIONAL)>"[label="uses"];
"{D} COMBINATION [1475360876084922324]:
kind: FULL
info: FULL" -> "{9} LVAR [4022411708127746323]:
%derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>
dynamic-extent: NIL"[label="fun"];
"{D} COMBINATION [1475360876084922324]:
kind: FULL
info: FULL" -> "{C} LVAR [1186859114169146565]:
%derived-type: #<VALUES-TYPE (VALUES (MEMBER FOO) &OPTIONAL)>
dynamic-extent: NIL"[label="args[# 0]"];
"{D} COMBINATION [1475360876084922324]:
kind: FULL
info: FULL" -> "{E} LVAR [3728149842014737266]:
%derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>
dynamic-extent: NIL"[label="args[# 1]"];
"{9} LVAR [4022411708127746323]:
%derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>
dynamic-extent: NIL" -> "{D} COMBINATION [1475360876084922324]:
kind: FULL
info: FULL"[label="dest"color="brown"];
"{9} LVAR [4022411708127746323]:
%derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>
dynamic-extent: NIL" -> "{6} REF [1814276436352168607]:
derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>"[label="uses"];
"{E} LVAR [3728149842014737266]:
%derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>
dynamic-extent: NIL" -> "{D} COMBINATION [1475360876084922324]:
kind: FULL
info: FULL"[label="dest"color="brown"];
"{E} LVAR [3728149842014737266]:
%derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>
dynamic-extent: NIL" -> "{F} REF [4127949218090209127]:
derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>"[label="uses"];
"{F} REF [4127949218090209127]:
derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>" -> "{10} NOT SUPPORTED YET:
#<FUNCTIONAL :%SOURCE-NAME FOO :%DEBUG-NAME NIL {10029BCC33}>"[label="leaf"];
"{F} REF [4127949218090209127]:
derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>" -> "{D} COMBINATION [1475360876084922324]:
kind: FULL
info: FULL"[label="next[ctran: INSIDE-BLOCK]"color="blue"];
"{F} REF [4127949218090209127]:
derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>" -> "{E} LVAR [3728149842014737266]:
%derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>
dynamic-extent: NIL"[label="lvar"];
}

795
contrib/sb-graph/example/trace-3-DEFUNBAR.dot
View file

@ -1,795 +0,0 @@
digraph {
"{0} COMPONENT [NIL]: ''DEFUN BAR''" -> "{1} CBLOCK [1575903357056582106]"[label="head"];
"{0} COMPONENT [NIL]: ''DEFUN BAR''" -> "{2} CBLOCK [646725814620792949]"[label="tail"];
"{1} CBLOCK [1575903357056582106]" -> "{0} COMPONENT [NIL]: ''DEFUN BAR''"[label="component"];
"{1} CBLOCK [1575903357056582106]" -> "{3} CBLOCK [463338187003706333]"[label="succ[# 0]"];
"{1} CBLOCK [1575903357056582106]" -> "{4} CBLOCK [4485638051092447707]"[label="succ[# 1]"];
"{3} CBLOCK [463338187003706333]" -> "{0} COMPONENT [NIL]: ''DEFUN BAR''"[label="component"];
"{3} CBLOCK [463338187003706333]" -> "{5} CBLOCK [4517821492800445034]"[label="succ[# 0]"];
"{3} CBLOCK [463338187003706333]" -> "{4} CBLOCK [4485638051092447707]"[label="pred[# 0]"];
"{3} CBLOCK [463338187003706333]" -> "{1} CBLOCK [1575903357056582106]"[label="pred[# 1]"];
"{3} CBLOCK [463338187003706333]" -> "{6} BIND [2888465489035891844]"[label="start[ctran: BLOCK-START]"color="blue"];
"{5} CBLOCK [4517821492800445034]" -> "{0} COMPONENT [NIL]: ''DEFUN BAR''"[label="component"];
"{5} CBLOCK [4517821492800445034]" -> "{7} CBLOCK [560949006574360106]"[label="succ[# 0]"];
"{5} CBLOCK [4517821492800445034]" -> "{8} CBLOCK [4400914120625574157]"[label="succ[# 1]"];
"{5} CBLOCK [4517821492800445034]" -> "{3} CBLOCK [463338187003706333]"[label="pred[# 0]"];
"{5} CBLOCK [4517821492800445034]" -> "{9} ENTRY [3859794357893252955]:
"[label="start[ctran: BLOCK-START]"color="blue"];
"{7} CBLOCK [560949006574360106]" -> "{0} COMPONENT [NIL]: ''DEFUN BAR''"[label="component"];
"{7} CBLOCK [560949006574360106]" -> "{2} CBLOCK [646725814620792949]"[label="succ[# 0]"];
"{7} CBLOCK [560949006574360106]" -> "{5} CBLOCK [4517821492800445034]"[label="pred[# 0]"];
"{7} CBLOCK [560949006574360106]" -> "{A} REF [970847179709888776]:
derived-type: #<VALUES-TYPE (VALUES (FUNCTION (T T T) NIL) &OPTIONAL)>"[label="start[ctran: BLOCK-START]"color="blue"];
"{2} CBLOCK [646725814620792949]" -> "{0} COMPONENT [NIL]: ''DEFUN BAR''"[label="component"];
"{2} CBLOCK [646725814620792949]" -> "{7} CBLOCK [560949006574360106]"[label="pred[# 0]"];
"{2} CBLOCK [646725814620792949]" -> "{B} CBLOCK [3753698776976668030]"[label="pred[# 1]"];
"{B} CBLOCK [3753698776976668030]" -> "{0} COMPONENT [NIL]: ''DEFUN BAR''"[label="component"];
"{B} CBLOCK [3753698776976668030]" -> "{2} CBLOCK [646725814620792949]"[label="succ[# 0]"];
"{B} CBLOCK [3753698776976668030]" -> "{8} CBLOCK [4400914120625574157]"[label="pred[# 0]"];
"{B} CBLOCK [3753698776976668030]" -> "{C} CRETURN [1875721060202815921]:
result-type: #<VALUES-TYPE (VALUES NUMBER &OPTIONAL)>"[label="start[ctran: BLOCK-START]"color="blue"];
"{8} CBLOCK [4400914120625574157]" -> "{0} COMPONENT [NIL]: ''DEFUN BAR''"[label="component"];
"{8} CBLOCK [4400914120625574157]" -> "{B} CBLOCK [3753698776976668030]"[label="succ[# 0]"];
"{8} CBLOCK [4400914120625574157]" -> "{5} CBLOCK [4517821492800445034]"[label="pred[# 0]"];
"{8} CBLOCK [4400914120625574157]" -> "{D} REF [1142794053290553148]:
derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>"[label="start[ctran: BLOCK-START]"color="blue"];
"{D} REF [1142794053290553148]:
derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>" -> "{E} CLAMBDA [1583379011298201103]:
%debug-name: (LET ((G5 G4)))
source-name: .ANONYMOUS.
kind: LET"[label="leaf"];
"{D} REF [1142794053290553148]:
derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>" -> "{F} REF [1091524514451138732]:
derived-type: #<VALUES-TYPE (VALUES NUMBER &OPTIONAL)>"[label="next[ctran: INSIDE-BLOCK]"color="blue"];
"{D} REF [1142794053290553148]:
derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>" -> "{10} LVAR [1899977882035455531]:
%derived-type: NIL
dynamic-extent: NIL"[label="lvar"];
"{E} CLAMBDA [1583379011298201103]:
%debug-name: (LET ((G5 G4)))
source-name: .ANONYMOUS.
kind: LET" -> "{11} CLAMBDA [274430610392932488]:
%debug-name: NIL
source-name: BAR
kind: NIL"[label="home"];
"{E} CLAMBDA [1583379011298201103]:
%debug-name: (LET ((G5 G4)))
source-name: .ANONYMOUS.
kind: LET" -> "{12} LAMBDA-VAR [2194186068469748088]:
arg-info: NIL
flags: 0"[label="vars[# 0]"];
"{11} CLAMBDA [274430610392932488]:
%debug-name: NIL
source-name: BAR
kind: NIL" -> "{11} CLAMBDA [274430610392932488]:
%debug-name: NIL
source-name: BAR
kind: NIL"[label="home"];
"{11} CLAMBDA [274430610392932488]:
%debug-name: NIL
source-name: BAR
kind: NIL" -> "{13} LAMBDA-VAR [551267047686253943]:
arg-info: NIL
flags: 0"[label="vars[# 0]"];
"{11} CLAMBDA [274430610392932488]:
%debug-name: NIL
source-name: BAR
kind: NIL" -> "{14} LAMBDA-VAR [1342701350530444948]:
arg-info: NIL
flags: 0"[label="vars[# 1]"];
"{11} CLAMBDA [274430610392932488]:
%debug-name: NIL
source-name: BAR
kind: NIL" -> "{15} LAMBDA-VAR [687676610963465975]:
arg-info: NIL
flags: 0"[label="vars[# 2]"];
"{13} LAMBDA-VAR [551267047686253943]:
arg-info: NIL
flags: 0" -> "{11} CLAMBDA [274430610392932488]:
%debug-name: NIL
source-name: BAR
kind: NIL"[label="home"];
"{14} LAMBDA-VAR [1342701350530444948]:
arg-info: NIL
flags: 0" -> "{11} CLAMBDA [274430610392932488]:
%debug-name: NIL
source-name: BAR
kind: NIL"[label="home"];
"{15} LAMBDA-VAR [687676610963465975]:
arg-info: NIL
flags: 0" -> "{11} CLAMBDA [274430610392932488]:
%debug-name: NIL
source-name: BAR
kind: NIL"[label="home"];
"{12} LAMBDA-VAR [2194186068469748088]:
arg-info: NIL
flags: 0" -> "{E} CLAMBDA [1583379011298201103]:
%debug-name: (LET ((G5 G4)))
source-name: .ANONYMOUS.
kind: LET"[label="home"];
"{F} REF [1091524514451138732]:
derived-type: #<VALUES-TYPE (VALUES NUMBER &OPTIONAL)>" -> "{16} LAMBDA-VAR [4210063433964233181]:
arg-info: NIL
flags: 0"[label="leaf"];
"{F} REF [1091524514451138732]:
derived-type: #<VALUES-TYPE (VALUES NUMBER &OPTIONAL)>" -> "{17} COMBINATION [2114537499351968799]:
kind: LOCAL
info: LOCAL"[label="next[ctran: INSIDE-BLOCK]"color="blue"];
"{F} REF [1091524514451138732]:
derived-type: #<VALUES-TYPE (VALUES NUMBER &OPTIONAL)>" -> "{18} LVAR [1279162088182557763]:
%derived-type: #<VALUES-TYPE (VALUES NUMBER &OPTIONAL)>
dynamic-extent: NIL"[label="lvar"];
"{16} LAMBDA-VAR [4210063433964233181]:
arg-info: NIL
flags: 0" -> "{19} CLAMBDA [1745095324529044804]:
%debug-name: (LET ((G4 CONSTANT)))
source-name: .ANONYMOUS.
kind: LET"[label="home"];
"{19} CLAMBDA [1745095324529044804]:
%debug-name: (LET ((G4 CONSTANT)))
source-name: .ANONYMOUS.
kind: LET" -> "{11} CLAMBDA [274430610392932488]:
%debug-name: NIL
source-name: BAR
kind: NIL"[label="home"];
"{19} CLAMBDA [1745095324529044804]:
%debug-name: (LET ((G4 CONSTANT)))
source-name: .ANONYMOUS.
kind: LET" -> "{16} LAMBDA-VAR [4210063433964233181]:
arg-info: NIL
flags: 0"[label="vars[# 0]"];
"{17} COMBINATION [2114537499351968799]:
kind: LOCAL
info: LOCAL" -> "{10} LVAR [1899977882035455531]:
%derived-type: NIL
dynamic-extent: NIL"[label="fun"];
"{17} COMBINATION [2114537499351968799]:
kind: LOCAL
info: LOCAL" -> "{18} LVAR [1279162088182557763]:
%derived-type: #<VALUES-TYPE (VALUES NUMBER &OPTIONAL)>
dynamic-extent: NIL"[label="args[# 0]"];
"{10} LVAR [1899977882035455531]:
%derived-type: NIL
dynamic-extent: NIL" -> "{17} COMBINATION [2114537499351968799]:
kind: LOCAL
info: LOCAL"[label="dest"color="brown"];
"{10} LVAR [1899977882035455531]:
%derived-type: NIL
dynamic-extent: NIL" -> "{D} REF [1142794053290553148]:
derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>"[label="uses"];
"{18} LVAR [1279162088182557763]:
%derived-type: #<VALUES-TYPE (VALUES NUMBER &OPTIONAL)>
dynamic-extent: NIL" -> "{17} COMBINATION [2114537499351968799]:
kind: LOCAL
info: LOCAL"[label="dest"color="brown"];
"{18} LVAR [1279162088182557763]:
%derived-type: #<VALUES-TYPE (VALUES NUMBER &OPTIONAL)>
dynamic-extent: NIL" -> "{F} REF [1091524514451138732]:
derived-type: #<VALUES-TYPE (VALUES NUMBER &OPTIONAL)>"[label="uses"];
"{C} CRETURN [1875721060202815921]:
result-type: #<VALUES-TYPE (VALUES NUMBER &OPTIONAL)>" -> "{11} CLAMBDA [274430610392932488]:
%debug-name: NIL
source-name: BAR
kind: NIL"[label="lambda"];
"{C} CRETURN [1875721060202815921]:
result-type: #<VALUES-TYPE (VALUES NUMBER &OPTIONAL)>" -> "{1A} LVAR [934340460890599439]:
%derived-type: NIL
dynamic-extent: NIL"[label="result"];
"{1A} LVAR [934340460890599439]:
%derived-type: NIL
dynamic-extent: NIL" -> "{C} CRETURN [1875721060202815921]:
result-type: #<VALUES-TYPE (VALUES NUMBER &OPTIONAL)>"[label="dest"color="brown"];
"{1A} LVAR [934340460890599439]:
%derived-type: NIL
dynamic-extent: NIL" -> "{1B} COMBINATION [875787350148863859]:
kind: KNOWN
info: #<VOP-INFO
:NAME SB-VM::GENERIC-*
:ARG-TYPES (* *)
:RESULT-TYPES (*)
:LTN-POLICY :SAFE
:COST 30>"[label="uses"];
"{1B} COMBINATION [875787350148863859]:
kind: KNOWN
info: #<VOP-INFO
:NAME SB-VM::GENERIC-*
:ARG-TYPES (* *)
:RESULT-TYPES (*)
:LTN-POLICY :SAFE
:COST 30>" -> "{1C} LVAR [880575187628074238]:
%derived-type: #<VALUES-TYPE (VALUES
(FUNCTION (&REST NUMBER)
(VALUES NUMBER &OPTIONAL))
&OPTIONAL)>
dynamic-extent: NIL"[label="fun"];
"{1B} COMBINATION [875787350148863859]:
kind: KNOWN
info: #<VOP-INFO
:NAME SB-VM::GENERIC-*
:ARG-TYPES (* *)
:RESULT-TYPES (*)
:LTN-POLICY :SAFE
:COST 30>" -> "{1D} LVAR [2954358970637004122]:
%derived-type: #<VALUES-TYPE (VALUES NUMBER &OPTIONAL)>
dynamic-extent: NIL"[label="args[# 0]"];
"{1B} COMBINATION [875787350148863859]:
kind: KNOWN
info: #<VOP-INFO
:NAME SB-VM::GENERIC-*
:ARG-TYPES (* *)
:RESULT-TYPES (*)
:LTN-POLICY :SAFE
:COST 30>" -> "{1E} LVAR [1183996723568101089]:
%derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>
dynamic-extent: NIL"[label="args[# 1]"];
"{1C} LVAR [880575187628074238]:
%derived-type: #<VALUES-TYPE (VALUES
(FUNCTION (&REST NUMBER)
(VALUES NUMBER &OPTIONAL))
&OPTIONAL)>
dynamic-extent: NIL" -> "{1B} COMBINATION [875787350148863859]:
kind: KNOWN
info: #<VOP-INFO
:NAME SB-VM::GENERIC-*
:ARG-TYPES (* *)
:RESULT-TYPES (*)
:LTN-POLICY :SAFE
:COST 30>"[label="dest"color="brown"];
"{1C} LVAR [880575187628074238]:
%derived-type: #<VALUES-TYPE (VALUES
(FUNCTION (&REST NUMBER)
(VALUES NUMBER &OPTIONAL))
&OPTIONAL)>
dynamic-extent: NIL" -> "{1F} REF [1077682984383576289]:
derived-type: #<VALUES-TYPE (VALUES
(FUNCTION (&REST NUMBER)
(VALUES NUMBER &OPTIONAL))
&OPTIONAL)>"[label="uses"];
"{1F} REF [1077682984383576289]:
derived-type: #<VALUES-TYPE (VALUES
(FUNCTION (&REST NUMBER)
(VALUES NUMBER &OPTIONAL))
&OPTIONAL)>" -> "{20} NOT SUPPORTED YET:
#<GLOBAL-VAR
:%SOURCE-NAME *
:TYPE #<SB-KERNEL:FUN-TYPE (FUNCTION (&REST NUMBER)
(VALUES NUMBER &OPTIONAL))>
:DEFINED-TYPE #<SB-KERNEL:FUN-TYPE (FUNCTION (&REST NUMBER)
(VALUES NUMBER &OPTIONAL))>
:WHERE-FROM :DECLARED
:KIND :GLOBAL-FUNCTION {1002A2E013}>"[label="leaf"];
"{1F} REF [1077682984383576289]:
derived-type: #<VALUES-TYPE (VALUES
(FUNCTION (&REST NUMBER)
(VALUES NUMBER &OPTIONAL))
&OPTIONAL)>" -> "{21} REF [3270722447377338959]:
derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>"[label="next[ctran: INSIDE-BLOCK]"color="blue"];
"{1F} REF [1077682984383576289]:
derived-type: #<VALUES-TYPE (VALUES
(FUNCTION (&REST NUMBER)
(VALUES NUMBER &OPTIONAL))
&OPTIONAL)>" -> "{1C} LVAR [880575187628074238]:
%derived-type: #<VALUES-TYPE (VALUES
(FUNCTION (&REST NUMBER)
(VALUES NUMBER &OPTIONAL))
&OPTIONAL)>
dynamic-extent: NIL"[label="lvar"];
"{21} REF [3270722447377338959]:
derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>" -> "{22} NOT SUPPORTED YET:
#<GLOBAL-VAR
:%SOURCE-NAME FOO
:TYPE #<SB-KERNEL:BUILT-IN-CLASSOID FUNCTION (read-only)>
:DEFINED-TYPE #<SB-KERNEL:FUN-TYPE (FUNCTION (T T)
(VALUES NUMBER &OPTIONAL))>
:WHERE-FROM :DEFINED-HERE
:KIND :GLOBAL-FUNCTION {1002A2E323}>"[label="leaf"];
"{21} REF [3270722447377338959]:
derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>" -> "{23} REF [3193645899558233143]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>"[label="next[ctran: INSIDE-BLOCK]"color="blue"];
"{21} REF [3270722447377338959]:
derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>" -> "{24} LVAR [1092023012539887227]:
%derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>
dynamic-extent: NIL"[label="lvar"];
"{23} REF [3193645899558233143]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>" -> "{13} LAMBDA-VAR [551267047686253943]:
arg-info: NIL
flags: 0"[label="leaf"];
"{23} REF [3193645899558233143]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>" -> "{25} REF [2658638157906711011]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>"[label="next[ctran: INSIDE-BLOCK]"color="blue"];
"{23} REF [3193645899558233143]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>" -> "{26} LVAR [1584308892107556128]:
%derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>
dynamic-extent: NIL"[label="lvar"];
"{25} REF [2658638157906711011]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>" -> "{14} LAMBDA-VAR [1342701350530444948]:
arg-info: NIL
flags: 0"[label="leaf"];
"{25} REF [2658638157906711011]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>" -> "{27} COMBINATION [4361784411754163848]:
kind: FULL
info: FULL"[label="next[ctran: INSIDE-BLOCK]"color="blue"];
"{25} REF [2658638157906711011]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>" -> "{28} LVAR [2490411435938110265]:
%derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>
dynamic-extent: NIL"[label="lvar"];
"{27} COMBINATION [4361784411754163848]:
kind: FULL
info: FULL" -> "{24} LVAR [1092023012539887227]:
%derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>
dynamic-extent: NIL"[label="fun"];
"{27} COMBINATION [4361784411754163848]:
kind: FULL
info: FULL" -> "{26} LVAR [1584308892107556128]:
%derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>
dynamic-extent: NIL"[label="args[# 0]"];
"{27} COMBINATION [4361784411754163848]:
kind: FULL
info: FULL" -> "{28} LVAR [2490411435938110265]:
%derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>
dynamic-extent: NIL"[label="args[# 1]"];
"{24} LVAR [1092023012539887227]:
%derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>
dynamic-extent: NIL" -> "{27} COMBINATION [4361784411754163848]:
kind: FULL
info: FULL"[label="dest"color="brown"];
"{24} LVAR [1092023012539887227]:
%derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>
dynamic-extent: NIL" -> "{21} REF [3270722447377338959]:
derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>"[label="uses"];
"{26} LVAR [1584308892107556128]:
%derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>
dynamic-extent: NIL" -> "{27} COMBINATION [4361784411754163848]:
kind: FULL
info: FULL"[label="dest"color="brown"];
"{26} LVAR [1584308892107556128]:
%derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>
dynamic-extent: NIL" -> "{23} REF [3193645899558233143]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>"[label="uses"];
"{28} LVAR [2490411435938110265]:
%derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>
dynamic-extent: NIL" -> "{27} COMBINATION [4361784411754163848]:
kind: FULL
info: FULL"[label="dest"color="brown"];
"{28} LVAR [2490411435938110265]:
%derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>
dynamic-extent: NIL" -> "{25} REF [2658638157906711011]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>"[label="uses"];
"{1D} LVAR [2954358970637004122]:
%derived-type: #<VALUES-TYPE (VALUES NUMBER &OPTIONAL)>
dynamic-extent: NIL" -> "{1B} COMBINATION [875787350148863859]:
kind: KNOWN
info: #<VOP-INFO
:NAME SB-VM::GENERIC-*
:ARG-TYPES (* *)
:RESULT-TYPES (*)
:LTN-POLICY :SAFE
:COST 30>"[label="dest"color="brown"];
"{1D} LVAR [2954358970637004122]:
%derived-type: #<VALUES-TYPE (VALUES NUMBER &OPTIONAL)>
dynamic-extent: NIL" -> "{29} NOT SUPPORTED YET:
#<CAST
:%TYPE-CHECK NIL
:VALUE #<SB-C::LVAR 32 {1002A36853}>
:ASSERTED-TYPE #<SB-KERNEL:VALUES-TYPE (VALUES NUMBER &OPTIONAL)>
:TYPE-TO-CHECK #<SB-KERNEL:VALUES-TYPE (VALUES NUMBER
&OPTIONAL)> {1002A31703}>"[label="uses"];
"{1E} LVAR [1183996723568101089]:
%derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>
dynamic-extent: NIL" -> "{1B} COMBINATION [875787350148863859]:
kind: KNOWN
info: #<VOP-INFO
:NAME SB-VM::GENERIC-*
:ARG-TYPES (* *)
:RESULT-TYPES (*)
:LTN-POLICY :SAFE
:COST 30>"[label="dest"color="brown"];
"{1E} LVAR [1183996723568101089]:
%derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>
dynamic-extent: NIL" -> "{2A} REF [3033938375645121583]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>"[label="uses"];
"{2A} REF [3033938375645121583]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>" -> "{15} LAMBDA-VAR [687676610963465975]:
arg-info: NIL
flags: 0"[label="leaf"];
"{2A} REF [3033938375645121583]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>" -> "{2B} REF [1791781268393324760]:
derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>"[label="next[ctran: INSIDE-BLOCK]"color="blue"];
"{2A} REF [3033938375645121583]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>" -> "{1E} LVAR [1183996723568101089]:
%derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>
dynamic-extent: NIL"[label="lvar"];
"{2B} REF [1791781268393324760]:
derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>" -> "{19} CLAMBDA [1745095324529044804]:
%debug-name: (LET ((G4 CONSTANT)))
source-name: .ANONYMOUS.
kind: LET"[label="leaf"];
"{2B} REF [1791781268393324760]:
derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>" -> "{2C} COMBINATION [1668396070861299820]:
kind: LOCAL
info: LOCAL"[label="next[ctran: INSIDE-BLOCK]"color="blue"];
"{2B} REF [1791781268393324760]:
derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>" -> "{2D} LVAR [3615461272610505909]:
%derived-type: NIL
dynamic-extent: NIL"[label="lvar"];
"{2C} COMBINATION [1668396070861299820]:
kind: LOCAL
info: LOCAL" -> "{2D} LVAR [3615461272610505909]:
%derived-type: NIL
dynamic-extent: NIL"[label="fun"];
"{2C} COMBINATION [1668396070861299820]:
kind: LOCAL
info: LOCAL" -> "{2E} LVAR [1415646066275954498]:
%derived-type: #<NAMED-TYPE *>
dynamic-extent: NIL"[label="args[# 0]"];
"{2D} LVAR [3615461272610505909]:
%derived-type: NIL
dynamic-extent: NIL" -> "{2C} COMBINATION [1668396070861299820]:
kind: LOCAL
info: LOCAL"[label="dest"color="brown"];
"{2D} LVAR [3615461272610505909]:
%derived-type: NIL
dynamic-extent: NIL" -> "{2B} REF [1791781268393324760]:
derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>"[label="uses"];
"{2E} LVAR [1415646066275954498]:
%derived-type: #<NAMED-TYPE *>
dynamic-extent: NIL" -> "{2C} COMBINATION [1668396070861299820]:
kind: LOCAL
info: LOCAL"[label="dest"color="brown"];
"{2E} LVAR [1415646066275954498]:
%derived-type: #<NAMED-TYPE *>
dynamic-extent: NIL" -> "{27} COMBINATION [4361784411754163848]:
kind: FULL
info: FULL"[label="uses"];
"{A} REF [970847179709888776]:
derived-type: #<VALUES-TYPE (VALUES (FUNCTION (T T T) NIL) &OPTIONAL)>" -> "{2F} NOT SUPPORTED YET:
#<GLOBAL-VAR
:%SOURCE-NAME SB-C::%TYPE-CHECK-ERROR/C
:TYPE #<SB-KERNEL:FUN-TYPE (FUNCTION (T T T) NIL)>
:DEFINED-TYPE #<SB-KERNEL:FUN-TYPE (FUNCTION (T T T) NIL)>
:WHERE-FROM :DECLARED
:KIND :GLOBAL-FUNCTION {1002A37C83}>"[label="leaf"];
"{A} REF [970847179709888776]:
derived-type: #<VALUES-TYPE (VALUES (FUNCTION (T T T) NIL) &OPTIONAL)>" -> "{30} REF [2480652678179831556]:
derived-type: #<VALUES-TYPE (VALUES (NOT NUMBER) &OPTIONAL)>"[label="next[ctran: INSIDE-BLOCK]"color="blue"];
"{A} REF [970847179709888776]:
derived-type: #<VALUES-TYPE (VALUES (FUNCTION (T T T) NIL) &OPTIONAL)>" -> "{31} LVAR [4253175545486229054]:
%derived-type: #<VALUES-TYPE (VALUES (FUNCTION (T T T) NIL) &OPTIONAL)>
dynamic-extent: NIL"[label="lvar"];
"{30} REF [2480652678179831556]:
derived-type: #<VALUES-TYPE (VALUES (NOT NUMBER) &OPTIONAL)>" -> "{16} LAMBDA-VAR [4210063433964233181]:
arg-info: NIL
flags: 0"[label="leaf"];
"{30} REF [2480652678179831556]:
derived-type: #<VALUES-TYPE (VALUES (NOT NUMBER) &OPTIONAL)>" -> "{32} REF [4597392725968595806]:
derived-type: #<VALUES-TYPE (VALUES (MEMBER SB-KERNEL:OBJECT-NOT-NUMBER-ERROR)
&OPTIONAL)>"[label="next[ctran: INSIDE-BLOCK]"color="blue"];
"{30} REF [2480652678179831556]:
derived-type: #<VALUES-TYPE (VALUES (NOT NUMBER) &OPTIONAL)>" -> "{33} LVAR [351302786686104344]:
%derived-type: #<VALUES-TYPE (VALUES (NOT NUMBER) &OPTIONAL)>
dynamic-extent: NIL"[label="lvar"];
"{32} REF [4597392725968595806]:
derived-type: #<VALUES-TYPE (VALUES (MEMBER SB-KERNEL:OBJECT-NOT-NUMBER-ERROR)
&OPTIONAL)>" -> "{34} CONSTANT [1034096512296901705]:
value: OBJECT-NOT-NUMBER-ERROR"[label="leaf"];
"{32} REF [4597392725968595806]:
derived-type: #<VALUES-TYPE (VALUES (MEMBER SB-KERNEL:OBJECT-NOT-NUMBER-ERROR)
&OPTIONAL)>" -> "{35} REF [4291216069658349752]:
derived-type: #<VALUES-TYPE (VALUES NULL &OPTIONAL)>"[label="next[ctran: INSIDE-BLOCK]"color="blue"];
"{32} REF [4597392725968595806]:
derived-type: #<VALUES-TYPE (VALUES (MEMBER SB-KERNEL:OBJECT-NOT-NUMBER-ERROR)
&OPTIONAL)>" -> "{36} LVAR [742349938659844719]:
%derived-type: #<VALUES-TYPE (VALUES (MEMBER SB-KERNEL:OBJECT-NOT-NUMBER-ERROR)
&OPTIONAL)>
dynamic-extent: NIL"[label="lvar"];
"{35} REF [4291216069658349752]:
derived-type: #<VALUES-TYPE (VALUES NULL &OPTIONAL)>" -> "{37} CONSTANT [3166890015804126914]:
value: NIL"[label="leaf"];
"{35} REF [4291216069658349752]:
derived-type: #<VALUES-TYPE (VALUES NULL &OPTIONAL)>" -> "{38} COMBINATION [3837710288170316803]:
kind: KNOWN
info: #<VOP-INFO
:NAME SB-VM::TYPE-CHECK-ERROR/C
:ARG-TYPES (* (:CONSTANT . SYMBOL) (:CONSTANT . T))
:RESULT-TYPES NIL
:LTN-POLICY :FAST-SAFE
:COST 900
:INFO-ARG-COUNT 2>"[label="next[ctran: INSIDE-BLOCK]"color="blue"];
"{35} REF [4291216069658349752]:
derived-type: #<VALUES-TYPE (VALUES NULL &OPTIONAL)>" -> "{39} LVAR [919264330689577080]:
%derived-type: #<VALUES-TYPE (VALUES NULL &OPTIONAL)>
dynamic-extent: NIL"[label="lvar"];
"{38} COMBINATION [3837710288170316803]:
kind: KNOWN
info: #<VOP-INFO
:NAME SB-VM::TYPE-CHECK-ERROR/C
:ARG-TYPES (* (:CONSTANT . SYMBOL) (:CONSTANT . T))
:RESULT-TYPES NIL
:LTN-POLICY :FAST-SAFE
:COST 900
:INFO-ARG-COUNT 2>" -> "{31} LVAR [4253175545486229054]:
%derived-type: #<VALUES-TYPE (VALUES (FUNCTION (T T T) NIL) &OPTIONAL)>
dynamic-extent: NIL"[label="fun"];
"{38} COMBINATION [3837710288170316803]:
kind: KNOWN
info: #<VOP-INFO
:NAME SB-VM::TYPE-CHECK-ERROR/C
:ARG-TYPES (* (:CONSTANT . SYMBOL) (:CONSTANT . T))
:RESULT-TYPES NIL
:LTN-POLICY :FAST-SAFE
:COST 900
:INFO-ARG-COUNT 2>" -> "{33} LVAR [351302786686104344]:
%derived-type: #<VALUES-TYPE (VALUES (NOT NUMBER) &OPTIONAL)>
dynamic-extent: NIL"[label="args[# 0]"];
"{38} COMBINATION [3837710288170316803]:
kind: KNOWN
info: #<VOP-INFO
:NAME SB-VM::TYPE-CHECK-ERROR/C
:ARG-TYPES (* (:CONSTANT . SYMBOL) (:CONSTANT . T))
:RESULT-TYPES NIL
:LTN-POLICY :FAST-SAFE
:COST 900
:INFO-ARG-COUNT 2>" -> "{36} LVAR [742349938659844719]:
%derived-type: #<VALUES-TYPE (VALUES (MEMBER SB-KERNEL:OBJECT-NOT-NUMBER-ERROR)
&OPTIONAL)>
dynamic-extent: NIL"[label="args[# 1]"];
"{38} COMBINATION [3837710288170316803]:
kind: KNOWN
info: #<VOP-INFO
:NAME SB-VM::TYPE-CHECK-ERROR/C
:ARG-TYPES (* (:CONSTANT . SYMBOL) (:CONSTANT . T))
:RESULT-TYPES NIL
:LTN-POLICY :FAST-SAFE
:COST 900
:INFO-ARG-COUNT 2>" -> "{39} LVAR [919264330689577080]:
%derived-type: #<VALUES-TYPE (VALUES NULL &OPTIONAL)>
dynamic-extent: NIL"[label="args[# 2]"];
"{31} LVAR [4253175545486229054]:
%derived-type: #<VALUES-TYPE (VALUES (FUNCTION (T T T) NIL) &OPTIONAL)>
dynamic-extent: NIL" -> "{38} COMBINATION [3837710288170316803]:
kind: KNOWN
info: #<VOP-INFO
:NAME SB-VM::TYPE-CHECK-ERROR/C
:ARG-TYPES (* (:CONSTANT . SYMBOL) (:CONSTANT . T))
:RESULT-TYPES NIL
:LTN-POLICY :FAST-SAFE
:COST 900
:INFO-ARG-COUNT 2>"[label="dest"color="brown"];
"{31} LVAR [4253175545486229054]:
%derived-type: #<VALUES-TYPE (VALUES (FUNCTION (T T T) NIL) &OPTIONAL)>
dynamic-extent: NIL" -> "{A} REF [970847179709888776]:
derived-type: #<VALUES-TYPE (VALUES (FUNCTION (T T T) NIL) &OPTIONAL)>"[label="uses"];
"{33} LVAR [351302786686104344]:
%derived-type: #<VALUES-TYPE (VALUES (NOT NUMBER) &OPTIONAL)>
dynamic-extent: NIL" -> "{38} COMBINATION [3837710288170316803]:
kind: KNOWN
info: #<VOP-INFO
:NAME SB-VM::TYPE-CHECK-ERROR/C
:ARG-TYPES (* (:CONSTANT . SYMBOL) (:CONSTANT . T))
:RESULT-TYPES NIL
:LTN-POLICY :FAST-SAFE
:COST 900
:INFO-ARG-COUNT 2>"[label="dest"color="brown"];
"{33} LVAR [351302786686104344]:
%derived-type: #<VALUES-TYPE (VALUES (NOT NUMBER) &OPTIONAL)>
dynamic-extent: NIL" -> "{30} REF [2480652678179831556]:
derived-type: #<VALUES-TYPE (VALUES (NOT NUMBER) &OPTIONAL)>"[label="uses"];
"{36} LVAR [742349938659844719]:
%derived-type: #<VALUES-TYPE (VALUES (MEMBER SB-KERNEL:OBJECT-NOT-NUMBER-ERROR)
&OPTIONAL)>
dynamic-extent: NIL" -> "{38} COMBINATION [3837710288170316803]:
kind: KNOWN
info: #<VOP-INFO
:NAME SB-VM::TYPE-CHECK-ERROR/C
:ARG-TYPES (* (:CONSTANT . SYMBOL) (:CONSTANT . T))
:RESULT-TYPES NIL
:LTN-POLICY :FAST-SAFE
:COST 900
:INFO-ARG-COUNT 2>"[label="dest"color="brown"];
"{36} LVAR [742349938659844719]:
%derived-type: #<VALUES-TYPE (VALUES (MEMBER SB-KERNEL:OBJECT-NOT-NUMBER-ERROR)
&OPTIONAL)>
dynamic-extent: NIL" -> "{32} REF [4597392725968595806]:
derived-type: #<VALUES-TYPE (VALUES (MEMBER SB-KERNEL:OBJECT-NOT-NUMBER-ERROR)
&OPTIONAL)>"[label="uses"];
"{39} LVAR [919264330689577080]:
%derived-type: #<VALUES-TYPE (VALUES NULL &OPTIONAL)>
dynamic-extent: NIL" -> "{38} COMBINATION [3837710288170316803]:
kind: KNOWN
info: #<VOP-INFO
:NAME SB-VM::TYPE-CHECK-ERROR/C
:ARG-TYPES (* (:CONSTANT . SYMBOL) (:CONSTANT . T))
:RESULT-TYPES NIL
:LTN-POLICY :FAST-SAFE
:COST 900
:INFO-ARG-COUNT 2>"[label="dest"color="brown"];
"{39} LVAR [919264330689577080]:
%derived-type: #<VALUES-TYPE (VALUES NULL &OPTIONAL)>
dynamic-extent: NIL" -> "{35} REF [4291216069658349752]:
derived-type: #<VALUES-TYPE (VALUES NULL &OPTIONAL)>"[label="uses"];
"{9} ENTRY [3859794357893252955]:
" -> "{3A} NOT SUPPORTED YET:
#<CLEANUP :KIND :BLOCK :MESS-UP #<SB-C::ENTRY {1002A2DEA3}> {1002A2DEF3}>"[label="cleanup"];
"{9} ENTRY [3859794357893252955]:
" -> "{1F} REF [1077682984383576289]:
derived-type: #<VALUES-TYPE (VALUES
(FUNCTION (&REST NUMBER)
(VALUES NUMBER &OPTIONAL))
&OPTIONAL)>"[label="next[ctran: INSIDE-BLOCK]"color="blue"];
"{9} ENTRY [3859794357893252955]:
" -> "{9} ENTRY [3859794357893252955]:
"[label="prev[ctran: BLOCK-START]"color="blue"];
"{4} CBLOCK [4485638051092447707]" -> "{0} COMPONENT [NIL]: ''DEFUN BAR''"[label="component"];
"{4} CBLOCK [4485638051092447707]" -> "{3} CBLOCK [463338187003706333]"[label="succ[# 0]"];
"{4} CBLOCK [4485638051092447707]" -> "{1} CBLOCK [1575903357056582106]"[label="pred[# 0]"];
"{4} CBLOCK [4485638051092447707]" -> "{3B} BIND [1357533544267766393]"[label="start[ctran: BLOCK-START]"color="blue"];
"{3B} BIND [1357533544267766393]" -> "{3C} CLAMBDA [2613760754162345450]:
%debug-name: (XEP BAR)
source-name: .ANONYMOUS.
kind: EXTERNAL"[label="lambda"];
"{3B} BIND [1357533544267766393]" -> "{3D} REF [1764939026324736725]:
derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>"[label="next[ctran: INSIDE-BLOCK]"color="green"];
"{3B} BIND [1357533544267766393]" -> "{3B} BIND [1357533544267766393]"[label="prev[ctran: BLOCK-START]"color="red"];
"{3C} CLAMBDA [2613760754162345450]:
%debug-name: (XEP BAR)
source-name: .ANONYMOUS.
kind: EXTERNAL" -> "{3C} CLAMBDA [2613760754162345450]:
%debug-name: (XEP BAR)
source-name: .ANONYMOUS.
kind: EXTERNAL"[label="home"];
"{3C} CLAMBDA [2613760754162345450]:
%debug-name: (XEP BAR)
source-name: .ANONYMOUS.
kind: EXTERNAL" -> "{3E} LAMBDA-VAR [602304310100471643]:
arg-info: NIL
flags: 1"[label="vars[# 0]"];
"{3C} CLAMBDA [2613760754162345450]:
%debug-name: (XEP BAR)
source-name: .ANONYMOUS.
kind: EXTERNAL" -> "{3F} LAMBDA-VAR [3684977715938429788]:
arg-info: NIL
flags: 0"[label="vars[# 1]"];
"{3C} CLAMBDA [2613760754162345450]:
%debug-name: (XEP BAR)
source-name: .ANONYMOUS.
kind: EXTERNAL" -> "{40} LAMBDA-VAR [1054668136212602532]:
arg-info: NIL
flags: 0"[label="vars[# 2]"];
"{3C} CLAMBDA [2613760754162345450]:
%debug-name: (XEP BAR)
source-name: .ANONYMOUS.
kind: EXTERNAL" -> "{41} LAMBDA-VAR [4315196173549852881]:
arg-info: NIL
flags: 0"[label="vars[# 3]"];
"{3E} LAMBDA-VAR [602304310100471643]:
arg-info: NIL
flags: 1" -> "{3C} CLAMBDA [2613760754162345450]:
%debug-name: (XEP BAR)
source-name: .ANONYMOUS.
kind: EXTERNAL"[label="home"];
"{3F} LAMBDA-VAR [3684977715938429788]:
arg-info: NIL
flags: 0" -> "{3C} CLAMBDA [2613760754162345450]:
%debug-name: (XEP BAR)
source-name: .ANONYMOUS.
kind: EXTERNAL"[label="home"];
"{40} LAMBDA-VAR [1054668136212602532]:
arg-info: NIL
flags: 0" -> "{3C} CLAMBDA [2613760754162345450]:
%debug-name: (XEP BAR)
source-name: .ANONYMOUS.
kind: EXTERNAL"[label="home"];
"{41} LAMBDA-VAR [4315196173549852881]:
arg-info: NIL
flags: 0" -> "{3C} CLAMBDA [2613760754162345450]:
%debug-name: (XEP BAR)
source-name: .ANONYMOUS.
kind: EXTERNAL"[label="home"];
"{3D} REF [1764939026324736725]:
derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>" -> "{11} CLAMBDA [274430610392932488]:
%debug-name: NIL
source-name: BAR
kind: NIL"[label="leaf"];
"{3D} REF [1764939026324736725]:
derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>" -> "{42} REF [842470847812081026]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>"[label="next[ctran: INSIDE-BLOCK]"color="blue"];
"{3D} REF [1764939026324736725]:
derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>" -> "{43} LVAR [1888062279493340457]:
%derived-type: NIL
dynamic-extent: NIL"[label="lvar"];
"{42} REF [842470847812081026]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>" -> "{3F} LAMBDA-VAR [3684977715938429788]:
arg-info: NIL
flags: 0"[label="leaf"];
"{42} REF [842470847812081026]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>" -> "{44} REF [2055375462078303612]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>"[label="next[ctran: INSIDE-BLOCK]"color="blue"];
"{42} REF [842470847812081026]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>" -> "{45} LVAR [4254170655862804359]:
%derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>
dynamic-extent: NIL"[label="lvar"];
"{44} REF [2055375462078303612]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>" -> "{40} LAMBDA-VAR [1054668136212602532]:
arg-info: NIL
flags: 0"[label="leaf"];
"{44} REF [2055375462078303612]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>" -> "{46} REF [4363891311576890011]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>"[label="next[ctran: INSIDE-BLOCK]"color="blue"];
"{44} REF [2055375462078303612]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>" -> "{47} LVAR [3883248025090896421]:
%derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>
dynamic-extent: NIL"[label="lvar"];
"{46} REF [4363891311576890011]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>" -> "{41} LAMBDA-VAR [4315196173549852881]:
arg-info: NIL
flags: 0"[label="leaf"];
"{46} REF [4363891311576890011]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>" -> "{48} COMBINATION [3442268956323344380]:
kind: LOCAL
info: LOCAL"[label="next[ctran: INSIDE-BLOCK]"color="blue"];
"{46} REF [4363891311576890011]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>" -> "{49} LVAR [571401066792478435]:
%derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>
dynamic-extent: NIL"[label="lvar"];
"{48} COMBINATION [3442268956323344380]:
kind: LOCAL
info: LOCAL" -> "{43} LVAR [1888062279493340457]:
%derived-type: NIL
dynamic-extent: NIL"[label="fun"];
"{48} COMBINATION [3442268956323344380]:
kind: LOCAL
info: LOCAL" -> "{45} LVAR [4254170655862804359]:
%derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>
dynamic-extent: NIL"[label="args[# 0]"];
"{48} COMBINATION [3442268956323344380]:
kind: LOCAL
info: LOCAL" -> "{47} LVAR [3883248025090896421]:
%derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>
dynamic-extent: NIL"[label="args[# 1]"];
"{48} COMBINATION [3442268956323344380]:
kind: LOCAL
info: LOCAL" -> "{49} LVAR [571401066792478435]:
%derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>
dynamic-extent: NIL"[label="args[# 2]"];
"{43} LVAR [1888062279493340457]:
%derived-type: NIL
dynamic-extent: NIL" -> "{48} COMBINATION [3442268956323344380]:
kind: LOCAL
info: LOCAL"[label="dest"color="brown"];
"{43} LVAR [1888062279493340457]:
%derived-type: NIL
dynamic-extent: NIL" -> "{3D} REF [1764939026324736725]:
derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>"[label="uses"];
"{45} LVAR [4254170655862804359]:
%derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>
dynamic-extent: NIL" -> "{48} COMBINATION [3442268956323344380]:
kind: LOCAL
info: LOCAL"[label="dest"color="brown"];
"{45} LVAR [4254170655862804359]:
%derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>
dynamic-extent: NIL" -> "{42} REF [842470847812081026]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>"[label="uses"];
"{47} LVAR [3883248025090896421]:
%derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>
dynamic-extent: NIL" -> "{48} COMBINATION [3442268956323344380]:
kind: LOCAL
info: LOCAL"[label="dest"color="brown"];
"{47} LVAR [3883248025090896421]:
%derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>
dynamic-extent: NIL" -> "{44} REF [2055375462078303612]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>"[label="uses"];
"{49} LVAR [571401066792478435]:
%derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>
dynamic-extent: NIL" -> "{48} COMBINATION [3442268956323344380]:
kind: LOCAL
info: LOCAL"[label="dest"color="brown"];
"{49} LVAR [571401066792478435]:
%derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>
dynamic-extent: NIL" -> "{46} REF [4363891311576890011]:
derived-type: #<VALUES-TYPE (VALUES T &OPTIONAL)>"[label="uses"];
"{6} BIND [2888465489035891844]" -> "{11} CLAMBDA [274430610392932488]:
%debug-name: NIL
source-name: BAR
kind: NIL"[label="lambda"];
"{6} BIND [2888465489035891844]" -> "{6} BIND [2888465489035891844]"[label="prev[ctran: BLOCK-START]"color="red"];
}

128
contrib/sb-graph/example/trace-4-toplevelform.dot
View file

@ -1,128 +0,0 @@
digraph {
"{0} COMPONENT [TOPLEVEL]: ''top level form''" -> "{1} CBLOCK [4546777747233824097]"[label="head"];
"{0} COMPONENT [TOPLEVEL]: ''top level form''" -> "{2} CBLOCK [293033905737092273]"[label="tail"];
"{1} CBLOCK [4546777747233824097]" -> "{0} COMPONENT [TOPLEVEL]: ''top level form''"[label="component"];
"{1} CBLOCK [4546777747233824097]" -> "{3} CBLOCK [2374185086335330572]"[label="succ[# 0]"];
"{3} CBLOCK [2374185086335330572]" -> "{0} COMPONENT [TOPLEVEL]: ''top level form''"[label="component"];
"{3} CBLOCK [2374185086335330572]" -> "{2} CBLOCK [293033905737092273]"[label="succ[# 0]"];
"{3} CBLOCK [2374185086335330572]" -> "{1} CBLOCK [4546777747233824097]"[label="pred[# 0]"];
"{3} CBLOCK [2374185086335330572]" -> "{4} BIND [2124840765505938481]"[label="start[ctran: BLOCK-START]"color="blue"];
"{2} CBLOCK [293033905737092273]" -> "{0} COMPONENT [TOPLEVEL]: ''top level form''"[label="component"];
"{2} CBLOCK [293033905737092273]" -> "{3} CBLOCK [2374185086335330572]"[label="pred[# 0]"];
"{4} BIND [2124840765505938481]" -> "{5} CLAMBDA [3240387953118118454]:
%debug-name: (TOP-LEVEL-FORM
(%DEFUN 'BAR
(NAMED-LAMBDA BAR
(B C D)
(DECLARE (TOP-LEVEL-FORM))
(BLOCK BAR (* # D)))))
source-name: .ANONYMOUS.
kind: TOPLEVEL"[label="lambda"];
"{4} BIND [2124840765505938481]" -> "{6} REF [1909866941284971615]:
derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>"[label="next[ctran: INSIDE-BLOCK]"color="green"];
"{4} BIND [2124840765505938481]" -> "{4} BIND [2124840765505938481]"[label="prev[ctran: BLOCK-START]"color="red"];
"{5} CLAMBDA [3240387953118118454]:
%debug-name: (TOP-LEVEL-FORM
(%DEFUN 'BAR
(NAMED-LAMBDA BAR
(B C D)
(DECLARE (TOP-LEVEL-FORM))
(BLOCK BAR (* # D)))))
source-name: .ANONYMOUS.
kind: TOPLEVEL" -> "{5} CLAMBDA [3240387953118118454]:
%debug-name: (TOP-LEVEL-FORM
(%DEFUN 'BAR
(NAMED-LAMBDA BAR
(B C D)
(DECLARE (TOP-LEVEL-FORM))
(BLOCK BAR (* # D)))))
source-name: .ANONYMOUS.
kind: TOPLEVEL"[label="home"];
"{6} REF [1909866941284971615]:
derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>" -> "{7} NOT SUPPORTED YET:
#<GLOBAL-VAR
:%SOURCE-NAME SB-IMPL::%DEFUN
:TYPE #<SB-KERNEL:BUILT-IN-CLASSOID FUNCTION (read-only)>
:DEFINED-TYPE #<SB-KERNEL:FUN-TYPE (FUNCTION (T FUNCTION &OPTIONAL T T)
(VALUES (OR SYMBOL CONS) &OPTIONAL))>
:WHERE-FROM :DEFINED
:KIND :GLOBAL-FUNCTION {1001D6DA43}>"[label="leaf"];
"{6} REF [1909866941284971615]:
derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>" -> "{8} REF [784168789779171862]:
derived-type: #<VALUES-TYPE (VALUES (MEMBER BAR) &OPTIONAL)>"[label="next[ctran: INSIDE-BLOCK]"color="blue"];
"{6} REF [1909866941284971615]:
derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>" -> "{9} LVAR [2701418418247132151]:
%derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>
dynamic-extent: NIL"[label="lvar"];
"{8} REF [784168789779171862]:
derived-type: #<VALUES-TYPE (VALUES (MEMBER BAR) &OPTIONAL)>" -> "{A} CONSTANT [1255380336112371100]:
value: BAR"[label="leaf"];
"{8} REF [784168789779171862]:
derived-type: #<VALUES-TYPE (VALUES (MEMBER BAR) &OPTIONAL)>" -> "{B} NOT SUPPORTED YET:
#<ENCLOSE
:FUNS (#<SB-C::CLAMBDA
:%SOURCE-NAME BAR
:%DEBUG-NAME NIL
:KIND NIL
:TYPE #<SB-KERNEL:FUN-TYPE (FUNCTION (T T T)
(VALUES NUMBER &OPTIONAL))>
:WHERE-FROM :DEFINED
:VARS (B C D) {1002A2D803}>) {1002A2ED73}>"[label="next[ctran: INSIDE-BLOCK]"color="blue"];
"{8} REF [784168789779171862]:
derived-type: #<VALUES-TYPE (VALUES (MEMBER BAR) &OPTIONAL)>" -> "{C} LVAR [2400416095386229337]:
%derived-type: #<VALUES-TYPE (VALUES (MEMBER BAR) &OPTIONAL)>
dynamic-extent: NIL"[label="lvar"];
"{C} LVAR [2400416095386229337]:
%derived-type: #<VALUES-TYPE (VALUES (MEMBER BAR) &OPTIONAL)>
dynamic-extent: NIL" -> "{D} COMBINATION [2858390395914678261]:
kind: FULL
info: FULL"[label="dest"color="brown"];
"{C} LVAR [2400416095386229337]:
%derived-type: #<VALUES-TYPE (VALUES (MEMBER BAR) &OPTIONAL)>
dynamic-extent: NIL" -> "{8} REF [784168789779171862]:
derived-type: #<VALUES-TYPE (VALUES (MEMBER BAR) &OPTIONAL)>"[label="uses"];
"{D} COMBINATION [2858390395914678261]:
kind: FULL
info: FULL" -> "{9} LVAR [2701418418247132151]:
%derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>
dynamic-extent: NIL"[label="fun"];
"{D} COMBINATION [2858390395914678261]:
kind: FULL
info: FULL" -> "{C} LVAR [2400416095386229337]:
%derived-type: #<VALUES-TYPE (VALUES (MEMBER BAR) &OPTIONAL)>
dynamic-extent: NIL"[label="args[# 0]"];
"{D} COMBINATION [2858390395914678261]:
kind: FULL
info: FULL" -> "{E} LVAR [2458505184304471429]:
%derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>
dynamic-extent: NIL"[label="args[# 1]"];
"{9} LVAR [2701418418247132151]:
%derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>
dynamic-extent: NIL" -> "{D} COMBINATION [2858390395914678261]:
kind: FULL
info: FULL"[label="dest"color="brown"];
"{9} LVAR [2701418418247132151]:
%derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>
dynamic-extent: NIL" -> "{6} REF [1909866941284971615]:
derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>"[label="uses"];
"{E} LVAR [2458505184304471429]:
%derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>
dynamic-extent: NIL" -> "{D} COMBINATION [2858390395914678261]:
kind: FULL
info: FULL"[label="dest"color="brown"];
"{E} LVAR [2458505184304471429]:
%derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>
dynamic-extent: NIL" -> "{F} REF [4329924708167232172]:
derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>"[label="uses"];
"{F} REF [4329924708167232172]:
derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>" -> "{10} NOT SUPPORTED YET:
#<FUNCTIONAL :%SOURCE-NAME BAR :%DEBUG-NAME NIL {1002BF5203}>"[label="leaf"];
"{F} REF [4329924708167232172]:
derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>" -> "{D} COMBINATION [2858390395914678261]:
kind: FULL
info: FULL"[label="next[ctran: INSIDE-BLOCK]"color="blue"];
"{F} REF [4329924708167232172]:
derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>" -> "{E} LVAR [2458505184304471429]:
%derived-type: #<VALUES-TYPE (VALUES FUNCTION &OPTIONAL)>
dynamic-extent: NIL"[label="lvar"];
}

124
contrib/sb-graph/readme.org
View file

@ -1,124 +0,0 @@
* ir1-grapher
This library graphs SBCL [[https://cmucl.org/docs/internals/html/The-Implicit-Continuation-Representation.html#The-Implicit-Continuation-Representation][ir1]] and outputs graphviz.
As of now, it is stil unfinished. There are a few tweaks that are
needed to improve useablility, in particular, I think the rendering
could be done a lot better, with subgraphs, to make it a lot more
readable. Also to make it more readable, I'm planning on
implementing rainbow-parens-esque arrow + label color randomization.
** How do I use it during compiler tracing?
To load the system, you can call ~(asdf:load-system
:ir1-grapher)~ once you have either loaded ~ir1-grapher.asd~
manually, or placed the folder inside your [[https://common-lisp.net/project/asdf/asdf/Configuring-ASDF-to-find-your-systems.html][ASDF load path]].
Because of the way it hooks in the compiler, you shouldn't actually
have to do anything after loading it except turning on trace output
of the compiler (SBCL), and adding ~:sb-graph~ to
~sb-c::*compile-trace-targets*~. Turning on the tracing can be done
by calling ~(compile-file "file" :trace-file t)~, and adding
~:sb-graph~ to ~sb-c::*compile-trace-targets*~ can be done however
you want. After compilation is done, alongside the normal trace
file, SBCL is hooked into writing a series of .dot files, which
contain the graphviz DOT representation of all the components
compiled. If you set ~*compile-progress*~ to ~T~, it will print out
progress information, and will tell you when and where it writes
out the graphviz files.
** How do I use the system interactively?
If you ran into a compiler error, and want to graph the
still-in-memory code interactively, you can do so with the
following functions:
*** ~(make-and-dfs object distance)~
This function takes an ir1 object ~object~, and integer
~distance~, and returns a graph object with every node up to
~distance~ hops away from ~object~ in its ~dfs-table~. Each object
is tagged with a "codename", visible as a hex digit in braces at
the start of each graph node.
Then, to operate on the graph interactively, you can use:
*** ~(interactively-graph graph &optional filename)~
This function takes a ~graph~ and a ~filename~, and sets the
current working graph to it, and the current output file to the
filename. When calling ~output~ and ~expand~, the graph will be
written to ~filename~.
*** ~(output)~
This function outputs the current working graph to a string, and
if ~interactively-graph~ was called with a filename, writes it to
that file.
*** ~(expand codename)~
After you've rendered the graph, if you want to add a node to the
~dfs-table~ (thus expanding the amount of the in-memory objects
rendered), call this function with the codename of the new object
you'd like to add. Example: ~(expand "A")~.
If you passed a filename to ~interactively-graph~, this function
will then write the render to file automatically.
*** ~(unexpand codename)~
Removes the node tied to the codename from the table, meaning that
it won't get its neighbours traversed when graph rendering is done.
*** ~(get-node codename)~
Returns the object tied to ~codename~ from the current interactive
graph.
** And if you don't want to use ~interactively-graph~:
*** ~(render-graph graph)~
Given a graph with objects in its ~dfs-table~, returns a string of
the rendering of the graph in DOT.
Does the same thing as ~output~, but without using
~interactively-graph~.
*** ~(expand-codename graph codename)~
Given a graph and codename, put the node tied to ~codename~ into
the ~dfs-table~ of the graph.
Does the same thing as ~expand~, but without using
~interactively-graph~.
*** ~(unexpand-codename graph codename)~
Does the same thing as ~unexpand~, but without using
~interactively-graph~.
*** ~(get-node-from-codename graph codename)~
Return the node tied to ~codename~ in ~graph~.
Does the same thing as ~node~, but without using
~interactively-graph~.
** What good is ~interactively-graph~ if I need to run ~dot~ every time the graph gets output?
That's where ~render-on-change.sh~ comes in. Run
~render-on-change.sh~ with two arguments. First is the input DOT
file, and second is the output SVG file. If you want to export to a
different format, just modify the ~-Tsvg~ of the script.
** Help! It's saying there's a package locking error.
Run ~(sb-ext:unlock-package :sb-c)~ in the REPL, or compile SBCL
with ~--with-sb-devel~ (if you're doing compiler work, you should
probably do this anyways). In ~src/package.lisp~, there's a
~(sb-ext:unlock-package :sb-c)~ statement, but it seems to not work
as expected.
** But what if the compiler breaks your library, or I want to muck around with it?
~hooking.lisp~ contains all the code that is used to hook the
compiler directly, and ~graphing.lisp~ goes from the compiler data
structures to the graphviz DOT format.
Right now, I'm assuming that the only place that the compiler will
ever call ~sb-c::ir2-convert~ for each component is inside
~%compile-component~, and only one time. If this becomes no longer
true, then the hooking location/manner will have to be modified.
** After the ~.dot~ files get output, how do I render them?
~dot -T<output-format> input.dot > output~.
For example, ~dot -Tsvg trace-1-DEFUNFOO.dot > out.svg~.
** Can I see an example?
Yes, look at the ~example/~ folder. It contains the dot output
when running ~(compile-file "testfile" :trace-file t)~.

8
contrib/sb-graph/render-on-change.sh
View file

@ -1,8 +0,0 @@
#!/bin/bash
inotifywait -e close_write,moved_to,create -m . |
while read -r directory events filename; do
if [ "$filename" = "$1" ]; then
dot -Tsvg $1 > $2
fi
done

17
contrib/sb-graph/sb-graph.asd
View file

@ -1,17 +0,0 @@
;;; -*- Lisp -*-
#-(or sb-testing-contrib sb-building-contrib)
(error "Can't build contribs with ASDF")
(asdf:defsystem "sb-graph"
:serial t
:components
((:module src
:serial t
:components
((:file "package")
(:file "graphing")
(:file "hooking"))))
:perform (load-op :after (o c) (provide 'sb-graph)))
;;; The tests for sb-graph are under tests/sb-graph.impure.lisp to
;;; take advantage of the sbcl regression tester features.

120
contrib/sb-graph/sb-graph.texinfo
View file

@ -1,120 +0,0 @@
@node ICR Graphing
@comment node-name, next, previous, up
@chapter ICR Graphing
@cindex Graph, ICR, IR1
The @code{sb-graph} module provides a graphing tool for SBCL ir1. It
outputs graphviz DOT format.
Its main features are that it can hook compilation so that SBCL can
output .dot files when compiler tracing is enabled, and, given a graph
in memory, provide the facility to interactively graph and interact with
it.
@menu
* Overview::
* User Manual::
* API Description::
@end menu
@node Overview
@section Overview
@node User Manual
@section User Manual
If all you want to do is output .dot files during compiler tracing, you
shouldn’t actually have to do anything after loading it except turning
on SBCL’s trace output. This can be done by calling (compile-file "file"
:trace-file t). After compilation is done, alongside the normal trace
file, SBCL is transparently hooked into writing a series of .dot files,
which contain the graphviz DOT representation of all the components
compiled. If you set sb-c::*compile-progress* to T, it will print out
progress information, and will tell you when and where it writes out the
graphviz files.
To use it interactively, call interactively-graph with a graph object
and output filename. After this is done, output, expand, and get-node
can be used to interact with said graph. As you call expand, the graph
will be output to the filename you specified. In the root of the
repository is a shell script render-on-change.sh which can be run with
two arguments: the input DOT file (the one passed to
interactively-graph), as well as an output SVG file that graphviz will
render to every time the file is changed on disk. This uses
inotify-wait, and so inotify-utils must be installed. As far as I know
this only works on Linux. A similar thing could be written for other
operating systems, though. All-in-all, this allows for a very short
expand-render-display loop.
@node API Description
@section API Description
@itemize
@item
* (make-and-dfs object distance)
This function takes an ir1 object object, and integer distance, and
returns a graph object with every node up to distance hops away from
object in its dfs-table. Each object is tagged with a “codename”,
visible as a hex digit in braces at the start of each graph node.
@item
* (interactively-graph graph &optional filename)
This function takes a graph and a filename, and sets the current working
graph to it, and the current output file to the filename. When calling
output and expand, the graph will be written to filename.
@item
* (output)
This function outputs the current working graph to a string, and if
interactively-graph was called with a filename, writes it to that file.
@item
* (expand codename)
After you’ve rendered the graph, if you want to add
a node to the dfs-table (thus expanding the amount of the in-memory
objects rendered), call this function with the codename of the new
object you’d like to add. Example: (expand "A").
If you passed a filename to interactively-graph, this function will then
write the render to file automatically.
@item
* (get-node codename)
Returns the object tied to codename from the current interactive graph.
@item
* (render-graph graph)
Given a graph with objects in its dfs-table, returns a string of the
rendering of the graph in DOT.
Does the same thing as output, but without using interactively-graph.
@item
* (expand-graph-codename graph codename)
Given a graph and codename, put the node tied to codename into the
dfs-table of the graph.
Does the same thing as expand, but without using interactively-graph.
@item
* (get-node-from-codename graph codename)
Return the node tied to codename in graph.
Does the same thing as node, but without using interactively-graph.

389
contrib/sb-graph/src/graphing.lisp
View file

@ -1,389 +0,0 @@
(in-package :sb-graph)
(defun make-graph ()
(make-instance 'graph
:stream (make-string-output-stream)
:dfs-table (make-hash-table :test 'eq :size 63)
:obj-table (make-hash-table :test 'eq :size 63)
:codename-table (make-hash-table :test 'equal :size 63)
:codename-number 0))
(defun make-and-dfs (object distance)
(let ((graph (make-graph)))
(dfs-add graph distance object)
graph))
(defun save-graph (str filename)
(with-open-file (s filename :direction :output :if-does-not-exist :create :if-exists :supersede)
(write-string str s)))
;; dfs-table: obj -> T
;; obj-table: obj -> codename
;; codename-table: codename -> obj
(defclass graph ()
((stream :initarg :stream :accessor stream)
(dfs-table :initarg :dfs-table :reader dfs-table)
(obj-table :initarg :obj-table :reader obj-table)
(codename-table :initarg :codename-table :reader codename-table)
(codename-number :initarg :codename-number :accessor codename-number)))
(defmethod render-graph (graph)
(get-output-stream-string (stream graph))
(write-string (format nil "digraph {~%") (stream graph))
(maphash #'(lambda (k v) (declare (ignore v)) (edges graph k)) (dfs-table graph))
(write-string "}" (stream graph))
(get-output-stream-string (stream graph)))
;; RENDER-GRAPH goes through all the nodes in DFS-TABLE, so we add the
;; node corresponding to the given codename to the graph's DFS-TABLE
(defmethod expand-codename (graph codename)
(setf (gethash (gethash codename (codename-table graph))
(dfs-table graph))
t))
(defmethod unexpand-codename (graph codename)
(remhash (gethash codename (codename-table graph))
(dfs-table graph)))
(defun get-node-from-codename (graph codename)
(gethash codename (codename-table graph)))
;; creates a new codename, ties it to this object, then returns it.
(defun add-to-code-tables (graph object)
(if (nth-value 1 (gethash object (obj-table graph)))
(gethash object (obj-table graph))
(let ((new-codename (let ((res (format nil "~X" (codename-number graph))))
(incf (codename-number graph))
res)))
(setf (gethash object (obj-table graph))
new-codename
(gethash new-codename (codename-table graph))
object)
new-codename)))
(let ((curr-graph nil)
(curr-file nil))
(defun interactively-graph (graph &optional (filename nil))
(setf curr-graph graph)
(setf curr-file filename))
(defun output ()
(if curr-file
(save-graph (render-graph curr-graph) curr-file)
(render-graph curr-graph)))
(defun expand (codename)
(expand-codename curr-graph codename)
(when curr-file
(output)))
(defun unexpand (codename)
(unexpand-codename curr-graph codename)
(when curr-file
(output)))
(defun get-node (codename)
(get-node-from-codename curr-graph codename)))
;; modify-str-plist returns a new plist which is identical except the
;; value associated with KEY has been replaced by what is returned by
;; funcalling func on the value
(defun modify-str-plist (plist key func)
(assert (= 0 (mod (length plist) 2)))
(apply #'nconc
(loop with ck = nil
with cv = nil
while (setf ck (car plist)
cv (cadr plist))
collect (let ((v (if (string= key ck)
(list ck (funcall func cv))
(list ck cv))))
(setf plist (cddr plist))
v))))
;; this is because graphviz doesn't allow nodes to have more than 16k
;; of text in them
(defun clamp (str)
(if (< 16300 (length str))
(subseq str 0 16300)
str))
;; This was copied from the common lisp cookbook.
(defun replace-all (string part replacement &key (test #'char=))
"Returns a new string in which all the occurences of the part
is replaced with replacement."
(with-output-to-string (out)
(loop with part-length = (length part)
for old-pos = 0 then (+ pos part-length)
for pos = (search part string
:start2 old-pos
:test test)
do (write-string string out
:start old-pos
:end (or pos (length string)))
when pos do (write-string replacement out)
while pos)))
(defmethod edge ((graph graph) from to &rest options)
(assert (= 0 (mod (length options) 2)))
(format (stream graph) "\"{~A} ~A\" -> \"{~A} ~A\"[~A];~%"
(if (gethash from (obj-table graph))
(gethash from (obj-table graph))
(add-to-code-tables graph from))
(replace-all (replace-all (clamp (display from)) "\"" "'") "\\" "\\\\")
(if (gethash to (obj-table graph))
(gethash to (obj-table graph))
(add-to-code-tables graph to))
(replace-all (replace-all (clamp (display to)) "\"" "'") "\\" "\\\\")
(apply #'concatenate
(cons 'string
(loop with ck = nil
with cv = nil
while (setf ck (car options)
cv (cadr options))
collect (let ((v (format nil "~A=\"~A\"" ck cv)))
(setf options (cddr options))
v))))))
;; this is overriding the edge so that we can not render CTRANs
(defmethod edge ((graph graph) from (to sb-c::ctran) &rest options)
(apply #'edge (nconc (list graph from (sb-c::ctran-next to))
(modify-str-plist options "label"
(lambda (x)
(concatenate 'string x (format nil "[ctran: ~A]" (sb-c::ctran-kind to)))))
(unless (find-if (lambda (x) (string= x "color")) options)
'("color" "blue")))))
(defmethod edge ((graph graph) from (to list) &rest options)
(let ((counter 0))
(mapc #'(lambda (x)
(apply #'edge
(nconc (list graph from x)
(modify-str-plist
options "label"
#'(lambda (x)
(let ((res (format nil "~A[# ~A]"
x counter)))
(incf counter)
res))))))
to)))
;; display goes from an object to the string representation that'll be
;; inside the graph nodes
(defmethod display ((c sb-c::component))
(format nil "COMPONENT: '~S'"
(sb-c::component-name c)))
;; The sxhash is required to not end up with a single CBLOCK node
(defmethod display ((b sb-c::cblock))
(format nil "CBLOCK"))
(defmethod display ((ctran sb-c::ctran))
(error "Trying to display a CTRAN, this shouldn't happen"))
(defmethod display ((cl sb-c::clambda))
(format nil "CLAMBDA:~%%debug-name: ~A~%source-name: ~A~%kind: ~A"
(sb-c::lambda-%debug-name cl)
(sb-c::lambda-%source-name cl)
(sb-c::lambda-kind cl)))
(defmethod display ((cr sb-c::creturn))
(format nil "CRETURN:~%result-type: ~A"
(sb-c::return-result-type cr)))
(defmethod display ((bind sb-c::bind))
(format nil "BIND"))
(defmethod display ((ref sb-c::ref))
(format nil "REF:~%derived-type: ~A"
(sb-c::ref-derived-type ref)))
(defmethod display ((comb sb-c::combination))
(format nil "COMBINATION:~%kind: ~A~%info: ~A"
(sb-c::combination-kind comb)
(sb-c::combination-info comb)))
(defmethod display ((lvar sb-c::lvar))
(format nil "LVAR:~%%derived-type: ~A~%dynamic-extent: ~A"
(sb-c::lvar-%derived-type lvar)
(sb-c::lvar-dynamic-extent lvar)))
(defmethod display ((const sb-c::constant))
(format nil "CONSTANT:~%value: ~A"
(sb-c::constant-value const)))
(defmethod display ((lamvar sb-c::lambda-var))
(format nil "LAMBDA-VAR:~%arg-info: ~A~%flags: ~A"
(sb-c::lambda-var-arg-info lamvar)
(sb-c::lambda-var-flags lamvar)))
(defmethod display ((entry sb-c::entry))
(format nil "ENTRY"))
(defmethod display (obj)
(format nil "NOT SUPPORTED YET:~% ~A" obj))
(defmethod edges ((graph graph) (objects list))
(mapc #'(lambda (o) (edges graph o)) objects))
(defmethod edges ((graph graph) (component sb-c::component))
(edge graph component (sb-c::component-head component) "label" "head")
(edge graph component (sb-c::component-tail component) "label" "tail"))
(defmethod edges ((graph graph) (cblock sb-c::cblock))
(edge graph cblock (sb-c::block-component cblock) "label" "component")
(edge graph cblock (sb-c::block-succ cblock) "label" "succ")
(edge graph cblock (sb-c::block-pred cblock) "label" "pred")
(edge graph cblock (sb-c::block-start cblock) "label" "start"))
;; Unfinished
(defmethod edges ((graph graph) (cl sb-c::clambda))
(edge graph cl (sb-c::lambda-home cl) "label" "home")
(edge graph cl (sb-c::lambda-vars cl) "label" "vars"))
(defmethod edges ((graph graph) (cr sb-c::creturn))
(edge graph cr (sb-c::return-lambda cr) "label" "lambda")
(edge graph cr (sb-c::return-result cr) "label" "result"))
;; this is just a dummy function to skip the CTRAN
(defmethod edges ((graph graph) (ct sb-c::ctran)))
(defmethod edges ((graph graph) (ref sb-c::ref))
(edge graph ref (sb-c::ref-leaf ref) "label" "leaf")
(edge graph ref (sb-c::ref-next ref) "label" "next")
(edge graph ref (sb-c::ref-lvar ref) "label" "lvar"))
(defmethod edges ((graph graph) (bind sb-c::bind))
(edge graph bind (sb-c::bind-lambda bind) "label" "lambda")
(edge graph bind (sb-c::bind-next bind) "label" "next" "color" "green")
(edge graph bind (sb-c::bind-prev bind) "label" "prev" "color" "red"))
(defmethod edges ((graph graph) (comb sb-c::combination))
(edge graph comb (sb-c::combination-fun comb) "label" "fun")
(edge graph comb (sb-c::combination-args comb) "label" "args"))
(defmethod edges ((graph graph) (lvar sb-c::lvar))
(edge graph lvar (sb-c::lvar-dest lvar) "label" "dest" "color" "brown")
(edge graph lvar (sb-c::lvar-uses lvar) "label" "uses"))
(defmethod edges ((graph graph) (lamvar sb-c::lambda-var))
(edge graph lamvar (sb-c::lambda-var-home lamvar) "label" "home")
(edge graph lamvar (sb-c::lambda-var-sets lamvar) "label" "sets"))
(defmethod edges ((graph graph) (entry sb-c::entry))
(edge graph entry (sb-c::entry-exits entry) "label" "exits")
(edge graph entry (sb-c::entry-cleanup entry) "label" "cleanup")
(edge graph entry (sb-c::entry-next entry) "label" "next")
(edge graph entry (sb-c::entry-prev entry) "label" "prev"))
(defmethod edges ((graph graph) object))
;; the name is a "pun" of the words 'unique' and 'graph'
(defmacro unig ((graph obj) &body body)
(let ((g (gensym))
(o (gensym)))
`(let ((,g ,graph)
(,o ,obj))
(unless (nth-value 1 (gethash ,o (dfs-table ,g)))
(setf (gethash ,o (dfs-table ,g)) t)
,@body))))
(defmethod dfs-add ((graph graph) (distance integer) (objects list))
(mapc #'(lambda (o) (dfs-add graph distance o)) objects))
;; a component should be rendered as a subgraph
(defmethod dfs-add ((graph graph) (distance integer) (component sb-c::component))
(when (> distance 0)
(decf distance)
(unig (graph component)
(dfs-add graph distance (sb-c::component-head component))
(dfs-add graph distance (sb-c::component-tail component)))))
(defmethod dfs-add ((graph graph) (distance integer) (cblock sb-c::cblock))
(when (> distance 0)
(decf distance)
(unig (graph cblock)
(dfs-add graph distance (sb-c::block-component cblock))
(dfs-add graph distance (sb-c::block-succ cblock))
(dfs-add graph distance (sb-c::block-pred cblock))
(dfs-add graph distance (sb-c::block-start cblock)))))
;; Unfinished
(defmethod dfs-add ((graph graph) (distance integer) (cl sb-c::clambda))
(when (> distance 0)
(decf distance)
(unig (graph cl)
(dfs-add graph distance (sb-c::lambda-home cl))
(dfs-add graph distance (sb-c::lambda-vars cl)))))
(defmethod dfs-add ((graph graph) (distance integer) (cr sb-c::creturn))
(when (> distance 0)
(decf distance)
(unig (graph cr)
(dfs-add graph distance (sb-c::return-lambda cr))
(dfs-add graph distance (sb-c::return-result cr)))))
;; (defmethod dfs-add ((graph graph) (distance integer) (node sb-c::node))
;; )
;; this is just a dummy function to skip the CTRAN. Note that it
;; doesn't decf distance.
(defmethod dfs-add ((graph graph) (distance integer) (ct sb-c::ctran))
(when (> distance 0)
(unig (graph ct)
(dfs-add graph distance (sb-c::ctran-next ct)))))
(defmethod dfs-add ((graph graph) (distance integer) (ref sb-c::ref))
(when (> distance 0)
(decf distance)
(unig (graph ref)
(dfs-add graph distance (sb-c::ref-leaf ref))
(dfs-add graph distance (sb-c::ref-next ref))
(dfs-add graph distance (sb-c::ref-lvar ref)))))
(defmethod dfs-add ((graph graph) (distance integer) (bind sb-c::bind))
(when (> distance 0)
(decf distance)
(unig (graph bind)
(dfs-add graph distance (sb-c::bind-lambda bind))
(dfs-add graph distance (sb-c::bind-next bind))
(dfs-add graph distance (sb-c::bind-prev bind)))))
(defmethod dfs-add ((graph graph) (distance integer) (comb sb-c::combination))
(when (> distance 0)
(decf distance)
(unig (graph comb)
(dfs-add graph distance (sb-c::combination-fun comb))
(dfs-add graph distance (sb-c::combination-args comb)))))
(defmethod dfs-add ((graph graph) (distance integer) (lvar sb-c::lvar))
(when (> distance 0)
(decf distance)
(unig (graph lvar)
(dfs-add graph distance (sb-c::lvar-dest lvar))
(dfs-add graph distance (sb-c::lvar-uses lvar)))))
(defmethod dfs-add ((graph graph) (distance integer) (lamvar sb-c::lambda-var))
(when (> distance 0)
(decf distance)
(unig (graph lamvar)
(dfs-add graph distance (sb-c::lambda-var-home lamvar))
(dfs-add graph distance (sb-c::lambda-var-sets lamvar)))))
(defmethod dfs-add ((graph graph) (distance integer) (entry sb-c::entry))
(when (> distance 0)
(decf distance)
(unig (graph entry)
(dfs-add graph distance (sb-c::entry-exits entry))
(dfs-add graph distance (sb-c::entry-cleanup entry))
(dfs-add graph distance (sb-c::entry-next entry))
(dfs-add graph distance (sb-c::entry-prev entry)))))
(defmethod dfs-add ((graph graph) (distance integer) object)
(when (> distance 0)
(decf distance)
(unig (graph object))))

87
contrib/sb-graph/src/hooking.lisp
View file

@ -1,87 +0,0 @@
(in-package :sb-graph)
(eval-when (:compile-toplevel :load-toplevel)
(defvar *hook-enabled* (make-hash-table)))
(defmacro hook (fun lambda-list &body body)
(let ((ll (gensym))
(f (gensym))
(orig (gensym)))
`(let ((,f ',fun))
(when (nth-value 1 (gethash ',f *hook-enabled*))
(unhook ,fun))
(setf (gethash ,f *hook-enabled*) t)
(sb-int::encapsulate ,f 'hook
(lambda (,orig &rest ,ll)
(when (hook-enabled ,fun)
(destructuring-bind ,lambda-list ,ll
(block hook
,@body)))
(apply ,orig ,ll))))))
(defmacro disable-hook (fun)
(let ((f (gensym)))
`(let ((,f ',fun))
(when (nth-value 1 (gethash ,f *hook-enabled*))
(setf (gethash ',fun *hook-enabled*) nil)))))
(defmacro enable-hook (fun)
(let ((f (gensym)))
`(let ((,f ',fun))
(when (nth-value 1 (gethash ,f *hook-enabled*))
(setf (gethash ',fun *hook-enabled*) t)))))
(defmacro unhook (fun)
(let ((f (gensym)))
`(let ((,f ',fun))
(when (nth-value 1 (gethash ,f *hook-enabled*))
(sb-int::unencapsulate ,f 'hook)
(remhash ,f *hook-enabled*)))))
(defmacro hook-enabled (fun)
`(gethash ',fun *hook-enabled*))
;; (defun test-hook (a b c &rest d)
;; (list (+ a b c) d))
;; (hook test-hook (a b c &rest d)
;; (format t "This is a hook! ~A ~A ~A ~A~%" a b c d))
;; (unhook test-hook)
;; (hook sb-c::compile-toplevel (lambdas load-time-value-p)
;; (format t "~%Hooking the compiler. compile-toplevel:~%lambdas: ~A~%load-time-value-p: ~A~%"
;; lambdas load-time-value-p))
;; (unhook sb-c::compile-toplevel)
;; (eval-when (:compile-toplevel :load-toplevel)
;; (defvar *acc* nil))
;; (hook sb-c::compile-component (component)
;; (push component *acc*))
(eval-when (:compile-toplevel :load-toplevel)
(defvar *trace-number* 0))
(hook sb-c::ir2-convert (component)
(disable-hook sb-c::ir2-convert)
(when (and (streamp sb-c::*compiler-trace-output*)
(find :sb-graph sb-c::*compile-trace-targets*))
(let* ((pn (pathname sb-c::*compiler-trace-output*))
(out-pn (make-pathname
:host (pathname-host pn)
:directory (pathname-directory pn)
:name
(format nil "trace-~A-~A" (incf *trace-number*)
(coerce (loop for char
across
(let ((cn (sb-c::component-name component)))
(cond
((symbolp cn) (symbol-name cn))
((stringp cn) cn)
((listp cn) (if (eq (car cn) 'top-level-form)
"TOP-LEVEL-FORM"
(format nil "~{~a~}" cn)))
(t "")))
when (or (alpha-char-p char)
(digit-char-p char)
(char= char #\-)
(char= char #\_))
collect char)
'string))
:type "dot")))
(save-graph (render-graph (make-and-dfs component 9999999)) out-pn)
(when sb-c::*compile-progress*
(format *debug-io* "~%; Wrote graphviz of component ~A to ~A.~%" component out-pn))))
(enable-hook sb-c::ir2-convert))

10
contrib/sb-graph/src/package.lisp
View file

@ -1,10 +0,0 @@
(eval-when (:compile-toplevel :load-toplevel)
(sb-ext:unlock-package :sb-c))
(defpackage :sb-graph
(:shadow :stream)
(:use :cl :cl-user)
(:export :hook :disable-hook :enable-hook :unhook :hook-enabled
:make-graph :make-and-dfs :save-graph :graph :render-graph
:expand :expand-codename :get-node-from-codename :expand :unexpand :get-node
:interactively-graph :output :dfs-add))

77
contrib/sb-grovel/def-to-lisp.lisp
View file

@ -181,6 +181,36 @@ code:
(as-c "return 0;")
(as-c "}")))
(defun run-c-compiler (sourcefile exefile)
(let ((cc (or (and (string/= (sb-ext:posix-getenv "CC") "")
(sb-ext:posix-getenv "CC"))
(if (member :sb-building-contrib *features*)
(error "~@<The CC environment variable not set during ~
SB-GROVEL build.~:@>")
(sb-int:style-warn
"CC environment variable not set, SB-GROVEL falling back to \"cc\"."))
"cc")))
(sb-ext:process-exit-code
(sb-ext:run-program
cc
(append
(split-cflags (sb-ext:posix-getenv "EXTRA_CFLAGS"))
#+(and linux largefile)
'("-D_LARGEFILE_SOURCE" "-D_LARGEFILE64_SOURCE" "-D_FILE_OFFSET_BITS=64")
#+(and (or x86 ppc sparc) (or linux freebsd)) '("-m32")
#+(and x86-64 darwin inode64)
`("-arch" "x86_64" ,(format nil "-mmacosx-version-min=~A"
(or (sb-ext:posix-getenv "SBCL_MACOSX_VERSION_MIN")
"10.6"))
"-D_DARWIN_USE_64_BIT_INODE")
#+(and x86-64 darwin (not inode64))
'("-arch" "x86_64" "-mmacosx-version-min=10.4")
#+(and x86-64 sunos) '("-m64")
(list "-o" (namestring exefile) (namestring sourcefile)))
:search t
:input nil
:output *trace-output*))))
;;; Extract constants as specified from INPUT, creating file OUTPUT.
;;; Very important: This OUTPUT formal parameter should ** literally ** be
;;; be named OUTPUT, and not OUTPUT-FILE. WAT ???
@ -203,6 +233,8 @@ code:
;;;
;;; TLDR: this stupid restriction on a variable's name makes
;;; something work that didn't used to work. And victory is ours!
#+asdf
(progn
(defun c-constants-extract (input output package)
(with-open-file (f output :direction :output :if-exists :supersede)
(with-open-file (i input :direction :input)
@ -210,8 +242,6 @@ code:
(definitions (read i)))
(print-c-source f headers definitions package)))))
#+asdf
(progn
(defclass grovel-constants-file (cl-source-file)
((package :accessor constants-package :initarg :package)
(do-not-grovel :accessor do-not-grovel
@ -246,48 +276,9 @@ code:
real-output-file))
(tmp-constants (merge-pathnames #p"constants.lisp-temp"
real-output-file)))
(funcall (intern "C-CONSTANTS-EXTRACT" (find-package "SB-GROVEL"))
filename tmp-c-source (constants-package component))
(c-constants-extract filename tmp-c-source (constants-package component))
(unless (do-not-grovel component)
(let* ((cc (or (and (string/= (sb-ext:posix-getenv "CC") "")
(sb-ext:posix-getenv "CC"))
(if (member :sb-building-contrib *features*)
(error "~@<The CC environment variable not set during ~
SB-GROVEL build.~:@>")
(sb-int:style-warn
"CC environment variable not set, SB-GROVEL falling back to \"cc\"."))
"cc"))
(code (sb-ext:process-exit-code
(sb-ext:run-program
cc
(append
(split-cflags (sb-ext:posix-getenv "EXTRA_CFLAGS"))
#+(and linux largefile)
'("-D_LARGEFILE_SOURCE"
"-D_LARGEFILE64_SOURCE"
"-D_FILE_OFFSET_BITS=64")
#+(and (or x86 ppc sparc) (or linux freebsd)) '("-m32")
#+(and x86-64 darwin inode64)
`("-arch" "x86_64"
,(format nil "-mmacosx-version-min=~A"
(or (sb-ext:posix-getenv "SBCL_MACOSX_VERSION_MIN")
"10.6"))
"-D_DARWIN_USE_64_BIT_INODE")
#+(and x86-64 darwin (not inode64))
'("-arch" "x86_64"
"-mmacosx-version-min=10.4")
#+(and x86 darwin)
`("-arch" "i386"
,(format nil "-mmacosx-version-min=~A"
(or (sb-ext:posix-getenv "SBCL_MACOSX_VERSION_MIN")
"10.4")))
#+(and x86-64 sunos) '("-m64")
(list "-o"
(namestring tmp-a-dot-out)
(namestring tmp-c-source)))
:search t
:input nil
:output *trace-output*))))
(let ((code (run-c-compiler tmp-c-source tmp-a-dot-out)))
(unless (= code 0)
(apply 'error 'c-compile-failed condition-arguments)))
(let ((code (sb-ext:process-exit-code

2
contrib/sb-grovel/foreign-glue.lisp
View file

@ -134,6 +134,7 @@
(defclass padding (value-slot)
())
(defgeneric slot-end (slot))
(defmethod print-object ((o value-slot) s)
(print-unreadable-object (o s :type t)
@ -152,7 +153,6 @@
(children slot))
:initial-value 0))))
(defgeneric slot-end (slot))
(defmethod slot-end ((slot slot))
(+ (offset slot) (size slot)))

7
contrib/sb-grovel/sb-grovel.asd
View file

@ -1,15 +1,10 @@
;;; -*- Lisp -*-
#-(or sb-testing-contrib sb-building-contrib)
(error "Can't build contribs with ASDF")
(defsystem "sb-grovel"
:version "0.2"
:depends-on ("asdf")
#+sb-building-contrib :pathname
#+sb-building-contrib #p"SYS:CONTRIB;SB-GROVEL;"
:components ((:file "defpackage")
(:file "def-to-lisp" :depends-on ("defpackage"))
(:file "foreign-glue" :depends-on ("defpackage")))
:perform (load-op :after (o c) (provide 'sb-grovel))
:perform (test-op (o c) t))
(:file "foreign-glue" :depends-on ("defpackage"))))

30
contrib/sb-introspect/introspect.lisp
View file

@ -460,18 +460,19 @@ If an unsupported TYPE is requested, the function will return NIL.
(defun find-function-definition-source (function)
(let* ((debug-info (function-debug-info function))
(debug-source (debug-info-source debug-info))
(debug-fun (debug-info-debug-function function debug-info)))
(multiple-value-bind (tlf character-offset)
(sb-di::debug-fun-tlf-and-offset debug-info debug-fun)
(debug-fun (debug-info-debug-function function debug-info))
(tlf (if debug-fun (sb-c::compiled-debug-fun-tlf-number debug-fun))))
(make-definition-source
:pathname
(when (stringp (debug-source-namestring debug-source))
(parse-namestring (debug-source-namestring debug-source)))
:character-offset character-offset
:character-offset
(if tlf
(elt (sb-c::debug-source-start-positions debug-source) tlf))
:form-path (if tlf (list tlf))
:form-number (sb-c::compiled-debug-fun-form-number debug-fun)
:file-write-date (debug-source-created debug-source)
:plist (sb-c::debug-source-plist debug-source)))))
:plist (sb-c::debug-source-plist debug-source))))
(defun translate-source-location (location)
(if location
@ -751,6 +752,14 @@ Experimental.
;;;; ALLOCATION INTROSPECTION
(eval-when (:compile-toplevel :execute)
(defmacro pinnedp (addr)
`(eql (sb-alien:alien-funcall
(sb-alien:extern-alien "sb_introspect_pinnedp"
(function sb-alien:int sb-alien:unsigned))
,addr)
1)))
(defun allocation-information (object)
"Returns information about the allocation of OBJECT. Primary return value
indicates the general type of allocation: :IMMEDIATE, :HEAP, :STACK,
@ -820,19 +829,12 @@ Experimental: interface subject to change."
(let* ((wp (page-protected-p object))
(index (sb-vm:find-page-index
(get-lisp-obj-address object)))
(flags (sb-alien:slot page 'sb-vm::flags))
.
#+big-endian
((type (ldb (byte 6 2) flags))
(dontmove (logbitp 0 flags)))
#+little-endian
((type (ldb (byte 6 0) flags))
(dontmove (logbitp 7 flags))))
(type (sb-alien:slot page 'sb-vm::flags)))
(list :space space
:generation (sb-alien:slot page 'sb-vm::gen)
:write-protected wp
:boxed (> (logand type #xf) 1)
:pinned dontmove
:pinned (pinnedp (get-lisp-obj-address object))
:large (logbitp 4 type)
:page index)))
(list :space space))

54
contrib/sb-introspect/sb-introspect.asd
View file

@ -9,59 +9,7 @@
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
#-(or sb-testing-contrib sb-building-contrib)
(error "Can't build contribs with ASDF")
(defsystem "sb-introspect"
:components ((:file "introspect"))
#+sb-building-contrib :pathname
#+sb-building-contrib #p"SYS:CONTRIB;SB-INTROSPECT;"
:perform (load-op :after (o c) (provide 'sb-introspect))
:in-order-to ((test-op (test-op "sb-introspect/tests"))))
(defclass plist-file (cl-source-file)
((source-plist
:initform nil
:initarg :source-plist
:reader plist-file-source-plist)))
(defmethod perform ((op compile-op) (com plist-file))
(with-compilation-unit (:source-plist (plist-file-source-plist com))
(call-next-method)))
(defmethod perform ((op load-op) (com plist-file))
(with-compilation-unit (:source-plist (plist-file-source-plist com))
(call-next-method)))
(defsystem "sb-introspect/tests"
:depends-on ("sb-introspect" "sb-rt")
#+sb-building-contrib :pathname
#+sb-building-contrib #p"SYS:CONTRIB;SB-INTROSPECT;"
:components ((:file "xref-test-data")
(:file "xref-test" :depends-on ("xref-test-data"))
(:plist-file "test" :source-plist (:test-outer "OUT") :operation-done-p (compile-op (o c) nil))
(:file "test-driver" :depends-on ("test")))
:perform
(test-op (o c)
;; N.b. At least DEFINITION-SOURCE-PLIST.1 assumes that CWD is the
;; contrib/sb-introspect directory which is true for when this is
;; implicitly run via make-target-contribs.sh -- but not when this
;; is executed manually.
(let ((*default-pathname-defaults* (translate-logical-pathname (system-source-directory c))))
(multiple-value-bind (soft strict pending) (symbol-call :sb-rt :do-tests)
(declare (ignorable pending))
(fresh-line)
(unless strict
#+sb-testing-contrib
;; We create TEST-PASSED from a shell script if tests passed. But
;; since the shell script only `touch'es it, we can actually create
;; it ahead of time -- as long as we're certain that tests truly
;; passed, hence the check for SOFT.
(when soft
(with-open-file (s #p"SYS:CONTRIB;SB-INTROSPECT;TEST-PASSED"
:direction :output)
(dolist (pend pending)
(format s "Expected failure: ~A~%" pend))))
(warn "ignoring expected failures in test-op"))
(unless soft
(error "test-op failed with unexpected failures"))))))
:components ((:file "introspect")))

227
contrib/sb-introspect/test-driver.lisp
View file

@ -8,16 +8,11 @@
;;;; files for more information.
(defpackage :sb-introspect-test
(:use "SB-INTROSPECT" "CL" "SB-RT"))
(:import-from #:test-util #:deftest)
(:use "SB-INTROSPECT" "CL"))
(in-package :sb-introspect-test)
(defmacro deftest* ((name &key fails-on) form &rest results)
`(progn
(when (sb-impl::featurep ',fails-on)
(pushnew ',name sb-rt::*expected-failures*))
(deftest ,name ,form ,@results)))
;; When running the tests which query for a function type, sb-interpreter
;; can return an answer if there were type declarations for the arguments,
;; except that return type is always unknown. The compiler returns a
@ -48,10 +43,14 @@
(deftest macro-lambda-list.1
(equal (function-lambda-list (defmacro macro-lambda-list.1-m (x b)
`(x b)))
`(,x ,b)))
'(x b))
t)
(defmacro interpret (form)
`(let ((sb-ext:*evaluator-mode* :interpret))
(eval ',form)))
#+sb-eval
(deftest macro-lambda-list.2
(equal (function-lambda-list (interpret (defmacro macro-lambda-list.2-m (x)
@ -61,26 +60,26 @@
(deftest macro-lambda-list.3
(equal (function-lambda-list (defmacro macro-lambda-list.1-m (x &optional (b "abc"))
`(x b)))
`(,x ,b)))
'(x &optional (b "abc")))
t)
(deftest macro-lambda-list.4
(equal (function-lambda-list (defmacro macro-lambda-list.1-m (x &key (b "abc"))
`(x b)))
`(,x ,b)))
'(x &key (b "abc")))
t)
(deftest definition-source.1
(values (consp (find-definition-sources-by-name 'vectorp :vop))
(consp (find-definition-sources-by-name 'check-type :macro)))
t t)
(test-util:with-test (:name definition-source.1 :skipped-on :no-source-locs)
(assert (consp (find-definition-sources-by-name 'vectorp :vop)))
(assert (consp (find-definition-sources-by-name 'check-type :macro))))
(deftest definition-source-plist.1
(let* ((source (find-definition-source #'cl-user::one))
(plist (definition-source-plist source))
(pathname (definition-source-pathname source)))
(values (equalp pathname #p"SYS:CONTRIB;SB-INTROSPECT;TEST.LISP.NEWEST")
;; the full pathname isn't important
(values (equalp (pathname-name pathname) "TEST")
(= (definition-source-file-write-date source)
(file-write-date pathname))
(or (equal (getf plist :test-outer)
@ -88,18 +87,13 @@
plist)))
t t t)
;; Not sure why this fails when interpreted, and don't really care too much.
;; The behavior seems right to me anyway.
#.(if (eq sb-ext:*evaluator-mode* :compile)
'(deftest definition-source-plist.2
;;; The behavior of :SOURCE-PLIST on nested WITH-COMPILATION-UNIT
;;; is to append. This is documented in source/compiler/main
(test-util:with-test (:name :definition-source-plist.2)
(let ((plist (definition-source-plist
(find-definition-source #'cl-user::four))))
(values (or (equal (getf plist :test-outer) "OUT")
plist)
(or (equal (getf plist :test-inner) "IN")
plist)))
t t)
(values))
(assert (equal (getf plist :test-outer) "OUT"))
(assert (equal (getf plist :test-inner) "IN"))))
(defun matchp (object form-number)
(let ((ds (sb-introspect:find-definition-source object)))
@ -125,33 +119,26 @@
(matchp #'cl-user::one 2)
t)
(deftest find-source-stuff.3
(matchp-name :generic-function 'cl-user::two 3)
t)
(test-util:with-test (:name find-source-stuff.3 :skipped-on :no-source-locs)
(assert (matchp-name :generic-function 'cl-user::two 3)))
(deftest find-source-stuff.4
(matchp (car (sb-mop:generic-function-methods #'cl-user::two)) 4)
t)
(test-util:with-test (:name find-source-stuff.4 :skipped-on :no-source-locs)
(assert (matchp (car (sb-mop:generic-function-methods #'cl-user::two)) 4)))
(deftest find-source-stuff.5
(matchp-name :variable 'cl-user::*a* 8)
t)
(test-util:with-test (:name find-source-stuff.5 :skipped-on :no-source-locs)
(assert (matchp-name :variable 'cl-user::*a* 8)))
(deftest find-source-stuff.6
(matchp-name :variable 'cl-user::*b* 9)
t)
(test-util:with-test (:name find-source-stuff.6 :skipped-on :no-source-locs)
(assert (matchp-name :variable 'cl-user::*b* 9)))
(deftest find-source-stuff.7
(matchp-name :class 'cl-user::a 10)
t)
(test-util:with-test (:name find-source-stuff.7 :skipped-on :no-source-locs)
(assert (matchp-name :class 'cl-user::a 10)))
(deftest find-source-stuff.8
(matchp-name :condition 'cl-user::b 11)
t)
(test-util:with-test (:name find-source-stuff.8 :skipped-on :no-source-locs)
(assert (matchp-name :condition 'cl-user::b 11)))
(deftest find-source-stuff.9
(matchp-name :structure 'cl-user::c 12)
t)
(test-util:with-test (:name find-source-stuff.9 :skipped-on :no-source-locs)
(assert (matchp-name :structure 'cl-user::c 12)))
(deftest find-source-stuff.10
(matchp-name :function 'cl-user::make-c 12)
@ -161,9 +148,8 @@
(matchp-name :function 'cl-user::c-e 12)
t)
(deftest find-source-stuff.12
(matchp-name :structure 'cl-user::d 13)
t)
(test-util:with-test (:name find-source-stuff.12 :skipped-on :no-source-locs)
(assert (matchp-name :structure 'cl-user::d 13)))
(deftest find-source-stuff.13
(matchp-name :function 'cl-user::make-d 13)
@ -173,21 +159,17 @@
(matchp-name :function 'cl-user::d-e 13)
t)
(deftest find-source-stuff.15
(matchp-name :package 'cl-user::e 14)
t)
(test-util:with-test (:name find-source-stuff.15 :skipped-on :no-source-locs)
(assert (matchp-name :package 'cl-user::e 14)))
(deftest find-source-stuff.16
(matchp-name :symbol-macro 'cl-user::f 15)
t)
(test-util:with-test (:name find-source-stuff.16 :skipped-on :no-source-locs)
(assert (matchp-name :symbol-macro 'cl-user::f 15)))
(deftest find-source-stuff.17
(matchp-name :type 'cl-user::g 16)
t)
(test-util:with-test (:name find-source-stuff.17 :skipped-on :no-source-locs)
(assert (matchp-name :type 'cl-user::g 16)))
(deftest find-source-stuff.18
(matchp-name :constant 'cl-user::+h+ 17)
t)
(test-util:with-test (:name find-source-stuff.18 :skipped-on :no-source-locs)
(assert (matchp-name :constant 'cl-user::+h+ 17)))
(deftest find-source-stuff.19
(matchp-length :method 'cl-user::j 2)
@ -209,18 +191,16 @@
(matchp-name :function '(setf cl-user::o) 23)
t)
(deftest find-source-stuff.24
(matchp-name :method '(setf cl-user::p) 24)
t)
(test-util:with-test (:name find-source-stuff.24 :skipped-on :no-source-locs)
(assert (matchp-name :method '(setf cl-user::p) 24)))
(deftest find-source-stuff.25
(matchp-name :macro 'cl-user::q 25)
t)
(deftest find-source-stuff.26
(matchp-name :method-combination 'cl-user::r 26)
t)
(test-util:with-test (:name find-source-stuff.26 :skipped-on :no-source-locs)
(assert (matchp-name :method-combination 'cl-user::r 26)))
(deftest find-source-stuff.27
@ -250,14 +230,13 @@
(matchp-name :function 'cl-user::compile-time-too-fun 28)
t)
(load "load-test.lisp")
(load "../contrib/sb-introspect/load-test.lisp")
(deftest find-source-stuff.32
(matchp-name :function 'cl-user::loaded-as-source-fun 3)
t)
(deftest find-source-stuff.33
(matchp-name :variable 'cl-user::**global** 29)
t)
(test-util:with-test (:name find-source-stuff.33 :skipped-on :no-source-locs)
(assert (matchp-name :variable 'cl-user::**global** 29)))
;;; Check wrt. interplay of generic functions and their methods.
@ -384,28 +363,13 @@
(tai 42s0 :immediate nil)
t)
;;; -- It appears that this test can also fail due to systematic issues
;;; (possibly with the C compiler used) which we cannot detect based on
;;; *features*. Until this issue has been fixed, I am marking this test
;;; as failing on Windows to allow installation of the contrib on
;;; affected builds, even if the underlying issue is (possibly?) not even
;;; strictly related to windows. C.f. lp1057631. --DFL
;;;
(deftest* (allocation-information.4
(test-util:with-test (:name :allocation-information.4
;; Ignored as per the comment above, even though it seems
;; unlikely that this is the right condition.
:fails-on (or :win32 :ppc64 (and :sparc :gencgc)))
#+gencgc
:fails-on (or :ppc64 (and :sparc :gencgc)))
(tai (make-list 1) :heap
`(:space :dynamic :boxed t :large nil)
:ignore (list :page :pinned :generation :write-protected))
#-gencgc
(tai :cons :heap
;; FIXME: Figure out what's the right cheney-result. SPARC at least
;; has exhibited both :READ-ONLY and :DYNAMIC, which seems wrong.
'()
:ignore '(:space))
t)
:ignore (list :page :pinned :generation :write-protected)))
(setq sb-ext:*evaluator-mode* :compile)
(sb-ext:defglobal *large-obj* nil)
@ -440,30 +404,39 @@
(= (getf props :page) page)
(= (getf props :generation) gen)
(eq (getf props :boxed :missing) boxedp))))
(defun alloc-large-code ()
;; large objets have to have to be at least 4 GC pages
(let ((bytes (* 4 sb-vm:gencgc-page-bytes)))
;; For 32-bit in order to force allocation into a large-object page, the currently
;; open code region has to be closed. Otherwise the allocation might fit in the region.
#-64-bit
(sb-alien:alien-funcall
(sb-alien:extern-alien "gc_close_region"
(function sb-alien:void sb-alien:unsigned sb-alien:unsigned))
(+ (* 3 3 sb-vm:n-word-bytes) ; KLUDGE: a region is 3 words, and code_region
; is the third in the array of regions
(sb-sys:find-dynamic-foreign-symbol-address "gc_alloc_region"))
7) ; KLUDGE: PAGE_TYPE_CODE
;; A legal code object needs >= 4 boxed words. Let's use 8
(let ((object (sb-c:allocate-code-object nil 8 (- bytes (* 8 sb-vm:n-word-bytes)))))
(setq *large-obj* object)
;; assert that it's large, otherwise the entire test is bogus
(let ((props (nth-value 1 (allocation-information object))))
(assert (getf props :large)))
object)))
(compile 'alloc-large-code)
#+gencgc
(deftest* (allocation-information.6 :fails-on :sbcl)
(deftest allocation-information.6
;; Remember, all tests run after all toplevel forms have executed,
;; so if this were (DEFGLOBAL *LARGE-CODE* ... ) or something,
;; the garbage collection explicitly requested for ALLOCATION-INFORMATION.5
;; would have already happened, and thus affected this test as well.
;; So we need to make the objects within each test,
;; while avoiding use of lexical vars that would cause conservative pinning.
(multiple-value-bind (page gen)
(page-and-gen
(setq *large-obj*
;; To get a large-object page, a code object has to exceed
;; LARGE_OBJECT_SIZE and not fit within an open region.
;; (This is a minor bug, because one should be able to
;; create regions as large as desired without affecting
;; determination of whether an object is large.
;; Practically it means is that a small object region
;; is limited to at most 3 pages)
;; 32-bit machines use 64K for code allocation regions,
;; but the large object size can be as small as 16K.
;; 16K might fit in the free space of an open region,
;; and by accident would not go on a large object page.
(sb-c:allocate-code-object nil 0 0
(max (* 4 sb-vm:gencgc-page-bytes) #-64-bit 65536))))
(multiple-value-bind (page gen) (page-and-gen (alloc-large-code))
(declare (ignorable gen))
(declare (notinline format))
(format (make-string-output-stream) "~%")
(loop for i from 1 to sb-vm:+highest-normal-generation+
@ -479,7 +452,7 @@
(deftest allocation-information.7
(locally
(declare (notinline format))
;; Create a bignum using 4 GC cards
;; Create a bignum using 4 GC pages
(setq *b* (ash 1 (* sb-vm:gencgc-page-bytes sb-vm:n-byte-bits 4)))
(setq *negb* (- *b*))
(and (let ((props (get-small-bignum-allocation-information)))
@ -552,10 +525,6 @@
(sb-kernel:type= (sb-kernel:values-specifier-type typespec1)
(sb-kernel:values-specifier-type typespec2))))
(defmacro interpret (form)
`(let ((sb-ext:*evaluator-mode* :interpret))
(eval ',form)))
;; Functions
(declaim (ftype (function (integer &optional string) string) moon))
@ -735,7 +704,7 @@
(predicate (find-definition-source #'cl-user::three-p)))
(values (and (equalp copier accessor)
(equalp copier predicate))
(equal "TEST.LISP.NEWEST"
(equal "test.lisp"
(file-namestring (definition-source-pathname copier)))
(equal '(5)
(definition-source-form-path copier))))
@ -749,7 +718,7 @@
(predicate (car (find-definition-sources-by-name 'cl-user::three-p :function))))
(values (and (equalp copier accessor)
(equalp copier predicate))
(equal "TEST.LISP.NEWEST"
(equal "test.lisp"
(file-namestring (definition-source-pathname copier)))
(equal '(5)
(definition-source-form-path copier))))
@ -757,25 +726,20 @@
t
t)
(deftest alien-type.1
(matchp-name :alien-type 'cl-user::test-alien-type 30)
t)
(test-util:with-test (:name alien-type.1 :skipped-on :no-source-locs)
(assert (matchp-name :alien-type 'cl-user::test-alien-type 30)))
(deftest alien-type.2
(matchp-name :alien-type 'cl-user::test-alien-struct 31)
t)
(test-util:with-test (:name alien-type.2 :skipped-on :no-source-locs)
(assert (matchp-name :alien-type 'cl-user::test-alien-struct 31)))
(deftest alien-variable
(matchp-name :variable 'cl-user::test-alien-var 32)
t)
(test-util:with-test (:name alien-variable :skipped-on :no-source-locs)
(assert (matchp-name :variable 'cl-user::test-alien-var 32)))
(deftest condition-slot-reader
(matchp-name :method 'cl-user::condition-slot-reader 33)
t)
(test-util:with-test (:name condition-slot-reader :skipped-on :no-source-locs)
(matchp-name :method 'cl-user::condition-slot-reader 33))
(deftest condition-slot-writer
(matchp-name :method 'cl-user::condition-slot-writer 33)
t)
(test-util:with-test (:name condition-slot-writer :skipped-on :no-source-locs)
(matchp-name :method 'cl-user::condition-slot-writer 33))
(deftest function-with-a-local-function
(sb-introspect:definition-source-form-number
@ -802,9 +766,10 @@
(deftest map-root-closure-unnamed
(count-pointees (funcall (compile nil `(lambda (x) (lambda () x))) t) nil)
2)
;;; (SYMBOL-FUNCTION 'AND) is a named closure over 1 value.
;;; The closed-over value is AND, and the name of the closure is (:MACRO AND).
(deftest map-root-closure-named (count-pointees (symbol-function 'and) nil) 3)
;;; (SYMBOL-FUNCTION 'IF) is a named closure over 1 value.
;;; The closed-over value is (:SPECIAL IF), and the name of the closure is
;;; identical, but it also has a docstring.
(deftest map-root-closure-named (count-pointees (symbol-function 'if) nil) 3)
;;; GFs point to their layout, implementation function, and slot vector.
;;; There's also a hash-code which is stored is one of two different ways.

3
contrib/sb-introspect/xref-test-data.lisp
View file

@ -8,7 +8,8 @@
;;;; files for more information.
(defpackage :sb-introspect-test/xref
(:use "SB-INTROSPECT" "CL" "SB-RT"))
(:import-from #:test-util #:deftest)
(:use "SB-INTROSPECT" "CL"))
(in-package :sb-introspect-test/xref)

26
contrib/sb-md5/md5-tests.lisp
View file

@ -1,5 +1,6 @@
(defpackage #:sb-md5-tests
(:use #:sb-md5 #:cl #:sb-rt))
(:import-from #:test-util #:deftest)
(:use #:sb-md5 #:cl))
(in-package #:sb-md5-tests)
(defun byte-array-to-hex-string (bytevec)
@ -131,22 +132,13 @@
("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "a0d1395c7fb36247bfe2d49376d9d133")
("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "ab75504250558b788f99d1ebd219abf2"))))
(deftest sb-md5.md5sum-file.0
(let ((file
(loop with ret
for filename = (format nil "md5-test-~6,'0D" (random 100000))
do (with-open-file (stream filename :direction :output
:if-exists nil
:if-does-not-exist :create)
(when stream
(setf ret stream)))
when ret return ret)))
(unwind-protect
(string= (format nil "~(~{~2,'0X~}~)"
(coerce (md5sum-file file) 'list))
"d41d8cd98f00b204e9800998ecf8427e")
(delete-file file)))
t)
;; This is barely a test. It's md5summing an empty file. Why?
(test-util:with-test (:name :sb-md5.md5sum-file.0)
(test-util:with-scratch-file (name)
(with-open-file (stream name :direction :output :if-does-not-exist :create))
(let ((answer (md5sum-file name)))
(assert (string= (format nil "~(~{~2,'0X~}~)" (coerce answer 'list))
"d41d8cd98f00b204e9800998ecf8427e")))))
(deftest sb-md5.md5sum-sequence.error.0
(handler-case (md5sum-sequence "foo")

1
contrib/sb-md5/md5.lisp
View file

@ -69,6 +69,7 @@
(in-package sb-md5)
(eval-when (:compile-toplevel :load-toplevel :execute)
(sb-ext:restrict-compiler-policy 'space 1) ; lp#1988683
(setf (sb-int:system-package-p *package*) t))
#+cmu

16
contrib/sb-md5/sb-md5.asd
View file

@ -7,7 +7,6 @@
;;;; facility.
;;;;
#-(or sb-testing-contrib sb-building-contrib)
(error "Can't build contribs with ASDF")
(defsystem "sb-md5"
@ -21,17 +20,4 @@
(and :lispworks (not :lispworks4))
:ccl :allegro)
"flexi-streams")
#+sb-building-contrib :pathname
#+sb-building-contrib #p"SYS:CONTRIB;SB-MD5;"
:components ((:file "md5"))
:perform (load-op :after (o c) (provide 'sb-md5))
:in-order-to ((test-op (test-op "sb-md5/tests"))))
(defsystem "sb-md5/tests"
:depends-on ("sb-md5" "sb-rt")
:version "2.0.4"
:components ((:file "md5-tests")))
(defmethod perform ((o test-op) (c (eql (find-system "sb-md5/tests"))))
(or (funcall (intern "DO-TESTS" (find-package "SB-RT")))
(error "test-op failed")))
:components ((:file "md5")))

29
contrib/sb-mpfr/mpfr.lisp
View file

@ -198,10 +198,11 @@
(defun %load-mpfr ()
(or (some #'try-load-shared-object
#-(or win32 darwin) '("libmpfr.so" "libmpfr.so.4")
#+darwin '("libmpfr.dylib" "libmpfr.4.dylib")
#-(or win32 darwin) '("libmpfr.so" "libmpfr.so.4" "libmpfr.so.6")
#+darwin '("libmpfr.dylib" "libmpfr.4.dylib" "libmpfr.6.dylib")
#+win32 '("mpfr.dll"))
(warn "MPFR not loaded.")))
(warn "MPFR was not loaded. This is likely because the shared library ~
was not found.")))
(defun load-mpfr (&key (persistently t))
(setf *mpfr-version* nil
@ -217,8 +218,8 @@
(alien-funcall (extern-alien "mpfr_get_version"
(function c-string)))))
(cond ((null *mpfr-version*))
((string<= *mpfr-version* "3.1")
(warn "SB-MPFR requires at least MPFR version 3.1")
((string<= *mpfr-version* "4.0.0")
(warn "SB-MPFR requires at least MPFR version 4.0.0")
(setf success nil))
(t
(setf +mpfr-precision+
@ -1730,7 +1731,7 @@
,@defines))))
(define-onearg-no-rnd-mpfr-funs
((ceil mpfr_ceil)
((ceiling mpfr_ceil)
(floor mpfr_floor)
(round mpfr_round)
(truncate mpfr_trunc)))
@ -1783,6 +1784,19 @@
(x (* (struct mpfrfloat)))
(rnd mpfr_rnd_enum))
(declaim (inline mpfr_get_q))
(define-alien-routine mpfr_get_q void
(rop (* (struct sb-gmp::gmprat)))
(op (* (struct mpfrfloat))))
(defun mpfrfloat->rational (f)
"Convert a raw MPFRFLOAT F into a CL:RATIONAL."
(with-alien ((q (struct sb-gmp::gmprat)))
(sb-gmp::__gmpq_init (addr q))
(mpfr_get_q (addr q) f)
(prog1 (sb-gmp::mpq->rational q)
(sb-gmp::__gmpq_clear (addr q)))))
(defun coerce (x type &optional (round *mpfr-rnd*))
(cond
((typep x 'mpfr-float)
@ -1792,6 +1806,9 @@
(mpfr_get_flt x-ref round))
(double-float
(mpfr_get_d x-ref round))
(rational
;; this will always be exact
(mpfrfloat->rational x-ref))
(mpfr-float
(let ((result (make-mpfr-float)))
(mpfr_set (mpfr-float-ref result) x-ref round)

21
contrib/sb-mpfr/sb-mpfr.asd
View file

@ -1,4 +1,3 @@
#-(or sb-testing-contrib sb-building-contrib)
(error "Can't build contribs with ASDF")
(defsystem "sb-mpfr"
@ -7,22 +6,4 @@
:description "bignum float calculations for SBCL using the MPFR library"
:serial t
:depends-on ("sb-gmp")
:components ((:file "mpfr"))
:perform (load-op :after (o c) (provide 'sb-mpfr))
:in-order-to ((test-op (test-op "sb-mpfr/tests"))))
(defsystem "sb-mpfr/tests"
:depends-on ("sb-rt" "sb-mpfr")
:components ((:file "tests")))
(defmethod perform ((o test-op) (c (eql (find-system "sb-mpfr/tests"))))
(if (not (member :sb-mpfr *features*))
(warn "unable to test sb-mpfr: libmpfr unavailable")
(multiple-value-bind (soft strict pending)
(funcall (intern "DO-TESTS" (find-package "SB-RT")))
(declare (ignorable pending))
(fresh-line)
(unless strict
(warn "ignoring expected failures in sb-mpfr-tests"))
(unless soft
(error "sb-mpfr-tests failed with unexpected failures")))))
:components ((:file "mpfr")))

36
contrib/sb-mpfr/tests.lisp
View file

@ -1,7 +1,4 @@
(defpackage "SB-MPFR-TESTS"
(:use "COMMON-LISP" "SB-RT"))
(in-package "SB-MPFR-TESTS")
;;; FIXME: how are these testing anything???
(defun sample ()
(let ((sb-mpfr:*mpfr-rnd* :MPFR_RNDD))
@ -26,3 +23,34 @@
(defun sample-pi ()
(sb-mpfr:set-precision 400)
(sb-mpfr:const-pi))
;;; Test that (sb-mpfr:coerce * 'rational) works
(defvar *roundtrip-precision* 100)
(defun rational-roundtrip (rat)
(sb-mpfr:with-precision *roundtrip-precision*
(let* ((f (sb-mpfr:coerce rat 'sb-mpfr:mpfr-float))
(frat (sb-mpfr:coerce f 'rational)))
frat)))
(macrolet ((%write-out-idempotence-tests (&rest rationals)
`(progn
,@(loop :for rat :in rationals
:collect
`(test-util:with-test
(:name ,(sb-int:keywordicate (format nil "TEST-RATIONALIZE-~A" rat)))
(assert (<= (abs (- ,rat (rational-roundtrip ,rat)))
(expt 2 (- *roundtrip-precision*)))))))))
(%write-out-idempotence-tests
1/2
1/4
1/8
1/16
(+ 1/2 1/4 1/8)
355/113
pi
(exp 1)
(sqrt 2)))

8
contrib/sb-posix/interface.lisp
View file

@ -360,7 +360,7 @@ not supported."
;; Dead threads aren't pruned from *ALL-THREADS* until the Pthread join.
;; Do that now so that the forked process has only the main thread
;; in *ALL-THREADS* and nothing in *JOINABLE-THREADS*.
(sb-thread::join-pthread-joinables #'identity)
(sb-thread::%dispose-thread-structs)
;; Threads are added to ALL-THREADS before they have an OS thread,
;; but newborn threads are not exposed in SB-THREAD:LIST-ALL-THREADS.
;; So we need to go lower-level to sense whether any exist.
@ -547,8 +547,8 @@ not supported."
(passwd :initarg :passwd :accessor group-passwd)
(gid :initarg :gid :accessor group-gid)))
(defmacro define-obj-call (name arg type conv)
#-(or win32 android)
(macrolet ((define-obj-call (name arg type conv)
;; FIXME: this isn't the documented way of doing this, surely?
(let ((lisp-name (intern (string-upcase name) :sb-posix)))
`(progn
@ -558,7 +558,7 @@ not supported."
(let ((r (alien-funcall (extern-alien ,name ,type) ,arg)))
(if (null-alien r)
nil
(,conv r)))))))
(,conv r))))))))
(define-obj-call "getpwnam" login-name (function (* alien-passwd) (c-string :not-null t))
alien-to-passwd)
@ -568,7 +568,7 @@ not supported."
alien-to-group)
(define-obj-call "getgrgid" gid (function (* alien-group) gid-t)
alien-to-group)
) ; end MACROLET
#-win32
(define-protocol-class timeval alien-timeval ()

3
contrib/sb-posix/libc-tests.lisp
View file

@ -1,5 +1,4 @@
(defpackage #:sb-libc-tests (:use #:cl #:sb-rt))
(in-package "SB-LIBC-TESTS")
(in-package "SB-POSIX-TESTS")
(defparameter *tests* ; unicode strings (by default unless #-sb-unicode)
#("1.20203" "3.4400" "3240.2205" "10088.92" "12.3" "1000000000e-2"

90
contrib/sb-posix/posix-tests.lisp
View file

@ -1,19 +1,16 @@
(defpackage "SB-POSIX-TESTS"
(:use "COMMON-LISP" "SB-RT"))
(:import-from #:test-util #:deftest)
(:use "COMMON-LISP"))
(in-package "SB-POSIX-TESTS")
(defvar *test-directory*
(ensure-directories-exist
(merge-pathnames (make-pathname :directory '(:relative "test-output"))
(make-pathname :directory
(pathname-directory *load-truename*)))))
(defvar *test-directory* test-util:*test-directory*)
(defvar *current-directory* *default-pathname-defaults*)
(defvar *this-file* *load-truename*)
(eval-when (:compile-toplevel :load-toplevel)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defconstant +mode-rwx-all+
(logior sb-posix::s-irusr sb-posix::s-iwusr sb-posix::s-ixusr
#-win32
@ -158,15 +155,12 @@
(sb-posix:syscall-errno c))))
#.sb-posix::enoent)
(deftest rmdir.error.2
(handler-case
(sb-posix:rmdir *this-file*)
(sb-posix:syscall-error (c)
(sb-posix:syscall-errno c)))
#-win32
#.sb-posix::enotdir
#+win32
#.sb-posix::einval)
(test-util:with-test (:name :rmdir.error.2)
(let ((err (handler-case (sb-posix:rmdir *this-file*)
(sb-posix:syscall-error (c) (sb-posix:syscall-errno c)))))
(assert #-unix (eql err #.sb-posix:einval)
;; non-writable parent dir may return EACCES instead of ENOTDIR
#+unix (member err `(,sb-posix:enotdir ,sb-posix:eacces)))))
(deftest rmdir.error.3
(handler-case
@ -174,17 +168,11 @@
(sb-posix:syscall-error (c)
(typep
(sb-posix:syscall-errno c)
'(member
#+(or darwin openbsd)
#.sb-posix:eisdir
#+win32
#.sb-posix::eacces
#+win32
#.sb-posix::enotempty
#+sunos
#.sb-posix::einval
#-(or darwin openbsd win32 sunos)
#.sb-posix::ebusy)))) t)
`(member #+(or darwin openbsd freebsd) ,sb-posix:eisdir
#+win32 ,sb-posix::eacces #+win32 ,sb-posix::enotempty
#+sunos ,sb-posix::einval
#-(or darwin openbsd freebsd win32 sunos) ,sb-posix::ebusy))))
t)
(deftest rmdir.error.4
(let* ((dir (ensure-directories-exist
@ -390,6 +378,7 @@
(let ((file (format nil "~A/[foo].txt" (namestring *test-directory*))))
;; creat() with a string as argument
(let ((fd (sb-posix:creat file sb-posix:s-iwrite)))
(declare (ignorable fd))
#+win32
(sb-posix:close fd))
;; if this test fails, it will probably be with
@ -435,7 +424,7 @@
:type sb-posix:f-wrlck
:whence sb-posix:seek-set
:start 0 :len 10))
(pathname "fcntl.flock.1")
(pathname (merge-pathnames #P"fcntl.flock.1" *test-directory*))
kid-status)
(catch 'test
(with-open-file (f pathname :direction :output)
@ -470,7 +459,7 @@
:type sb-posix:f-wrlck
:whence sb-posix:seek-set
:start 0 :len 10))
(pathname "fcntl.flock.2")
(pathname (merge-pathnames #P"fcntl.flock.2" *test-directory*))
kid-status)
(catch 'test
(with-open-file (f pathname :direction :output)
@ -534,32 +523,30 @@
t)
#-darwin
(deftest readdir/dirent-name
(let ((dir (sb-posix:opendir *current-directory*)))
(unwind-protect
(equal (sort (loop for entry = (sb-posix:readdir dir)
(test-util:with-test (:name :readdir/dirent-name)
(let* ((dir (sb-posix:opendir *current-directory*))
(posix-readdir (loop for entry = (sb-posix:readdir dir)
until (sb-alien:null-alien entry)
collect (sb-posix:dirent-name entry))
#'string<)
(sort (append '("." "..")
collect (sb-posix:dirent-name entry)))
(cl-directory
(append '("." "..")
(mapcar (lambda (p)
(let ((string (enough-namestring p *current-directory*)))
(if (pathname-name p)
string
(subseq string 0 (1- (length string))))))
(directory (make-pathname
:name :wild
(directory (make-pathname :name :wild
:type :wild
:defaults *current-directory*)
:resolve-symlinks nil)))
#'string<))
(sb-posix:closedir dir)))
t)
:resolve-symlinks nil)))))
(sb-posix:closedir dir)
(assert (equal (sort posix-readdir #'string<)
(sort cl-directory #'string<)))))
(deftest write.1
(progn
(let ((fd (sb-posix:open (merge-pathnames "write-test.txt" *test-directory*)
(test-util:with-test (:name :write.1)
(multiple-value-bind (n str)
(test-util:with-scratch-file (tmpname)
(let ((fd (sb-posix:open tmpname
(logior sb-posix:o-creat sb-posix:o-wronly)
(logior sb-posix:s-irusr sb-posix:s-iwusr)))
(retval nil))
@ -568,10 +555,8 @@
(setf retval (sb-posix:write fd (sb-sys:vector-sap buf) 3)))
(sb-posix:close fd))
(with-open-file (inf (merge-pathnames "write-test.txt" *test-directory*)
:direction :input)
(values retval (read-line inf)))))
3 "foo")
(with-open-file (inf tmpname) (values retval (read-line inf)))))
(assert (and (eql n 3) (equal str "foo")))))
#-(or android win32)
(deftest pwent.1
@ -590,7 +575,7 @@
;; make sure that we get something sensible, not an error
(handler-case (progn (sb-posix:getpwnam "almost-certainly-does-not-exist")
nil)
(t (cond) t))
(t (cond) (declare (ignore cond)) t))
nil)
#-(or android win32)
@ -613,7 +598,7 @@
;; make sure that we get something sensible, not an error
(handler-case (progn (sb-posix:getgrnam "almost-certainly-does-not-exist")
nil)
(t (cond) t))
(t (cond) (declare (ignore cond)) t))
nil)
#+nil
@ -700,6 +685,7 @@
#.(concatenate 'string "/" (make-string 255 :initial-element #\a)))
;; The error tests are in the order of exposition from SUSv3.
#-freebsd
(deftest readlink.error.1
(let* ((subdir-pathname (merge-pathnames
(make-pathname

34
contrib/sb-posix/sb-posix.asd
View file

@ -1,45 +1,13 @@
;;; -*- Lisp -*-
#-(or sb-testing-contrib sb-building-contrib)
(error "Can't build contribs with ASDF")
(defsystem "sb-posix"
:defsystem-depends-on ("sb-grovel")
#+sb-building-contrib :pathname
#+sb-building-contrib #p"SYS:CONTRIB;SB-POSIX;"
:components ((:file "defpackage")
(:file "strtod" :depends-on ("defpackage"))
(:file "designator" :depends-on ("defpackage"))
(:file "macros" :depends-on ("designator"))
(:sb-grovel-constants-file "constants"
:package :sb-posix :depends-on ("defpackage"))
(:file "interface" :depends-on ("constants" "macros" "designator")))
:perform (load-op :after (o c) (provide 'sb-posix))
:in-order-to ((test-op (test-op "sb-posix/tests"))))
(defsystem "sb-posix/tests"
:depends-on ("sb-rt")
#+sb-building-contrib :pathname
#+sb-building-contrib #p"SYS:CONTRIB;SB-POSIX;"
:components ((:file "libc-tests")
(:file "posix-tests"))
:perform
(test-op (o c)
(funcall (intern "DO-TESTS" (find-package "SB-RT")))
(let ((failures (funcall (intern "PENDING-TESTS" "SB-RT")))
(ignored-failures (loop for sym being the symbols of :sb-posix-tests
if (search ".ERROR" (symbol-name sym))
collect sym)))
(cond
((null failures)
t)
((null (set-difference failures ignored-failures))
(warn "~@<some POSIX implementations return incorrect error values for ~
failing calls, but there is legitimate variation between ~
implementations too. If you think the errno ~
from your platform is valid, please contact the sbcl ~
developers; otherwise, please submit a bug report to your ~
kernel distributor~@:>")
t)
(t
(error "non-errno tests failed!"))))))
(:file "interface" :depends-on ("constants" "macros" "designator"))))

5
contrib/sb-queue/sb-queue.asd
View file

@ -9,11 +9,8 @@
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
#-(or sb-testing-contrib sb-building-contrib)
(error "Can't build contribs with ASDF")
(defsystem "sb-queue"
:depends-on ("sb-concurrency")
:components ((:file "package"))
:perform (load-op :after (o c) (provide 'sb-queue))
:perform (test-op (o c) :pass))
:components ((:file "package")))

13
contrib/sb-rotate-byte/sb-rotate-byte.asd
View file

@ -1,12 +1,9 @@
;;; -*- Lisp -*-
#-(or sb-testing-contrib sb-building-contrib)
(error "Can't build contribs with ASDF")
(defsystem "sb-rotate-byte"
:version "0.1"
#+sb-building-contrib :pathname
#+sb-building-contrib #p"SYS:CONTRIB;SB-ROTATE-BYTE;"
:components
((:file "package")
(:file "compiler" :depends-on ("package"))
@ -21,12 +18,4 @@
(:file "riscv-vm" :if-feature :riscv)
(:file "ppc-vm" :if-feature :ppc)
(:file "ppc64-vm" :if-feature :ppc64)))
(:file "rotate-byte" :depends-on ("vm")))
:perform (load-op :after (o c) (provide 'sb-rotate-byte))
:in-order-to ((test-op (test-op "sb-rotate-byte/tests"))))
(defsystem "sb-rotate-byte/tests"
#+sb-building-contrib :pathname
#+sb-building-contrib #p"SYS:CONTRIB;SB-ROTATE-BYTE;"
:depends-on ("sb-rotate-byte")
:components ((:file "rotate-byte-tests")))
(:file "rotate-byte" :depends-on ("vm"))))

9
contrib/sb-rt/sb-rt.asd
View file

@ -1,14 +1,7 @@
;;; -*- Lisp -*-
#-(or sb-testing-contrib sb-building-contrib)
(error "Can't build contribs with ASDF")
(defsystem "sb-rt"
:version "0.1.7" ; our version "0", GCL CVS version "1.7"
#+sb-building-contrib :pathname
#+sb-building-contrib #p"SYS:CONTRIB;SB-RT;"
:components ((:file "rt"))
:perform (load-op :after (o c) (provide 'sb-rt))
:perform (test-op (o c)
;; FIXME: Maybe also import rt-tests.lisp?
t))
:components ((:file "rt")))

8
contrib/sb-simd/CREDITS Normal file
View file

@ -0,0 +1,8 @@
sb-simd was developed by:
Marco Heisig
Bela Pecsek
Tomas Wain
Stas Boukarev
The detailed project history is archived at github.com/marcoheisig/sb-simd

2
contrib/sb-graph/Makefile → contrib/sb-simd/Makefile
View file

@ -1,2 +1,2 @@
SYSTEM=sb-graph
SYSTEM=sb-simd
include ../asdf-module.mk

50
contrib/sb-simd/code/constants.lisp Normal file
View file

@ -0,0 +1,50 @@
(in-package #:sb-simd-internals)
(defconstant most-positive-f32 most-positive-single-float)
(defconstant most-negative-f32 most-negative-single-float)
(defconstant most-positive-f64 most-positive-double-float)
(defconstant most-negative-f64 most-negative-double-float)
(defconstant most-positive-u1 (1- (expt 2 1)))
(defconstant most-positive-u2 (1- (expt 2 2)))
(defconstant most-positive-u4 (1- (expt 2 4)))
(defconstant most-positive-u8 (1- (expt 2 8)))
(defconstant most-positive-u16 (1- (expt 2 16)))
(defconstant most-positive-u32 (1- (expt 2 32)))
(defconstant most-positive-u64 (1- (expt 2 64)))
(defconstant +u8-true+ most-positive-u8)
(defconstant +u16-true+ most-positive-u16)
(defconstant +u32-true+ most-positive-u32)
(defconstant +u64-true+ most-positive-u64)
(defconstant +u8-false+ 0)
(defconstant +u16-false+ 0)
(defconstant +u32-false+ 0)
(defconstant +u64-false+ 0)
(defconstant most-positive-s8 (1- (expt 2 (1- 8))))
(defconstant most-positive-s16 (1- (expt 2 (1- 16))))
(defconstant most-positive-s32 (1- (expt 2 (1- 32))))
(defconstant most-positive-s64 (1- (expt 2 (1- 64))))
(defconstant most-negative-s8 (- (expt 2 (1- 8))))
(defconstant most-negative-s16 (- (expt 2 (1- 16))))
(defconstant most-negative-s32 (- (expt 2 (1- 32))))
(defconstant most-negative-s64 (- (expt 2 (1- 64))))
(defconstant +s8-true+ -1)
(defconstant +s16-true+ -1)
(defconstant +s32-true+ -1)
(defconstant +s64-true+ -1)
(defconstant +s8-false+ 0)
(defconstant +s16-false+ 0)
(defconstant +s32-false+ 0)
(defconstant +s64-false+ 0)
(defconstant +f32-true+ (sb-kernel:make-single-float +s32-true+))
(defconstant +f64-true+ (sb-kernel:make-double-float +s32-true+ +u32-true+))
(defconstant +f32-false+ (sb-kernel:make-single-float +s32-false+))
(defconstant +f64-false+ (sb-kernel:make-double-float +s32-false+ +u32-false+))

72
contrib/sb-simd/code/cpu-identification.lisp Normal file
View file

@ -0,0 +1,72 @@
(in-package #:sb-simd-internals)
#+x86-64
(progn
(defun cpuid (eax &optional (ecx 0))
(declare (type (unsigned-byte 32) eax ecx))
(sb-vm::%cpu-identification eax ecx))
(defun sse-supported-p ()
(and (>= (cpuid 0) 1)
(logbitp 25 (nth-value 3 (cpuid 1)))))
(defun sse2-supported-p ()
(and (>= (cpuid 0) 1)
(logbitp 26 (nth-value 3 (cpuid 1)))))
(defun sse3-supported-p ()
(and (>= (cpuid 0) 1)
(logbitp 0 (nth-value 2 (cpuid 1)))))
(defun ssse3-supported-p ()
(and (>= (cpuid 0) 1)
(logbitp 9 (nth-value 2 (cpuid 1)))))
(defun sse4.1-supported-p ()
(and (>= (cpuid 0) 1)
(logbitp 19 (nth-value 2 (cpuid 1)))))
(defun sse4.2-supported-p ()
(and (>= (cpuid 0) 1)
(logbitp 20 (nth-value 2 (cpuid 1)))))
(defun avx-supported-p ()
(and (>= (cpuid 0) 1)
(logbitp 28 (nth-value 2 (cpuid 1)))))
(defun avx2-supported-p ()
(and (>= (cpuid 0) 7)
(logbitp 5 (nth-value 1 (cpuid 7)))))
(defun fma-supported-p ()
(and (>= (cpuid 0) 1)
(logbitp 12 (nth-value 2 (cpuid 1))))))
#-x86-64
(progn
(defun sse-supported-p ()
nil)
(defun sse2-supported-p ()
nil)
(defun sse3-supported-p ()
nil)
(defun ssse3-supported-p ()
nil)
(defun sse4.1-supported-p ()
nil)
(defun sse4.2-supported-p ()
nil)
(defun avx-supported-p ()
nil)
(defun avx2-supported-p ()
nil)
(defun fma-supported-p ()
nil))

179
contrib/sb-simd/code/define-arefs.lisp Normal file
View file

@ -0,0 +1,179 @@
(in-package #:sb-simd-internals)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Auxiliary Functions and Macros
(declaim (notinline wrong-number-of-subscripts))
(defun wrong-number-of-subscripts (array number-of-subscripts)
(error "Wrong number of subcripts, ~S, for an array of rank ~S."
number-of-subscripts
(array-rank array)))
(declaim (notinline invalid-subscript))
(defun invalid-subscript (subscript array axis limit)
(declare (ignore array))
(error "Invalid array subscript ~S for axis ~S, ~
should be a non-negative integer below ~S."
subscript axis limit))
;; This function doesn't have to be particularly fast, because all index
;; computations where the number of subscripts is known at compile time are
;; expanded by compiler macros and WITH-ROW-MAJOR-SIMD-INDEX. The only way
;; to reach this function is when an array indexing function is supplied as
;; the first argument to APPLY or FUNCALL.
(defun array-row-major-simd-index (array simd-width &rest subscripts)
(let ((rank (array-rank array))
(length (length subscripts)))
(unless (= rank length)
(wrong-number-of-subscripts array length))
(let ((stride 1)
(index 0))
(declare (index stride index))
(loop for axis from (1- rank) downto 0
for subscript = (nth axis subscripts)
for dimension = (array-dimension array axis)
for width = simd-width then 1 do
(unless (<= -1 subscript (- dimension width))
(invalid-subscript subscript array axis (1+ (- dimension width))))
(incf index (* stride subscript))
(setf stride (* stride dimension)))
index)))
(defmacro with-row-major-simd-index
((index array simd-width &rest indices) &body body &environment env)
(check-type index symbol)
(check-type array symbol)
(check-type simd-width (integer 1))
(dolist (index indices)
(check-type index symbol))
(let* ((length (length indices))
(rank-binding `(,(gensym "RANK") (array-rank ,array)))
(rank (first rank-binding))
(dimension-bindings
(loop for axis below length
collect `(,(gensym "DIMENSION") (array-dimension ,array ,axis))))
(dimensions (mapcar #'first dimension-bindings))
(stride-bindings
(loop for axis from (- length 2) downto 0
for old-stride = nil then new-stride
for new-stride = (gensym "STRIDE")
for stride-binding = `(,new-stride ,(nth axis dimensions))
then `(,new-stride (index* ,(nth axis dimensions) ,old-stride))
collect stride-binding))
(strides (reverse (mapcar #'first stride-bindings)))
(index-form
`(index+
,@(loop for stride in strides
for index in indices
collect `(index* ,stride ,index))
,(first (last indices)))))
`(let (,rank-binding)
(unless (= ,rank ,length)
(wrong-number-of-subscripts ,array ,length))
(let (,@dimension-bindings)
(declare (ignorable ,@dimensions))
,@(when (sb-c:policy env (plusp sb-c::insert-array-bounds-checks))
(loop for axis from 0
for dimension in dimensions
for index in indices
for limit = (if (= axis (1- length)) `(- ,dimension ,(1- simd-width)) dimension)
collect `(unless (< -1 ,index ,limit)
(invalid-subscript ,index ,array ,axis ,limit))))
(let* (,@stride-bindings)
(let ((,index ,index-form))
,@body))))))
(defun setf-row-major-aref (v a i)
(setf (row-major-aref a i) v))
(define-compiler-macro setf-row-major-aref (v a i)
(let* ((v-binding `(,(gensym "VALUE") ,v))
(v (first v-binding)))
`(let (,v-binding)
(setf (row-major-aref ,a ,i) ,v))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Array Load and Store Instructions
(macrolet
((define-aref (load-record-name)
(with-accessors ((load load-record-name)
(aref load-record-aref)
(row-major-aref load-record-row-major-aref)
(value-record load-record-value-record)
(vector-record load-record-vector-record))
(find-function-record load-record-name)
(let ((simd-width (value-record-simd-width value-record))
(element-type
(second
(value-record-type vector-record))))
`(progn
(define-inline ,row-major-aref (array index)
(declare (type (array ,element-type) array)
(index index))
(,load array index))
(defun ,aref (array &rest indices)
(declare (type (array ,element-type) array))
(,load
array
(apply #'array-row-major-simd-index array ,simd-width indices)))
(define-compiler-macro ,aref (array &rest indices)
(let* ((index (gensym "INDEX"))
(array-binding `(,(gensym "ARRAY") ,array))
(index-bindings
(loop for index-form in indices
collect `(,(gensym "INDEX") ,index-form)))
(array (first array-binding))
(indices (mapcar #'first index-bindings)))
`(let (,array-binding ,@index-bindings)
(declare (type (array ,',element-type) ,array))
(with-row-major-simd-index (,index ,array ,',simd-width ,@indices)
(,',load ,array ,index)))))))))
(define-setf-aref (store-record-name)
(with-accessors ((store store-record-name)
(aref store-record-aref)
(row-major-aref store-record-row-major-aref)
(value-record store-record-value-record)
(vector-record store-record-vector-record))
(find-function-record store-record-name)
(let ((value-type (value-record-name value-record))
(simd-width (value-record-simd-width value-record))
(element-type
(second
(value-record-type vector-record))))
`(progn
(define-inline (setf ,row-major-aref) (value array index)
(declare (type (array ,element-type) array)
(index index))
(,store (,value-type value) array index))
(defun (setf ,aref) (value array &rest indices)
(declare (type (array ,element-type) array))
(,store
(,value-type value)
array
(apply #'array-row-major-simd-index array ,simd-width indices)))
(define-compiler-macro (setf ,aref) (value array &rest indices)
(let* ((value-binding `(,(gensym "VALUE") ,value))
(array-binding `(,(gensym "ARRAY") ,array))
(index-bindings
(loop for index-form in indices
collect `(,(gensym "INDEX") ,index-form)))
(indices (mapcar #'first index-bindings))
(value (first value-binding))
(array (first array-binding))
(index (gensym "INDEX")))
`(let (,value-binding ,array-binding ,@index-bindings)
(declare (type (array ,',element-type) ,array))
(with-row-major-simd-index (,index ,array ,',simd-width ,@indices)
(,',store (,',value-type ,value) ,array ,index)))))))))
(define-arefs ()
`(progn
,@(loop for load-record in (filter-function-records #'load-record-p)
for name = (load-record-name load-record)
collect `(define-aref ,name))
,@(loop for store-record in (filter-function-records #'store-record-p)
for name = (store-record-name store-record)
collect `(define-setf-aref ,name)))))
(define-arefs))

58
contrib/sb-simd/code/define-associatives.lisp Normal file
View file

@ -0,0 +1,58 @@
(in-package #:sb-simd-internals)
(macrolet
((define-associative (associative-record-name)
(with-accessors ((name associative-record-name)
(binary-operation associative-record-binary-operation)
(identity-element associative-record-identity-element))
(find-function-record associative-record-name)
(with-accessors ((binary-operation instruction-record-name)
(result-records instruction-record-result-records)
(argument-records instruction-record-argument-records)
(associative instruction-record-associative)) binary-operation
(assert associative)
(destructuring-bind ((value-record) (arg1-record arg2-record))
(list result-records argument-records)
(assert (eq value-record arg1-record))
(assert (eq value-record arg2-record))
(let ((type (value-record-name value-record)))
(if (not identity-element)
`(progn
(defun ,name (arg &rest more-args)
(let ((result (,type arg)))
(declare (,type result))
(loop for arg in more-args
do (setf result (,binary-operation result (,type arg))))
result))
(define-compiler-macro ,name (&whole whole &rest args)
(let ((n (length args)))
(case n
(0 whole)
(1 `(,',type ,(first args)))
(otherwise
`(,',binary-operation
(,',name ,@(subseq args 0 (floor n 2)))
(,',name ,@(subseq args (floor n 2)))))))))
`(progn
(defun ,name (&rest args)
(if (null args)
(,type ,identity-element)
(let ((result (,type (first args))))
(declare (,type result))
(loop for arg in (rest args)
do (setf result (,binary-operation result (,type arg))))
result)))
(define-compiler-macro ,name (&rest args)
(let ((n (length args)))
(case n
(0 `(,',type ,,identity-element))
(1 `(,',type ,(first args)))
(otherwise
`(,',binary-operation
(,',name ,@(subseq args 0 (floor n 2)))
(,',name ,@(subseq args (floor n 2)))))))))))))))
(define-associatives ()
`(progn
,@(loop for associative-record in (filter-function-records #'associative-record-p)
collect `(define-associative ,(associative-record-name associative-record))))))
(define-associatives))

47
contrib/sb-simd/code/define-comparisons.lisp Normal file
View file

@ -0,0 +1,47 @@
(in-package #:sb-simd-internals)
(macrolet
((define-comparison (comparision-record-name)
(with-accessors ((name comparison-record-name)
(cmp comparison-record-cmp)
(and comparison-record-and)
(truth comparison-record-truth))
(find-function-record comparision-record-name)
(with-accessors ((cmp instruction-record-name)
(result-records instruction-record-result-records)
(argument-records instruction-record-argument-records)) cmp
(destructuring-bind ((result-record) (argument-record other-argument-record))
(list result-records argument-records)
(assert (eq argument-record other-argument-record))
(let ((and (function-record-name and))
(result-type (value-record-name result-record))
(argument-type (value-record-name argument-record)))
`(progn
(defun ,name (arg &rest more-args)
(if (null more-args)
(progn (,argument-type arg) (,result-type ,truth))
(let* ((a (,argument-type arg))
(b (,argument-type (first more-args)))
(result (,cmp a b)))
(declare (,argument-type a b)
(,result-type result))
(loop for elt in (rest more-args)
do (shiftf a b (,argument-type elt))
do (setf result (,and result (,cmp a b))))
result)))
(define-compiler-macro ,name (arg &rest more-args)
(if (null more-args)
`(progn (,',argument-type ,arg) (,',result-type ,',truth))
(let ((bindings
(loop for arg in (list* arg more-args)
collect
(list (gensym "ARG") (list ',argument-type arg)))))
`(let ,bindings
(,',and ,@(loop for ((a nil) (b nil) . rest) on bindings
collect `(,',cmp ,a ,b)
until (null rest)))))))))))))
(define-comparisons ()
`(progn
,@(loop for comparison-record in (filter-function-records #'comparison-record-p)
collect `(define-comparison ,(comparison-record-name comparison-record))))))
(define-comparisons))

167
contrib/sb-simd/code/define-custom-vops.lisp Normal file
View file

@ -0,0 +1,167 @@
(in-package #:sb-vm)
(macrolet
((define-custom-vop (name &body clauses)
(with-accessors ((name sb-simd-internals:instruction-record-name)
(vop sb-simd-internals:instruction-record-vop)
(argument-records sb-simd-internals:instruction-record-argument-records)
(result-records sb-simd-internals:instruction-record-result-records)
(cost sb-simd-internals:instruction-record-cost)
(encoding sb-simd-internals:instruction-record-encoding))
(sb-simd-internals:find-function-record name)
(assert (eq encoding :custom))
(labels ((find-clauses (key)
(remove key clauses :test-not #'eq :key #'first))
(find-clause (key)
(let ((found (find-clauses key)))
(assert (= 1 (length found)))
(rest (first found)))))
`(sb-c:define-vop (,vop)
(:translate ,vop)
(:policy :fast-safe)
(:arg-types ,@(mapcar #'sb-simd-internals:value-record-primitive-type argument-records))
(:result-types ,@(mapcar #'sb-simd-internals:value-record-primitive-type result-records))
(:args
,@(loop for arg in (find-clause :args)
for argument-record in argument-records
collect `(,@arg :scs ,(sb-simd-internals:value-record-scs argument-record))))
,@(find-clauses :info)
,@(find-clauses :temporary)
(:results
,@(loop for result in (find-clause :results)
for result-record in result-records
collect `(,@result :scs ,(sb-simd-internals:value-record-scs result-record))))
(:generator ,cost ,@(find-clause :generator)))))))
;; SSE
(macrolet ((def (name cmp)
`(define-custom-vop ,name
(:args (a :target tmp) (b))
(:temporary (:sc single-reg :from (:argument 0)) tmp)
(:results (dst))
(:generator
(unless (location= a tmp)
(inst xorps tmp tmp)
(inst movss tmp a))
(inst cmpss ,cmp tmp b)
(inst movq dst tmp)))))
(def sb-simd-sse::two-arg-f32= :eq)
(def sb-simd-sse::two-arg-f32/= :neq)
(def sb-simd-sse::two-arg-f32< :lt)
(def sb-simd-sse::two-arg-f32<= :le)
(def sb-simd-sse::two-arg-f32> :nle)
(def sb-simd-sse::two-arg-f32>= :nlt))
(define-custom-vop sb-simd-sse::f32-from-s64
(:args (src))
(:results (dst))
(:generator
(inst xorps dst dst)
(inst cvtsi2ss dst src)))
(define-custom-vop sb-simd-sse::f32!-from-p128
(:args (src :target dst))
(:temporary (:sc single-sse-reg :from (:argument 0)) tmp)
(:results (dst))
(:generator
(move tmp src)
(inst xorps dst dst)
(inst movss dst tmp)))
;; SSE2
(macrolet ((def (name cmp)
`(define-custom-vop ,name
(:args (a :target tmp) (b))
(:temporary (:sc single-reg :from (:argument 0)) tmp)
(:results (dst))
(:generator
(unless (location= a tmp)
(inst xorpd tmp tmp)
(inst movsd tmp a))
(inst cmpsd ,cmp tmp b)
(inst movq dst tmp)))))
(def sb-simd-sse2::two-arg-f64= :eq)
(def sb-simd-sse2::two-arg-f64/= :neq)
(def sb-simd-sse2::two-arg-f64< :lt)
(def sb-simd-sse2::two-arg-f64<= :le)
(def sb-simd-sse2::two-arg-f64> :nle)
(def sb-simd-sse2::two-arg-f64>= :nlt))
(define-custom-vop sb-simd-sse2::f64-from-s64
(:args (src))
(:results (dst))
(:generator
(inst xorpd dst dst)
(inst cvtsi2sd dst src)))
(define-custom-vop sb-simd-sse2::f64!-from-p128
(:args (src :target tmp))
(:temporary (:sc double-sse-reg :from (:argument 0)) tmp)
(:results (dst))
(:generator
(move tmp src)
(inst xorpd dst dst)
(inst movsd dst tmp)))
;; AVX
(macrolet ((def (name cmp)
`(define-custom-vop ,name
(:args (a :target tmp) (b))
(:temporary (:sc single-reg :from (:argument 0)) tmp)
(:results (dst))
(:generator
(unless (location= a tmp)
(inst vxorps tmp tmp tmp))
(inst vcmpss ,cmp tmp a b)
(inst vmovq dst tmp)))))
(def sb-simd-avx::two-arg-f32= :eq)
(def sb-simd-avx::two-arg-f32/= :neq)
(def sb-simd-avx::two-arg-f32< :lt)
(def sb-simd-avx::two-arg-f32<= :le)
(def sb-simd-avx::two-arg-f32> :nle)
(def sb-simd-avx::two-arg-f32>= :nlt))
(macrolet ((def (name cmp)
`(define-custom-vop ,name
(:args (a :target tmp) (b))
(:temporary (:sc single-reg :from (:argument 0)) tmp)
(:results (dst))
(:generator
(unless (location= a tmp)
(inst vxorpd tmp tmp tmp))
(inst vcmpsd ,cmp tmp a b)
(inst vmovq dst tmp)))))
(def sb-simd-avx::two-arg-f64= :eq)
(def sb-simd-avx::two-arg-f64/= :neq)
(def sb-simd-avx::two-arg-f64< :lt)
(def sb-simd-avx::two-arg-f64<= :le)
(def sb-simd-avx::two-arg-f64> :nle)
(def sb-simd-avx::two-arg-f64>= :nlt))
(define-custom-vop sb-simd-avx::f32-from-s64
(:args (src :to :save))
(:results (dst))
(:generator
(inst vxorpd dst dst dst)
(inst vcvtsi2ss dst dst src)))
(define-custom-vop sb-simd-avx::f64-from-s64
(:args (src :to :save))
(:results (dst))
(:generator
(inst vxorpd dst dst dst)
(inst vcvtsi2sd dst dst src)))
(define-custom-vop sb-simd-avx::f32!-from-p128
(:args (src :to :save))
(:results (dst))
(:generator
(inst vxorps dst dst dst)
(inst movss dst src)))
(define-custom-vop sb-simd-avx::f32!-from-p256
(:args (src :to :save))
(:results (dst))
(:generator
(inst vxorps dst dst dst)
(inst movss dst src)))
(define-custom-vop sb-simd-avx::f64!-from-p128
(:args (src :to :save))
(:results (dst))
(:generator
(inst vxorpd dst dst dst)
(inst movsd dst src)))
(define-custom-vop sb-simd-avx::f64!-from-p256
(:args (src :to :save))
(:results (dst))
(:generator
(inst vxorpd dst dst dst)
(inst movsd dst src))))

1718
contrib/sb-simd/code/define-fake-vops.lisp Normal file
View file

File diff suppressed because it is too large Load diff

28
contrib/sb-simd/code/define-ifs.lisp Normal file
View file

@ -0,0 +1,28 @@
(in-package #:sb-simd-internals)
(macrolet
((define-if (if-record-name)
(with-accessors ((name if-record-name)
(blend if-record-blend))
(find-function-record if-record-name)
(with-accessors ((blend instruction-record-name)
(result-records instruction-record-result-records)
(argument-records instruction-record-argument-records)) blend
(destructuring-bind (a-record b-record mask-record) argument-records
(assert (eq a-record b-record))
(assert (= (value-record-bits a-record)
(value-record-bits mask-record)))
(destructuring-bind (result-record) result-records
(assert (eq result-record a-record))
(let ((value-type (value-record-name a-record))
(mask-type (value-record-name mask-record)))
`(define-inline ,name (mask a b)
(the ,value-type
(,blend (,value-type b)
(,value-type a)
(,mask-type mask))))))))))
(define-ifs ()
`(progn
,@(loop for if-record in (filter-function-records #'if-record-p)
collect `(define-if ,(if-record-name if-record))))))
(define-ifs))

181
contrib/sb-simd/code/define-instruction-vops.lisp Normal file
View file

@ -0,0 +1,181 @@
(in-package #:sb-vm)
(macrolet
((define-instruction-vop (instruction-record-name)
(with-accessors ((name sb-simd-internals:instruction-record-name)
(vop sb-simd-internals:instruction-record-vop)
(mnemonic sb-simd-internals:instruction-record-mnemonic)
(argument-records sb-simd-internals:instruction-record-argument-records)
(result-records sb-simd-internals:instruction-record-result-records)
(cost sb-simd-internals:instruction-record-cost)
(pure sb-simd-internals:instruction-record-pure)
(always-translatable sb-simd-internals:instruction-record-always-translatable)
(associative sb-simd-internals:instruction-record-associative)
(prefix sb-simd-internals:instruction-record-prefix)
(suffix sb-simd-internals:instruction-record-suffix)
(encoding sb-simd-internals:instruction-record-encoding))
(sb-simd-internals:find-function-record instruction-record-name)
(let* ((asyms (sb-simd-internals:prefixed-symbols "A" (length argument-records)))
(rsyms (sb-simd-internals:prefixed-symbols "R" (length result-records)))
(defknown
`(defknown ,vop
(,@(mapcar #'sb-simd-internals:value-record-name argument-records))
(values ,@(mapcar #'sb-simd-internals:value-record-name result-records) &optional)
(,@(when (and always-translatable (not (eq encoding :fake-vop)))
'(always-translatable))
,@(when pure '(foldable flushable movable)))
:overwrite-fndb-silently t))
(arg-types
(mapcar #'sb-simd-internals:value-record-primitive-type argument-records))
(result-types
(mapcar #'sb-simd-internals:value-record-primitive-type result-records))
(args
(loop for asym in asyms
for argument-record in argument-records
when (symbolp (sb-simd-internals:value-record-primitive-type argument-record))
collect `(,asym :scs ,(sb-simd-internals:value-record-scs argument-record))))
(info
(loop for asym in asyms
for argument-record in argument-records
unless (symbolp (sb-simd-internals:value-record-primitive-type argument-record))
collect asym))
(results
(loop for rsym in rsyms
for result-record in result-records
collect `(,rsym :scs ,(sb-simd-internals:value-record-scs result-record)))))
(ecase encoding
((:fake-vop :custom)
`(progn ,defknown))
(:standard
(assert mnemonic)
`(progn
,defknown
(define-vop (,vop)
(:translate ,vop)
(:policy :fast-safe)
(:args ,@args)
(:info ,@info)
(:results ,@results)
(:arg-types ,@arg-types)
(:result-types ,@result-types)
(:generator
,cost
(inst ,mnemonic ,@prefix ,@rsyms ,@asyms ,@suffix)))))
(:move
(assert mnemonic)
(let ((src (first asyms))
(dst (first rsyms)))
`(progn
,defknown
(define-vop (,vop)
(:translate ,vop)
(:policy :fast-safe)
(:args (,@(first args) :target ,dst) ,@(rest args))
(:info ,@info)
(:results ,@results)
(:arg-types ,@arg-types)
(:result-types ,@result-types)
(:generator
,cost
(unless (location= ,dst ,src)
(inst ,mnemonic ,@prefix ,@rsyms ,@asyms ,@suffix)))))))
(:sse
(assert mnemonic)
(let ((x (first asyms))
(y (second asyms))
(rest (rest (rest asyms)))
(r (first rsyms)))
`(progn
,defknown
(define-vop (,vop)
(:translate ,vop)
(:policy :fast-safe)
(:args (,@(first args) :target ,r) ,@(rest args))
(:temporary (:sc ,(first (sb-simd-internals:value-record-scs (first argument-records)))) tmp)
(:info ,@info)
(:results ,@results)
(:arg-types ,@arg-types)
(:result-types ,@result-types)
(:generator
,cost
(cond ((location= ,x ,r)
(inst ,mnemonic ,@prefix ,r ,y ,@rest ,@suffix))
((or (not (tn-p ,y))
(not (location= ,y ,r)))
(move ,r ,x)
(inst ,mnemonic ,@prefix ,r ,y ,@rest ,@suffix))
(t
(move tmp ,x)
(inst ,mnemonic ,@prefix tmp ,y ,@rest ,@suffix)
(move ,r tmp))))))))
(:sse+xmm0
(assert mnemonic)
(let ((x (first asyms))
(y (second asyms))
(z (third asyms))
(r (first rsyms)))
`(progn
,defknown
(define-vop (,vop)
(:translate ,vop)
(:policy :fast-safe)
(:args (,@(first args) :target ,r) ,(second args) (,@(third args) :target xmm0))
(:temporary (:sc ,(first (sb-simd-internals:value-record-scs (first argument-records)))) tmp)
(:temporary (:sc ,(first (sb-simd-internals:value-record-scs (second argument-records)))
:from (:argument 0) :to :result :offset 0) xmm0)
(:info ,@info)
(:results ,@results)
(:arg-types ,@arg-types)
(:result-types ,@result-types)
(:generator
,cost
(move xmm0 ,z)
(cond ((location= ,x ,r)
(inst ,mnemonic ,@prefix ,r ,y xmm0 ,@suffix))
((or (not (tn-p ,y))
(not (location= ,y ,r)))
(move ,r ,x)
(inst ,mnemonic ,@prefix ,r ,y xmm0 ,@suffix))
(t
(move tmp ,x)
(inst ,mnemonic ,@prefix tmp ,y xmm0 ,@suffix)
(move ,r tmp))))))))
(:fma
(assert mnemonic)
(let ((x (first asyms))
(y (second asyms))
(z (third asyms))
(rest (rest (rest (rest asyms))))
(r (first rsyms)))
`(progn
,defknown
(define-vop (,vop)
(:translate ,vop)
(:policy :fast-safe)
(:args (,@(first args) :target ,r) ,@(rest args))
(:temporary (:sc ,(first (sb-simd-internals:value-record-scs (first argument-records)))) tmp)
(:info ,@info)
(:results ,@results)
(:arg-types ,@arg-types)
(:result-types ,@result-types)
(:generator
,cost
(cond ((location= ,x ,r)
(inst ,mnemonic ,@prefix ,r ,y ,z ,@rest ,@suffix))
((and (or (not (tn-p ,y))
(not (location= ,y ,r)))
(or (not (tn-p ,z))
(not (location= ,z ,r))))
(move ,r ,x)
(inst ,mnemonic ,@prefix ,r ,y ,z ,@rest ,@suffix))
(t
(move tmp ,x)
(inst ,mnemonic ,@prefix tmp ,y ,z ,@rest ,@suffix)
(move ,r tmp))))))))))))
(define-instruction-vops ()
`(progn
,@(loop for instruction-record
in (sb-simd-internals:filter-available-function-records
#'sb-simd-internals:instruction-record-p)
collect `(define-instruction-vop ,(sb-simd-internals:instruction-record-name instruction-record))))))
(define-instruction-vops))

30
contrib/sb-simd/code/define-instructions.lisp Normal file
View file

@ -0,0 +1,30 @@
(in-package #:sb-simd-internals)
(macrolet
((define-instruction (name)
(with-accessors ((name instruction-record-name)
(vop instruction-record-vop)
(argument-records instruction-record-argument-records)
(encoding instruction-record-encoding)
(instruction-set instruction-record-instruction-set))
(find-function-record name)
(let ((argument-record-names (mapcar #'record-name argument-records))
(argument-symbols (prefixed-symbols "ARGUMENT-" (length argument-records))))
(if (not (instruction-set-available-p instruction-set))
`(define-missing-instruction ,name
:required-arguments ,argument-symbols)
;; Define the actual instruction as a wrapper around the VOP
;; that attempts to cast all arguments to the correct types.
`(define-inline ,name ,argument-symbols
(let ,(loop for argument-symbol in argument-symbols
for type in (mapcar #'value-record-name argument-records)
collect `(,argument-symbol (,type ,argument-symbol)))
(with-primitive-arguments
,(mapcar #'list argument-symbols argument-record-names)
(,vop ,@argument-symbols))))))))
(define-instructions ()
`(progn
,@(loop for instruction-record in (filter-function-records #'instruction-record-p)
for name = (instruction-record-name instruction-record)
collect `(define-instruction ,name)))))
(define-instructions))

142
contrib/sb-simd/code/define-modify-macros.lisp Normal file
View file

@ -0,0 +1,142 @@
(in-package #:sb-simd)
(define-modify-macro f32-incf (&optional (num 1f0)) two-arg-f32+)
(define-modify-macro f32-decf (&optional (num 1f0)) two-arg-f32-)
(define-modify-macro f64-incf (&optional (num 1d0)) two-arg-f64+)
(define-modify-macro f64-decf (&optional (num 1d0)) two-arg-f64-)
(define-modify-macro u8-incf (&optional (num 1)) two-arg-u8+)
(define-modify-macro u8-decf (&optional (num 1)) two-arg-u8-)
(define-modify-macro u16-incf (&optional (num 1)) two-arg-u16+)
(define-modify-macro u16-decf (&optional (num 1)) two-arg-u16-)
(define-modify-macro u32-incf (&optional (num 1)) two-arg-u32+)
(define-modify-macro u32-decf (&optional (num 1)) two-arg-u32-)
(define-modify-macro u64-incf (&optional (num 1)) two-arg-u64+)
(define-modify-macro u64-decf (&optional (num 1)) two-arg-u64-)
(define-modify-macro s8-incf (&optional (num 1)) two-arg-s8+)
(define-modify-macro s8-decf (&optional (num 1)) two-arg-s8-)
(define-modify-macro s16-incf (&optional (num 1)) two-arg-s16+)
(define-modify-macro s16-decf (&optional (num 1)) two-arg-s16-)
(define-modify-macro s32-incf (&optional (num 1)) two-arg-s32+)
(define-modify-macro s32-decf (&optional (num 1)) two-arg-s32-)
(define-modify-macro s64-incf (&optional (num 1)) two-arg-s64+)
(define-modify-macro s64-decf (&optional (num 1)) two-arg-s64-)
(in-package #:sb-simd-sse)
(define-modify-macro f32-incf (&optional (num 1f0)) two-arg-f32+)
(define-modify-macro f32-decf (&optional (num 1f0)) two-arg-f32-)
(define-modify-macro f32.4-incf (&optional (num 1f0)) two-arg-f32.4+)
(define-modify-macro f32.4-decf (&optional (num 1f0)) two-arg-f32.4-)
(in-package #:sb-simd-sse2)
(define-modify-macro f64-incf (&optional (num 1d0)) two-arg-f64+)
(define-modify-macro f64-decf (&optional (num 1d0)) two-arg-f64-)
(define-modify-macro f64.2-incf (&optional (num 1d0)) two-arg-f64.2+)
(define-modify-macro f64.2-decf (&optional (num 1d0)) two-arg-f64.2-)
(define-modify-macro u8.16-incf (&optional (num 1)) two-arg-u8.16+)
(define-modify-macro u8.16-decf (&optional (num 1)) two-arg-u8.16-)
(define-modify-macro u16.8-incf (&optional (num 1)) two-arg-u16.8+)
(define-modify-macro u16.8-decf (&optional (num 1)) two-arg-u16.8-)
(define-modify-macro u32.4-incf (&optional (num 1)) two-arg-u32.4+)
(define-modify-macro u32.4-decf (&optional (num 1)) two-arg-u32.4-)
(define-modify-macro u64.2-incf (&optional (num 1)) two-arg-u64.2+)
(define-modify-macro u64.2-decf (&optional (num 1)) two-arg-u64.2-)
(define-modify-macro s8.16-incf (&optional (num 1)) two-arg-s8.16+)
(define-modify-macro s8.16-decf (&optional (num 1)) two-arg-s8.16-)
(define-modify-macro s16.8-incf (&optional (num 1)) two-arg-s16.8+)
(define-modify-macro s16.8-decf (&optional (num 1)) two-arg-s16.8-)
(define-modify-macro s32.4-incf (&optional (num 1)) two-arg-s32.4+)
(define-modify-macro s32.4-decf (&optional (num 1)) two-arg-s32.4-)
(define-modify-macro s64.2-incf (&optional (num 1)) two-arg-s64.2+)
(define-modify-macro s64.2-decf (&optional (num 1)) two-arg-s64.2-)
(in-package #:sb-simd-avx)
(define-modify-macro f32-incf (&optional (num 1f0)) two-arg-f32+)
(define-modify-macro f32-decf (&optional (num 1f0)) two-arg-f32-)
(define-modify-macro f64-incf (&optional (num 1d0)) two-arg-f64+)
(define-modify-macro f64-decf (&optional (num 1d0)) two-arg-f64-)
(define-modify-macro f32.4-incf (&optional (num 1f0)) two-arg-f32.4+)
(define-modify-macro f32.4-decf (&optional (num 1f0)) two-arg-f32.4-)
(define-modify-macro f32.8-incf (&optional (num 1f0)) two-arg-f32.8+)
(define-modify-macro f32.8-decf (&optional (num 1f0)) two-arg-f32.8-)
(define-modify-macro f64.2-incf (&optional (num 1d0)) two-arg-f64.2+)
(define-modify-macro f64.2-decf (&optional (num 1d0)) two-arg-f64.2-)
(define-modify-macro f64.4-incf (&optional (num 1d0)) two-arg-f64.4+)
(define-modify-macro f64.4-decf (&optional (num 1d0)) two-arg-f64.4-)
(define-modify-macro u8.16-incf (&optional (num 1)) two-arg-u8.16+)
(define-modify-macro u8.16-decf (&optional (num 1)) two-arg-u8.16-)
(define-modify-macro u16.8-incf (&optional (num 1)) two-arg-u16.8+)
(define-modify-macro u16.8-decf (&optional (num 1)) two-arg-u16.8-)
(define-modify-macro u32.4-incf (&optional (num 1)) two-arg-u32.4+)
(define-modify-macro u32.4-decf (&optional (num 1)) two-arg-u32.4-)
(define-modify-macro u64.2-incf (&optional (num 1)) two-arg-u64.2+)
(define-modify-macro u64.2-decf (&optional (num 1)) two-arg-u64.2-)
(define-modify-macro s8.16-incf (&optional (num 1)) two-arg-s8.16+)
(define-modify-macro s8.16-decf (&optional (num 1)) two-arg-s8.16-)
(define-modify-macro s16.8-incf (&optional (num 1)) two-arg-s16.8+)
(define-modify-macro s16.8-decf (&optional (num 1)) two-arg-s16.8-)
(define-modify-macro s32.4-incf (&optional (num 1)) two-arg-s32.4+)
(define-modify-macro s32.4-decf (&optional (num 1)) two-arg-s32.4-)
(define-modify-macro s64.2-incf (&optional (num 1)) two-arg-s64.2+)
(define-modify-macro s64.2-decf (&optional (num 1)) two-arg-s64.2-)
(in-package #:sb-simd-avx2)
(define-modify-macro u8.32-incf (&optional (num 1)) two-arg-u8.32+)
(define-modify-macro u8.32-decf (&optional (num 1)) two-arg-u8.32-)
(define-modify-macro u16.16-incf (&optional (num 1)) two-arg-u16.16+)
(define-modify-macro u16.16-decf (&optional (num 1)) two-arg-u16.16-)
(define-modify-macro u32.8-incf (&optional (num 1)) two-arg-u32.8+)
(define-modify-macro u32.8-decf (&optional (num 1)) two-arg-u32.8-)
(define-modify-macro u64.4-incf (&optional (num 1)) two-arg-u64.4+)
(define-modify-macro u64.4-decf (&optional (num 1)) two-arg-u64.4-)
(define-modify-macro s8.32-incf (&optional (num 1)) two-arg-s8.32+)
(define-modify-macro s8.32-decf (&optional (num 1)) two-arg-s8.32-)
(define-modify-macro s16.16-incf (&optional (num 1)) two-arg-s16.16+)
(define-modify-macro s16.16-decf (&optional (num 1)) two-arg-s16.16-)
(define-modify-macro s32.8-incf (&optional (num 1)) two-arg-s32.8+)
(define-modify-macro s32.8-decf (&optional (num 1)) two-arg-s32.8-)
(define-modify-macro s64.4-incf (&optional (num 1)) two-arg-s64.4+)
(define-modify-macro s64.4-decf (&optional (num 1)) two-arg-s64.4-)

37
contrib/sb-simd/code/define-reducers.lisp Normal file
View file

@ -0,0 +1,37 @@
(in-package #:sb-simd-internals)
(macrolet
((define-reducer (reducer-record-name)
(with-accessors ((name reducer-record-name)
(binary-operation reducer-record-binary-operation)
(initial-element reducer-record-initial-element))
(find-function-record reducer-record-name)
(with-accessors ((binary-operation instruction-record-name)
(result-records instruction-record-result-records)
(argument-records instruction-record-argument-records)) binary-operation
(destructuring-bind ((value-record) (arg1-record arg2-record))
(list result-records argument-records)
(assert (eq value-record arg1-record))
(assert (eq value-record arg2-record))
(let ((type (value-record-name value-record)))
`(progn
(defun ,name (arg &rest more-args)
(if (null more-args)
(,binary-operation (,type ,initial-element) (,type arg))
(let ((result (,type arg)))
(declare (,type result))
(loop for arg in more-args
do (setf result (,binary-operation result (,type arg))))
result)))
(define-compiler-macro ,name (arg &rest more-args)
(cond ((null more-args)
`(,',binary-operation ,',initial-element (,',type ,arg)))
(t (reduce
(lambda (a b) `(,',binary-operation (,',type ,a) (,',type ,b)))
more-args
:initial-value `(,',type ,arg)))))))))))
(define-reducers ()
`(progn
,@(loop for reducer-record in (filter-function-records #'reducer-record-p)
collect `(define-reducer ,(reducer-record-name reducer-record))))))
(define-reducers))

44
contrib/sb-simd/code/define-reffers.lisp Normal file
View file

@ -0,0 +1,44 @@
(in-package #:sb-simd-internals)
;;; In this file, we define reffers for scalars that can be defined in
;;; terms of built-in Common Lisp functions.
(macrolet
((define-reffers ()
`(progn
,@(loop for record in (filter-function-records
(lambda (function-record)
(eq (symbol-package
(parse-function-name
(function-record-name function-record)))
(find-package "SB-SIMD"))))
for name = (function-record-name record)
for value-record = (first (function-record-result-records record))
for type = (value-record-name value-record)
when (aref-record-p record) collect
`(progn
(defun ,name (array &rest subscripts)
(declare (type (array ,type) array))
(apply #'aref array subscripts))
(define-compiler-macro ,name (array &rest subscripts)
`(aref (the (array ,',type) ,array) ,@subscripts)))
when (setf-aref-record-p record) collect
`(progn
(defun ,name (value array &rest subscripts)
(declare (type ,type value)
(type (array ,type) array))
(setf (apply #'aref array subscripts) value))
(define-compiler-macro ,name (value array &rest subscripts)
(let ((v (gensym "VALUE")))
`(let ((,v ,value))
(setf (aref (the (array ,',type) ,array) ,@subscripts)
,v)))))
when (row-major-aref-record-p record) collect
`(define-inline ,name (array index)
(declare (type (array ,type) array))
(row-major-aref array index))
when (setf-row-major-aref-record-p record) collect
`(define-inline ,name (value array index)
(declare (type ,type value)
(type (array ,type) array))
(setf (row-major-aref array index) value))))))
(define-reffers))

75
contrib/sb-simd/code/define-rounders.lisp Normal file
View file

@ -0,0 +1,75 @@
(in-package #:sb-simd-sse4.1)
(define-inline f32.4-round (x)
(f32.4-%round x #b00))
(define-inline f32.4-floor (x)
(f32.4-%round x #b01))
(define-inline f32.4-ceiling (x)
(f32.4-%round x #b10))
(define-inline f32.4-truncate (x)
(f32.4-%round x #b11))
(define-inline f64.2-round (x)
(f64.2-%round x #b00))
(define-inline f64.2-floor (x)
(f64.2-%round x #b01))
(define-inline f64.2-ceiling (x)
(f64.2-%round x #b10))
(define-inline f64.2-truncate (x)
(f64.2-%round x #b11))
(in-package #:sb-simd-avx)
(define-inline f32.4-round (x)
(f32.4-%round x #b00))
(define-inline f32.4-floor (x)
(f32.4-%round x #b01))
(define-inline f32.4-ceiling (x)
(f32.4-%round x #b10))
(define-inline f32.4-truncate (x)
(f32.4-%round x #b11))
(define-inline f64.2-round (x)
(f64.2-%round x #b00))
(define-inline f64.2-floor (x)
(f64.2-%round x #b01))
(define-inline f64.2-ceiling (x)
(f64.2-%round x #b10))
(define-inline f64.2-truncate (x)
(f64.2-%round x #b11))
(define-inline f32.8-round (x)
(f32.8-%round x #b00))
(define-inline f32.8-floor (x)
(f32.8-%round x #b01))
(define-inline f32.8-ceiling (x)
(f32.8-%round x #b10))
(define-inline f32.8-truncate (x)
(f32.8-%round x #b11))
(define-inline f64.4-round (x)
(f64.4-%round x #b00))
(define-inline f64.4-floor (x)
(f64.4-%round x #b01))
(define-inline f64.4-ceiling (x)
(f64.4-%round x #b10))
(define-inline f64.4-truncate (x)
(f64.4-%round x #b11))

78
contrib/sb-simd/code/define-scalar-casts.lisp Normal file
View file

@ -0,0 +1,78 @@
(in-package #:sb-simd-internals)
;;; For each value record we define a function of the same name that will
;;; either suitably convert its argument to that value record's type, or
;;; signal an error.
(macrolet
((define-scalar-cast (scalar-cast-record-name)
(with-accessors ((name scalar-cast-record-name))
(find-function-record scalar-cast-record-name)
(let ((err (mksym (symbol-package name) "CANNOT-CONVERT-TO-" name)))
`(progn
(define-notinline ,err (x)
(error "Cannot convert ~S to ~S." x ',name))
(sb-c:defknown ,name (t) (values ,name &optional)
(sb-c:foldable)
:overwrite-fndb-silently t)
(sb-c:deftransform ,name ((x) (,name) *)
'x)
,@(case name
(sb-simd:f32
`((sb-c:deftransform ,name ((x) (double-float) *)
'(coerce x 'single-float))))
(sb-simd:f64
`((sb-c:deftransform ,name ((x) (single-float) *)
'(coerce x 'double-float))))
(sb-simd-sse:f32
`((sb-c:deftransform ,name ((x) (double-float) *)
'(sb-kernel:%single-float x))
(sb-c:deftransform ,name ((x) ((signed-byte 64)) *)
'(sb-simd-sse::f32-from-s64 x))))
(sb-simd-sse2:f64
`((sb-c:deftransform ,name ((x) (single-float) *)
'(sb-simd-sse2::f64-from-f32 x))
(sb-c:deftransform ,name ((x) ((signed-byte 64)) *)
'(sb-simd-sse2::f64-from-s64 x))))
(sb-simd-avx:f32
`((sb-c:deftransform ,name ((x) (double-float) *)
'(sb-simd-avx::f32-from-f64 x))
(sb-c:deftransform ,name ((x) ((signed-byte 64)) *)
'(sb-simd-avx::f32-from-s64 x))))
(sb-simd-avx:f64
`((sb-c:deftransform ,name ((x) (single-float) *)
'(sb-simd-avx::f64-from-f32 x))
(sb-c:deftransform ,name ((x) ((signed-byte 64)) *)
'(sb-simd-avx::f64-from-s64 x)))))
(defun ,name (x)
(typecase x
(,name x)
,@(case name
(sb-simd:f32
`((double-float (coerce x 'single-float))
(real (coerce x ',name))))
(sb-simd:f64
`((sb-simd-sse2:f32 (coerce x 'double-float))
(real (coerce x ',name))))
(sb-simd-sse:f32
`((double-float (sb-kernel:%single-float x))
(sb-simd-sse:s64 (sb-simd-sse::%f32-from-s64 x))
(real (coerce x ',name))))
(sb-simd-sse2:f64
`((sb-simd-sse2:f32 (sb-simd-sse2::%f64-from-f32 x))
(sb-simd-sse2:s64 (sb-simd-sse2::%f64-from-s64 x))
(real (coerce x ',name))))
(sb-simd-avx:f32
`((sb-simd-avx:f64 (sb-simd-avx::%f32-from-f64 x))
(sb-simd-avx:s64 (sb-simd-avx::%f32-from-s64 x))
(real (coerce x ',name))))
(sb-simd-avx:f64
`((sb-simd-avx:f32 (sb-simd-avx::%f64-from-f32 x))
(sb-simd-avx:s64 (sb-simd-avx::%f64-from-s64 x))
(real (coerce x ',name)))))
(otherwise (,err x))))))))
(define-scalar-casts ()
`(progn
,@(loop for scalar-cast-record in (filter-function-records #'scalar-cast-record-p)
collect `(define-scalar-cast ,(function-record-name scalar-cast-record))))))
(define-scalar-casts))

92
contrib/sb-simd/code/define-simd-casts.lisp Normal file
View file

@ -0,0 +1,92 @@
(in-package #:sb-simd-internals)
;;; For each SIMD data type X.Y, define two functions:
;;;
;;; 1. A function named X.Y that ensures that an object is either of the
;;; type X.Y, or a scalar that can be broadcast to the type X.Y.
;;;
;;; 2. A function named X.Y! that reinterprets the bits of another SIMD
;;; pack or suitable scalar as an X.Y. If the supplied argument has
;;; more bits than the target data type, the excess bits are discarded.
;;; If the supplied argument has less bits than the target data types,
;;; the remaining bits are set to zero.
;;; The pXXX SIMD types are special - we define their 'cast' function
;;; manually.
(define-inline sb-simd-sse:p128 (x) (the sb-simd-sse:p128 x))
(define-inline sb-simd-avx:p128 (x) (the sb-simd-avx:p128 x))
(define-inline sb-simd-avx:p256 (x) (the sb-simd-avx:p256 x))
(macrolet
(;; We cannot call known functions directly in the definition of a
;; cast, only their VOPs. The reason is that each known function
;; definition uses casts to automatically upgrade its arguments, and
;; we don't want to end up with a circular dependency.
(call-vop (instruction-record-name &rest arguments)
(with-accessors ((instruction-set instruction-record-instruction-set)
(vop instruction-record-vop))
(find-function-record instruction-record-name)
(if (instruction-set-available-p instruction-set)
`(,vop ,@arguments)
`(progn
(missing-instruction
(load-time-value
(find-function-record ',instruction-record-name)))
(touch ,@arguments)))))
(define-simd-cast (simd-cast-record-name)
(with-accessors ((name simd-cast-record-name)
(instruction-set simd-cast-record-instruction-set)
(broadcast-record simd-cast-record-broadcast))
(find-function-record simd-cast-record-name)
(let* ((broadcast (function-record-name broadcast-record))
(simd-record (function-record-result-record broadcast-record))
(real-record (simd-record-scalar-record simd-record))
(simd-type (value-record-name simd-record))
(real-type (value-record-name real-record))
(package (instruction-set-package instruction-set))
(err (mksym package "CANNOT-CONVERT-TO-" name)))
`(progn
(define-notinline ,err (x)
(error "Cannot convert ~S to ~S." x ',name))
(sb-c:defknown ,name (t) (values ,name &optional)
(sb-c:foldable)
:overwrite-fndb-silently t)
(sb-c:deftransform ,name ((x) (,simd-type) *)
'x)
(sb-c:deftransform ,name ((x) (real) *)
'(,broadcast (,real-type x)))
(defun ,name (x)
(typecase x
(,simd-type x)
(real (call-vop ,broadcast (,real-type x)))
(otherwise (,err x))))))))
(define-reinterpret-cast (reinterpret-cast-record)
(with-accessors ((name reinterpret-cast-record-name)
(instruction-set reinterpret-cast-record-instruction-set)
(reinterpreters reinterpret-cast-record-reinterpreters))
(find-function-record reinterpret-cast-record)
(let* ((package (instruction-set-package instruction-set))
(err (mksym package "CANNOT-REINTERPRET-AS-" name)))
`(progn
(define-notinline ,err (x)
(error "Cannot reinterpret ~S as ~S." x ',name))
(defun ,name (x)
(typecase x
,@(loop for reinterpreter in reinterpreters
for argument-record = (first (function-record-required-argument-records reinterpreter))
collect
`(,(value-record-name argument-record)
(call-vop ,(function-record-name reinterpreter) x)))
(otherwise (,err x))))))))
(define-simd-casts ()
`(progn
,@(loop for simd-cast-record in (filter-function-records #'simd-cast-record-p)
collect
`(define-simd-cast ,(simd-cast-record-name simd-cast-record)))))
(define-reinterpret-casts ()
`(progn
,@(loop for reinterpret-cast-record in (filter-function-records #'reinterpret-cast-record-p)
collect
`(define-reinterpret-cast ,(reinterpret-cast-record-name reinterpret-cast-record))))))
(define-simd-casts)
(define-reinterpret-casts))

10
contrib/sb-simd/code/define-types.lisp Normal file
View file

@ -0,0 +1,10 @@
(in-package #:sb-simd-internals)
(macrolet
((define-types ()
`(progn
,@(loop for value-record being the hash-values of *value-records*
collect
`(deftype ,(value-record-name value-record) ()
',(value-record-type value-record))))))
(define-types))

46
contrib/sb-simd/code/define-unequals.lisp Normal file
View file

@ -0,0 +1,46 @@
(in-package #:sb-simd-internals)
(macrolet
((define-unequal (unequal-record-name)
(with-accessors ((name unequal-record-name)
(neq unequal-record-neq)
(and unequal-record-and)
(truth unequal-record-truth))
(find-function-record unequal-record-name)
(with-accessors ((neq instruction-record-name)
(result-records instruction-record-result-records)
(argument-records instruction-record-argument-records)) neq
(destructuring-bind ((result-record) (argument-record other-argument-record))
(list result-records argument-records)
(assert (eq argument-record other-argument-record))
(let ((and (function-record-name and))
(result-type (value-record-name result-record))
(argument-type (value-record-name argument-record)))
`(progn
(defun ,name (arg &rest more-args)
(let ((args (list* (,argument-type arg) (mapcar #',argument-type more-args)))
(result (,result-type ,truth)))
(declare (,result-type result))
(loop for (a . rest) on args do
(loop for b in rest do
(setf result (,and result (,neq a b)))))
result))
(define-compiler-macro ,name (arg &rest more-args)
(if (null more-args)
`(progn (,',argument-type ,arg) (,',result-type ,',truth))
(let ((bindings
(loop for arg in (list* arg more-args)
collect
(list (gensym "ARG") (list ',argument-type arg)))))
`(let ,bindings
(,',and
,@(loop for ((a nil) . rest) on bindings
append
(loop for (b nil) in rest
collect `(,',neq ,a ,b))))))))))))))
(define-unequals ()
`(progn
,@(loop for unequal-record in (filter-function-records #'unequal-record-p)
collect
`(define-unequal ,(unequal-record-name unequal-record))))))
(define-unequals))

68
contrib/sb-simd/code/define-vop-functions.lisp Normal file
View file

@ -0,0 +1,68 @@
(in-package #:sb-simd-internals)
;;; For constant folding, SBCL needs functions of the same name as the VOP.
;;; In this file, we define these functions. Because some VOPs cannot
;;; translate the full range of arguments supported by such a function,
;;; e.g., because one argument is expected to be a constant, we also need
;;; some macrology to have each function dispatch only to calls that can be
;;; translated.
(defmacro with-primitive-arguments (alist &body body)
;; Each entry in ALIST is of the form (VARIABLE VALUE-RECORD-NAME).
(if (null alist)
`(progn ,@body)
`(with-primitive-argument ,(first alist)
(with-primitive-arguments ,(rest alist)
,@body))))
(defmacro with-primitive-argument ((symbol value-record) &body body)
(with-accessors ((primitive-type value-record-primitive-type)
(simd-p simd-record-p))
(find-value-record value-record)
(etypecase primitive-type
;; Case 1: A symbol denoting a primitive type.
(symbol
(let ((alias (find primitive-type sb-c::*backend-primitive-type-aliases* :key #'car)))
;; ALIAS is either null or a list of the form (:OR PRIMITIVE-TYPE*)
(if (or (not simd-p) (not alias))
`(progn ,@body)
`(etypecase ,symbol
,@(loop for pt in (rest (rest alias))
for type = (sb-c::primitive-type-specifier (sb-c:primitive-type-or-lose pt))
collect `(,type ,@body))))))
;; Case 2: A list of the form (:CONSTANT TYPE), where TYPE is either
;; of the form (SIGNED-BYTE N) or (UNSIGNED-BYTE N) for some positive
;; integer N.
((cons (eql :constant) (cons type-specifier null))
(multiple-value-bind (low high)
(integer-type-specifier-inclusive-bounds (second primitive-type))
`(ecase ,symbol
,@(loop for value from low to high
collect `(,value (symbol-macrolet ((,symbol ,value)) ,@body)))))))))
(macrolet
((define-vop-function (name)
(with-accessors ((name instruction-record-name)
(vop instruction-record-vop)
(argument-records instruction-record-argument-records)
(encoding instruction-record-encoding)
(instruction-set instruction-record-instruction-set))
(find-function-record name)
(let* ((argument-record-names (mapcar #'record-name argument-records))
(argument-symbols (prefixed-symbols "ARGUMENT-" (length argument-records))))
(unless (or (eq encoding :fake-vop)
(not (instruction-set-available-p instruction-set)))
`(defun ,vop (,@argument-symbols)
(declare
,@(loop for argument-symbol in argument-symbols
for argument-record in argument-records
collect `(type ,(value-record-name argument-record) ,argument-symbol)))
(with-primitive-arguments ,(mapcar #'list argument-symbols argument-record-names)
(,vop ,@argument-symbols)))))))
(define-vop-functions ()
`(progn
,@(loop for instruction-record in (filter-function-records #'instruction-record-p)
for name = (instruction-record-name instruction-record)
collect `(define-vop-function ,name)))))
(define-vop-functions))

Some files were not shown because too many files have changed in this diff Show more