You can subscribe to this list here.
2002 |
Jan
|
Feb
|
Mar
(23) |
Apr
(68) |
May
(99) |
Jun
(109) |
Jul
(112) |
Aug
(104) |
Sep
(177) |
Oct
(211) |
Nov
(162) |
Dec
(135) |
---|---|---|---|---|---|---|---|---|---|---|---|---|
2003 |
Jan
(126) |
Feb
(228) |
Mar
(238) |
Apr
(299) |
May
(257) |
Jun
(283) |
Jul
(192) |
Aug
(227) |
Sep
(295) |
Oct
(202) |
Nov
(180) |
Dec
(70) |
2004 |
Jan
(88) |
Feb
(73) |
Mar
(133) |
Apr
(141) |
May
(205) |
Jun
(130) |
Jul
(148) |
Aug
(247) |
Sep
(228) |
Oct
(175) |
Nov
(158) |
Dec
(222) |
2005 |
Jan
(159) |
Feb
(96) |
Mar
(145) |
Apr
(192) |
May
(132) |
Jun
(190) |
Jul
(194) |
Aug
(280) |
Sep
(195) |
Oct
(207) |
Nov
(154) |
Dec
(101) |
2006 |
Jan
(156) |
Feb
(110) |
Mar
(261) |
Apr
(183) |
May
(148) |
Jun
(133) |
Jul
(94) |
Aug
(141) |
Sep
(137) |
Oct
(111) |
Nov
(172) |
Dec
(124) |
2007 |
Jan
(111) |
Feb
(72) |
Mar
(155) |
Apr
(286) |
May
(138) |
Jun
(170) |
Jul
(129) |
Aug
(156) |
Sep
(170) |
Oct
(90) |
Nov
(119) |
Dec
(112) |
2008 |
Jan
(135) |
Feb
(102) |
Mar
(115) |
Apr
(42) |
May
(132) |
Jun
(106) |
Jul
(94) |
Aug
(67) |
Sep
(33) |
Oct
(123) |
Nov
(54) |
Dec
(219) |
2009 |
Jan
(143) |
Feb
(168) |
Mar
(68) |
Apr
(142) |
May
(224) |
Jun
(202) |
Jul
(83) |
Aug
(86) |
Sep
(68) |
Oct
(37) |
Nov
(93) |
Dec
(80) |
2010 |
Jan
(39) |
Feb
(76) |
Mar
(144) |
Apr
(141) |
May
(27) |
Jun
(70) |
Jul
(23) |
Aug
(155) |
Sep
(152) |
Oct
(167) |
Nov
(87) |
Dec
(12) |
2011 |
Jan
(18) |
Feb
(39) |
Mar
(18) |
Apr
(27) |
May
(45) |
Jun
(135) |
Jul
(31) |
Aug
(82) |
Sep
(14) |
Oct
(60) |
Nov
(112) |
Dec
(117) |
2012 |
Jan
(15) |
Feb
(4) |
Mar
(30) |
Apr
(62) |
May
(45) |
Jun
(30) |
Jul
(9) |
Aug
(23) |
Sep
(41) |
Oct
(56) |
Nov
(35) |
Dec
(43) |
2013 |
Jan
(19) |
Feb
(41) |
Mar
(31) |
Apr
(28) |
May
(109) |
Jun
(90) |
Jul
(24) |
Aug
(37) |
Sep
(52) |
Oct
(45) |
Nov
(58) |
Dec
(35) |
2014 |
Jan
(24) |
Feb
(48) |
Mar
(93) |
Apr
(100) |
May
(204) |
Jun
(107) |
Jul
(85) |
Aug
(89) |
Sep
(79) |
Oct
(70) |
Nov
(92) |
Dec
(54) |
2015 |
Jan
(100) |
Feb
(103) |
Mar
(94) |
Apr
(77) |
May
(96) |
Jun
(63) |
Jul
(116) |
Aug
(76) |
Sep
(81) |
Oct
(269) |
Nov
(253) |
Dec
(143) |
2016 |
Jan
(78) |
Feb
(150) |
Mar
(151) |
Apr
(107) |
May
(52) |
Jun
(49) |
Jul
(71) |
Aug
(68) |
Sep
(127) |
Oct
(95) |
Nov
(73) |
Dec
(106) |
2017 |
Jan
(224) |
Feb
(144) |
Mar
(144) |
Apr
(99) |
May
(84) |
Jun
(112) |
Jul
(136) |
Aug
(200) |
Sep
(206) |
Oct
(255) |
Nov
(210) |
Dec
(324) |
2018 |
Jan
(289) |
Feb
(140) |
Mar
(223) |
Apr
(171) |
May
(174) |
Jun
(131) |
Jul
(108) |
Aug
(139) |
Sep
(126) |
Oct
(142) |
Nov
(109) |
Dec
(195) |
2019 |
Jan
(129) |
Feb
(102) |
Mar
(120) |
Apr
(157) |
May
(126) |
Jun
(99) |
Jul
(102) |
Aug
(117) |
Sep
(128) |
Oct
(143) |
Nov
(153) |
Dec
(156) |
2020 |
Jan
(139) |
Feb
(149) |
Mar
(251) |
Apr
(175) |
May
(140) |
Jun
(117) |
Jul
(140) |
Aug
(209) |
Sep
(194) |
Oct
(160) |
Nov
(177) |
Dec
(170) |
2021 |
Jan
(41) |
Feb
(126) |
Mar
(155) |
Apr
(152) |
May
(150) |
Jun
(116) |
Jul
(54) |
Aug
(151) |
Sep
(102) |
Oct
(182) |
Nov
(230) |
Dec
(161) |
2022 |
Jan
(213) |
Feb
(164) |
Mar
(206) |
Apr
(232) |
May
(219) |
Jun
(196) |
Jul
(177) |
Aug
(142) |
Sep
(179) |
Oct
(161) |
Nov
(165) |
Dec
(212) |
2023 |
Jan
(265) |
Feb
(98) |
Mar
(149) |
Apr
(87) |
May
(110) |
Jun
(207) |
Jul
(176) |
Aug
(223) |
Sep
(136) |
Oct
(117) |
Nov
(202) |
Dec
(217) |
2024 |
Jan
(228) |
Feb
(246) |
Mar
(254) |
Apr
|
May
|
Jun
|
Jul
|
Aug
|
Sep
|
Oct
|
Nov
|
Dec
|
From: Douglas K. <do...@go...> - 2014-06-24 02:17:04
|
That's precisely why I asked this question on sbcl-devel However CLHS is clear that the result-type of read-char is character, resp resp-byte is a byte. The author of one of the Quicklisp systems that got broken by this agreed that his code was in error On Wed, Jun 18, 2014 at 3:25 PM, Alastair Bridgewater < ala...@gm...> wrote: > Speaking of, almost anything in the gray stream interface which is > declared (in SBCL) to return BOOLEAN probably shouldn't be > (STREAM-DEFINITION-BY-USER says "true or false", and the CLHS for the > corresponding CL functions says "generalized boolean"). With certain > policies, this leads to typechecks being emitted on the calling side, > causing strange errors. > > > On Wed, Jun 18, 2014 at 1:45 PM, Stas Boukarev <sta...@gm...> wrote: > >> "Douglas Katzman" <sn...@us...> writes: >> >> > The branch "master" has been updated in SBCL: >> > via 7cdaadca09ba71e5642ae22b8414fe49ea1487fd (commit) >> > from 214b674f931b44ef389462a2351af0f668ab9c3c (commit) >> > >> > - Log ----------------------------------------------------------------- >> > commit 7cdaadca09ba71e5642ae22b8414fe49ea1487fd >> > Author: Douglas Katzman <do...@go...> >> > Date: Wed Jun 18 12:22:02 2014 -0400 >> > >> > Add some type-derivers >> What happens when a method for sb-gray:stream-read-char doesn't return a >> character? >> -- >> With best regards, Stas. >> >> >> ------------------------------------------------------------------------------ >> HPCC Systems Open Source Big Data Platform from LexisNexis Risk Solutions >> Find What Matters Most in Your Big Data with HPCC Systems >> Open Source. Fast. Scalable. Simple. Ideal for Dirty Data. >> Leverages Graph Analysis for Fast Processing & Easy Data Exploration >> http://p.sf.net/sfu/hpccsystems >> _______________________________________________ >> Sbcl-devel mailing list >> Sbc...@li... >> https://lists.sourceforge.net/lists/listinfo/sbcl-devel >> > > > > ------------------------------------------------------------------------------ > HPCC Systems Open Source Big Data Platform from LexisNexis Risk Solutions > Find What Matters Most in Your Big Data with HPCC Systems > Open Source. Fast. Scalable. Simple. Ideal for Dirty Data. > Leverages Graph Analysis for Fast Processing & Easy Data Exploration > http://p.sf.net/sfu/hpccsystems > _______________________________________________ > Sbcl-devel mailing list > Sbc...@li... > https://lists.sourceforge.net/lists/listinfo/sbcl-devel > > |
From: Douglas K. <do...@go...> - 2014-06-24 02:16:10
|
X is a string, so you can't unintern x. I assume you mean the result of the intern? But that's a totally different question. INTERN can't possibly return anything but a keyword. We've already discussed before (in the bug I opened suggesting that keywordp should be foldable) that keyword's can always "degrade" to ordinary symbols and that there are various internal things that are fundamentally broken if that actually happens in practice. On Thu, Jun 19, 2014 at 12:48 PM, Stas Boukarev <sta...@gm...> wrote: > "Douglas Katzman" <sn...@us...> writes: > > > The branch "master" has been updated in SBCL: > > via 1d796c22c86e8be5e49857edb3637cc9b70d0d94 (commit) > > from 758126197a609c34445dbd643f65aebb19bd602c (commit) > > > > - Log ----------------------------------------------------------------- > > commit 1d796c22c86e8be5e49857edb3637cc9b70d0d94 > > Author: Douglas Katzman <do...@go...> > > Date: Wed Jun 18 22:32:25 2014 -0400 > > > > Derive that (INTERN x "KEYWORD") produces a KEYWORD > What happens when unintern is called on x? > > -- > With best regards, Stas. > > > ------------------------------------------------------------------------------ > HPCC Systems Open Source Big Data Platform from LexisNexis Risk Solutions > Find What Matters Most in Your Big Data with HPCC Systems > Open Source. Fast. Scalable. Simple. Ideal for Dirty Data. > Leverages Graph Analysis for Fast Processing & Easy Data Exploration > http://p.sf.net/sfu/hpccsystems > _______________________________________________ > Sbcl-devel mailing list > Sbc...@li... > https://lists.sourceforge.net/lists/listinfo/sbcl-devel > |
From: Christophe R. <cr...@us...> - 2014-06-20 10:49:43
|
The branch "master" has been updated in SBCL: via c06b8c16bd481287337567f16e33c83dd14da72f (commit) from 233cf1b2e0734dc50cb96df86bdcf215f17ff626 (commit) - Log ----------------------------------------------------------------- commit c06b8c16bd481287337567f16e33c83dd14da72f Author: Christophe Rhodes <cs...@ca...> Date: Fri Jun 20 11:48:35 2014 +0100 support for DragonFly BSD x86(-64) only for now, and threads are currently non-functional. Closes lp#1292845, thanks to Vasily Postnicov. --- NEWS | 2 + TODO | 5 ++ base-target-features.lisp-expr | 35 +++++++------- contrib/asdf/asdf.lisp | 2 +- contrib/sb-bsd-sockets/constants.lisp | 2 +- contrib/sb-bsd-sockets/tests.lisp | 1 + make-config.sh | 21 ++++++++- src/code/run-program.lisp | 4 +- src/code/unix.lisp | 6 +- src/cold/shared.lisp | 5 ++- src/compiler/x86/parms.lisp | 15 +++--- src/runtime/Config.x86-64-dragonfly | 24 ++++++++++ src/runtime/Config.x86-dragonfly | 25 ++++++++++ src/runtime/bsd-os.c | 79 ++++++++++++++++++++++++++++++++- src/runtime/bsd-os.h | 8 +++ src/runtime/thread.c | 3 +- src/runtime/undefineds.h | 9 +++- src/runtime/x86-64-arch.c | 2 +- src/runtime/x86-64-assem.S | 4 +- src/runtime/x86-64-bsd-os.c | 19 +++++++- src/runtime/x86-64-bsd-os.h | 24 ++++++++++- src/runtime/x86-arch.c | 2 +- src/runtime/x86-assem.S | 9 +++- src/runtime/x86-bsd-os.c | 16 +++++-- src/runtime/x86-bsd-os.h | 4 +- tests/run-compiler.sh | 2 + tools-for-build/ldso-stubs.lisp | 2 +- 27 files changed, 273 insertions(+), 57 deletions(-) diff --git a/NEWS b/NEWS index 0f72197..4f73b23 100644 --- a/NEWS +++ b/NEWS @@ -6,6 +6,8 @@ changes relative to sbcl-1.2.0: to Christoph Egger) * enhancement: experimental support for threads on NetBSD/x86-64. (thanks to Robert Swindells) + * enhancement: support for DragonFly BSD. (lp#1292845, thanks to Vasily + Postnicov) * bug fix: TYPE-OF must not return AND/OR/NOT expressions. (lp#1317308) * bug fix: accessing NIL arrays stopped producing errors. (lp#1311421) diff --git a/TODO b/TODO index 6c8d83b..e93e629 100644 --- a/TODO +++ b/TODO @@ -104,6 +104,11 @@ DARWIN Needs love, particularly threads and exceptions/signals. slam.sh is also broken there. +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. + FUNCTION NAMES We'd like to be able to (SETF %FUNCTION-NAME) on a closure. diff --git a/base-target-features.lisp-expr b/base-target-features.lisp-expr index eb30d6d..7d30814 100644 --- a/base-target-features.lisp-expr +++ b/base-target-features.lisp-expr @@ -444,23 +444,24 @@ ;; implemented for this platform. ;; ;; operating system features: - ;; :unix = We're intended to run under some Unix-like OS. (This is not - ;; exclusive with the features which indicate which particular - ;; Unix-like OS we're intended to run under.) - ;; :linux = We're intended to run under some version of Linux. - ;; :bsd = We're intended to run under some version of BSD Unix. (This - ;; is not exclusive with the features which indicate which - ;; particular version of BSD we're intended to run under.) - ;; :freebsd = We're intended to run under FreeBSD. - ;; :openbsd = We're intended to run under OpenBSD. - ;; :netbsd = We're intended to run under NetBSD. - ;; :darwin = We're intended to run under Darwin (including MacOS X). - ;; :sunos = We're intended to run under Solaris user environment - ;; with the SunOS kernel. - ;; :hpux = We're intended to run under HP-UX 11.11 or later - ;; :osf1 = We're intended to run under Tru64 (aka Digital Unix - ;; aka OSF/1). - ;; :win32 = We're intended to under some version of Microsoft Windows. + ;; :unix = We're intended to run under some Unix-like OS. (This is not + ;; exclusive with the features which indicate which particular + ;; Unix-like OS we're intended to run under.) + ;; :linux = We're intended to run under some version of Linux. + ;; :bsd = We're intended to run under some version of BSD Unix. (This + ;; is not exclusive with the features which indicate which + ;; particular version of BSD we're intended to run under.) + ;; :freebsd = We're intended to run under FreeBSD. + ;; :openbsd = We're intended to run under OpenBSD. + ;; :netbsd = We're intended to run under NetBSD. + ;; :dragonfly = We're intended to run under DragonFly BSD. + ;; :darwin = We're intended to run under Darwin (including MacOS X). + ;; :sunos = We're intended to run under Solaris user environment + ;; with the SunOS kernel. + ;; :hpux = We're intended to run under HP-UX 11.11 or later + ;; :osf1 = We're intended to run under Tru64 (aka Digital Unix + ;; aka OSF/1). + ;; :win32 = We're intended to under some version of Microsoft Windows. ;; (No others are supported by SBCL as of 1.0.8, but :hpux or :irix ;; support could be ported from CMU CL if anyone is sufficiently ;; motivated to do so.) diff --git a/contrib/asdf/asdf.lisp b/contrib/asdf/asdf.lisp index e90fae7..49e1d5b 100644 --- a/contrib/asdf/asdf.lisp +++ b/contrib/asdf/asdf.lisp @@ -1601,7 +1601,7 @@ then returning the non-empty string value of the variable" '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first! (:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd (:macosx :macosx :darwin :darwin-target :apple) ; also before :bsd - (:solaris :solaris :sunos) (:bsd :bsd :freebsd :netbsd :openbsd) :unix + (:solaris :solaris :sunos) (:bsd :bsd :freebsd :netbsd :openbsd :dragonfly) :unix :genera))) (defun architecture () diff --git a/contrib/sb-bsd-sockets/constants.lisp b/contrib/sb-bsd-sockets/constants.lisp index 636fc21..49d3dfd 100644 --- a/contrib/sb-bsd-sockets/constants.lisp +++ b/contrib/sb-bsd-sockets/constants.lisp @@ -324,7 +324,7 @@ (:integer EAI-BADFLAGS "EAI_BADFLAGS") (:integer EAI-NONAME "EAI_NONAME") (:integer EAI-SERVICE "EAI_SERVICE") - #-freebsd + #-(or freebsd dragonfly) (:integer EAI-ADDRFAMILY "EAI_ADDRFAMILY") (:integer EAI-MEMORY "EAI_MEMORY") (:integer EAI-FAIL "EAI_FAIL") diff --git a/contrib/sb-bsd-sockets/tests.lisp b/contrib/sb-bsd-sockets/tests.lisp index d10a31b..89839d5 100644 --- a/contrib/sb-bsd-sockets/tests.lisp +++ b/contrib/sb-bsd-sockets/tests.lisp @@ -30,6 +30,7 @@ ;;; Apparently getprotobyname_r on FreeBSD says -1 and EINTR ;;; for unknown protocols... #-(and freebsd sb-thread) +#-(and dragonfly sb-thread) (deftest get-protocol-by-name/error (handler-case (get-protocol-by-name "nonexistent-protocol") (unknown-protocol () diff --git a/make-config.sh b/make-config.sh index b219dfc..22f7f03 100755 --- a/make-config.sh +++ b/make-config.sh @@ -289,6 +289,9 @@ case `uname` in ;; esac ;; + DragonFly) + sbcl_os="dragonfly" + ;; Darwin) sbcl_os="darwin" ;; @@ -399,7 +402,8 @@ then # If --fancy, enable threads on platforms where they can be built. case $sbcl_arch in x86|x86-64|ppc) - if [ "$sbcl_os" = "sunos" ] && [ "$sbcl_arch" = "x86-64" ] + if ([ "$sbcl_os" = "sunos" ] && [ "$sbcl_arch" = "x86-64" ]) || \ + [ "$sbcl_os" = "dragonfly" ] then echo "No threads on this platform." else @@ -513,6 +517,19 @@ case "$sbcl_os" in ;; esac ;; + dragonfly) + printf ' :unix' >> $ltf + printf ' :bsd' >> $ltf + printf ' :elf' >> $ltf + printf ' :dragonfly' >> $ltf + printf ' :sb-qshow' >> $ltf + if [ $sbcl_arch = "x86" ]; then + printf ' :restore-fs-segment-register-from-tls' >> $ltf + fi + link_or_copy $sbcl_arch-bsd-os.h target-arch-os.h + link_or_copy bsd-os.h target-os.h + link_or_copy Config.$sbcl_arch-dragonfly Config + ;; darwin) printf ' :unix' >> $ltf printf ' :mach-o' >> $ltf @@ -598,7 +615,7 @@ if [ "$sbcl_arch" = "x86" ]; then printf ' :alien-callbacks :cycle-counter :inline-constants ' >> $ltf printf ' :memory-barrier-vops :multiply-high-vops :ash-right-vops :symbol-info-vops' >> $ltf case "$sbcl_os" in - linux | freebsd | netbsd | openbsd | sunos | darwin | win32) + linux | freebsd | netbsd | openbsd | sunos | darwin | win32 | dragonfly) printf ' :linkage-table' >> $ltf esac if [ "$sbcl_os" = "win32" ]; then diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp index 7216349..43ca5f6 100644 --- a/src/code/run-program.lisp +++ b/src/code/run-program.lisp @@ -406,7 +406,7 @@ status slot." ;;; Find an unused pty. Return three values: the file descriptor for ;;; the master side of the pty, the file descriptor for the slave side ;;; of the pty, and the name of the tty device for the slave side. -#-(or win32 openbsd freebsd) +#-(or win32 openbsd freebsd dragonfly) (progn (define-alien-routine ptsname c-string (fd int)) (define-alien-routine grantpt boolean (fd int)) @@ -458,7 +458,7 @@ status slot." (sb-unix:unix-close master-fd)))))) (error "could not find a pty"))) -#+(or openbsd freebsd) +#+(or openbsd freebsd dragonfly) (progn (define-alien-routine openpty int (amaster int :out) (aslave int :out) (name (* char)) (termp (* t)) (winp (* t))) diff --git a/src/code/unix.lisp b/src/code/unix.lisp index 9553f62..8883fa5 100644 --- a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ -387,16 +387,16 @@ corresponds to NAME, or NIL if there is none." ;; ;; Signal an error at compile-time, since it's needed for the ;; runtime to start up - #!-(or android linux openbsd freebsd netbsd sunos osf1 darwin hpux win32) + #!-(or android linux openbsd freebsd netbsd sunos osf1 darwin hpux win32 dragonfly) #.(error "POSIX-GETCWD is not implemented.") (or - #!+(or linux openbsd freebsd netbsd sunos osf1 darwin hpux win32) + #!+(or linux openbsd freebsd netbsd sunos osf1 darwin hpux win32 dragonfly) (newcharstar-string (alien-funcall (extern-alien "getcwd" (function (* char) (* char) size-t)) nil - #!+(or linux openbsd freebsd netbsd darwin win32) 0 + #!+(or linux openbsd freebsd netbsd darwin win32 dragonfly) 0 #!+(or sunos osf1 hpux) 1025)) #!+android (with-alien ((ptr (array char #.path-max))) diff --git a/src/cold/shared.lisp b/src/cold/shared.lisp index 9530114..36c09ec 100644 --- a/src/cold/shared.lisp +++ b/src/cold/shared.lisp @@ -176,7 +176,10 @@ (and ppc (or sparc x86 x86-64)) (and sparc (or x86 x86-64)) (and x86 x86-64))" - "More than one architecture selected"))) + "More than one architecture selected") + ;; There is still hope to make multithreading on DragonFly x86-64 + ("(and sb-thread x86 dragonfly)" + ":SB-THREAD not supported on selected architecture"))) (failed-test-descriptions nil)) (dolist (test feature-compatability-tests) (let ((*features* *shebang-features*)) diff --git a/src/compiler/x86/parms.lisp b/src/compiler/x86/parms.lisp index 75d2345..15a37ba 100644 --- a/src/compiler/x86/parms.lisp +++ b/src/compiler/x86/parms.lisp @@ -187,13 +187,14 @@ ;;; NetBSD configuration used to have this comment regarding the linkage ;;; table: "In CMUCL: 0xB0000000->0xB1000000" -#!+win32 (!gencgc-space-setup #x22000000 nil nil #x10000) -#!+linux (!gencgc-space-setup #x01000000 #x09000000) -#!+sunos (!gencgc-space-setup #x20000000 #x48000000) -#!+freebsd (!gencgc-space-setup #x01000000 #x58000000) -#!+openbsd (!gencgc-space-setup #x1b000000 #x40000000) -#!+netbsd (!gencgc-space-setup #x20000000 #x60000000) -#!+darwin (!gencgc-space-setup #x04000000 #x10000000) +#!+win32 (!gencgc-space-setup #x22000000 nil nil #x10000) +#!+linux (!gencgc-space-setup #x01000000 #x09000000) +#!+sunos (!gencgc-space-setup #x20000000 #x48000000) +#!+freebsd (!gencgc-space-setup #x01000000 #x58000000) +#!+dragonfly (!gencgc-space-setup #x01000000 #x58000000) +#!+openbsd (!gencgc-space-setup #x1b000000 #x40000000) +#!+netbsd (!gencgc-space-setup #x20000000 #x60000000) +#!+darwin (!gencgc-space-setup #x04000000 #x10000000) ;;; Size of one linkage-table entry in bytes. (def!constant linkage-table-entry-size 8) diff --git a/src/runtime/Config.x86-64-dragonfly b/src/runtime/Config.x86-64-dragonfly new file mode 100644 index 0000000..c8cf688 --- /dev/null +++ b/src/runtime/Config.x86-64-dragonfly @@ -0,0 +1,24 @@ +# -*- makefile -*- for the C-level run-time support for SBCL + +# This software is part of the SBCL system. See the README file for +# more information. +# +# This software is derived from the CMU CL system, which was +# written at Carnegie Mellon University and released into the +# public domain. The software is in the public domain and is +# provided with absolutely no warranty. See the COPYING and CREDITS +# files for more information. + +# DragonFly BSD config is a modification of one for FreeBSD + +include Config.x86-64-bsd + +ASSEM_SRC += ldso-stubs.S +LINKFLAGS += -dynamic -export-dynamic + +# Link against pthread even if we do not want threaded SBCL +# This is because of bug in DragonFly RTLD which sometimes +# (in very rare situations) makes loading threaded libraries +# impossible without it. +# See: https://bugs.dragonflybsd.org/issues/2663 +OS_LIBS += -lutil -lpthread diff --git a/src/runtime/Config.x86-dragonfly b/src/runtime/Config.x86-dragonfly new file mode 100644 index 0000000..03b3598 --- /dev/null +++ b/src/runtime/Config.x86-dragonfly @@ -0,0 +1,25 @@ +# -*- makefile -*- for the C-level run-time support for SBCL + +# This software is part of the SBCL system. See the README file for +# more information. +# +# This software is derived from the CMU CL system, which was +# written at Carnegie Mellon University and released into the +# public domain. The software is in the public domain and is +# provided with absolutely no warranty. See the COPYING and CREDITS +# files for more information. + +# DragonFly BSD config is a modification of one for FreeBSD + +include Config.x86-bsd + +ASSEM_SRC += ldso-stubs.S +LINKFLAGS += -dynamic -export-dynamic +# Link against pthread even if we do not want threaded SBCL +# This is because of bug in DragonFly RTLD which sometimes +# (in very rare situations) makes loading threaded libraries +# impossible without it. +# See: https://bugs.dragonflybsd.org/issues/2663 +OS_LIBS += -lutil -lpthread + +CFLAGS += -fno-omit-frame-pointer diff --git a/src/runtime/bsd-os.c b/src/runtime/bsd-os.c index fdfb89e..7007e39 100644 --- a/src/runtime/bsd-os.c +++ b/src/runtime/bsd-os.c @@ -73,6 +73,12 @@ static os_vm_size_t max_allocation_size; static void freebsd_init(); #endif /* __FreeBSD__ */ +#ifdef __DragonFly__ +#include <sys/sysctl.h> + +static void dragonfly_init(); +#endif /* __DragonFly__ */ + #ifdef __OpenBSD__ #include <sys/types.h> #include <sys/resource.h> @@ -99,6 +105,8 @@ os_init(char *argv[], char *envp[]) openbsd_init(); #elif defined(LISP_FEATURE_DARWIN) darwin_init(); +#elif defined(__DragonFly__) + dragonfly_init(); #endif } @@ -108,7 +116,8 @@ os_context_sigmask_addr(os_context_t *context) /* (Unlike most of the other context fields that we access, the * signal mask field is a field of the basic, outermost context * struct itself both in FreeBSD 4.0 and in OpenBSD 2.6.) */ -#if defined(LISP_FEATURE_FREEBSD) || defined(__NetBSD__) || defined(LISP_FEATURE_DARWIN) +#if defined(LISP_FEATURE_FREEBSD) || defined(__NetBSD__) || defined(LISP_FEATURE_DARWIN) \ + || defined(__DragonFly__) return &context->uc_sigmask; #elif defined (__OpenBSD__) return &context->sc_mask; @@ -494,6 +503,58 @@ futex_wake(int *lock_word, int n) #endif #endif /* __FreeBSD__ */ +#ifdef __DragonFly__ +static void dragonfly_init() +{ +#ifdef LISP_FEATURE_X86 + size_t len; + int instruction_sse; + + len = sizeof(instruction_sse); + if (sysctlbyname("hw.instruction_sse", &instruction_sse, &len, + NULL, 0) == 0 && instruction_sse != 0) { + /* Use the SSE detector */ + fast_bzero_pointer = fast_bzero_detect; + } +#endif /* LISP_FEATURE_X86 */ +} + + +#if defined(LISP_FEATURE_SB_THREAD) && defined(LISP_FEATURE_SB_FUTEX) \ + && !defined(LISP_FEATURE_SB_PTHREAD_FUTEX) +int +futex_wait(int *lock_word, long oldval, long sec, unsigned long usec) +{ + int ret; + + if (sec < 0) + ret = umtx_sleep(lock_word, oldval, 0); + else { + int count = usec + 1000000 * sec; + ret = umtx_sleep(lock_word, oldval, count); + } + + if (ret == 0) return 0; + else { + switch (errno) { + case EWOULDBLOCK: // Operation timed out + return 1; + case EINTR: + return 2; + default: // Such as EINVAL or EBUSY + return -1; + } + } +} + +int +futex_wake(int *lock_word, int n) +{ + return umtx_wakeup(lock_word, n); +} +#endif +#endif /* __DragonFly__ */ + #ifdef LISP_FEATURE_DARWIN /* defined in ppc-darwin-os.c instead */ #elif defined(LISP_FEATURE_FREEBSD) @@ -532,6 +593,20 @@ os_get_runtime_executable_path(int external) return NULL; return copied_string(path); } +#elif defined(LISP_FEATURE_DRAGONFLY) +char * +os_get_runtime_executable_path(int external) +{ + char path[PATH_MAX + 1]; + int size = readlink("/proc/curproc/file", path, sizeof(path) - 1); + if (size < 0) + return NULL; + path[size] = '\0'; + + if (strcmp(path, "unknown") == 0) + return NULL; + return copied_string(path); +} #elif defined(LISP_FEATURE_NETBSD) || defined(LISP_FEATURE_OPENBSD) char * os_get_runtime_executable_path(int external) @@ -541,7 +616,7 @@ os_get_runtime_executable_path(int external) return copied_string("/proc/curproc/file"); return NULL; } -#else /* Not DARWIN or FREEBSD or NETBSD or OPENBSD */ +#else /* Not DARWIN or FREEBSD or NETBSD or OPENBSD or DragonFly */ char * os_get_runtime_executable_path(int external) { diff --git a/src/runtime/bsd-os.h b/src/runtime/bsd-os.h index 3ea3174..b782da5 100644 --- a/src/runtime/bsd-os.h +++ b/src/runtime/bsd-os.h @@ -61,6 +61,14 @@ extern int sig_memory_fault; #define SIG_STOP_FOR_GC (SIGUSR2) +#elif defined __DragonFly__ + +#include <sys/ucontext.h> +typedef ucontext_t os_context_t; + +#define SIG_MEMORY_FAULT (SIGSEGV) +#define SIG_STOP_FOR_GC (SIGUSR2) + #elif defined __OpenBSD__ typedef struct sigcontext os_context_t; diff --git a/src/runtime/thread.c b/src/runtime/thread.c index 65edae1..dbe5eb2 100644 --- a/src/runtime/thread.c +++ b/src/runtime/thread.c @@ -58,8 +58,7 @@ #define LOCK_CREATE_THREAD #endif -#ifdef LISP_FEATURE_FREEBSD -#define CREATE_CLEANUP_THREAD +#if defined(LISP_FEATURE_FREEBSD) || defined(LISP_FEATURE_DRAGONFLY) #define LOCK_CREATE_THREAD #endif diff --git a/src/runtime/undefineds.h b/src/runtime/undefineds.h index b1cb325..024b565 100644 --- a/src/runtime/undefineds.h +++ b/src/runtime/undefineds.h @@ -39,7 +39,8 @@ F(brk) || defined(SVR4) \ || defined(__FreeBSD__) \ || defined(__OpenBSD__) \ - || defined(__NetBSD__) + || defined(__NetBSD__) \ + || defined(__DragonFly__) F(cfgetospeed) F(cfsetospeed) F(cfgetispeed) @@ -154,7 +155,7 @@ F(sigreturn) #if !defined(SVR4) F(sigsetmask) #endif -#if !defined(SVR4) && !defined(__FreeBSD__) && !defined(__OpenBSD__) && !defined(__NetBSD__) +#if !defined(SVR4) && !defined(__FreeBSD__) && !defined(__OpenBSD__) && !defined(__NetBSD__) && !defined(__DragonFly__) F(sigstack) F(sigvec) #endif @@ -180,6 +181,7 @@ F(readdir) || defined(__FreeBSD__) \ || defined(__OpenBSD__) \ || defined(__NetBSD__) \ + || defined(__DragonFly__) \ || defined(__linux__) F(tcgetattr) F(tcsetattr) @@ -198,6 +200,7 @@ F(umask) && !defined(SOLARIS) \ && !defined(__OpenBSD__) \ && !defined(__FreeBSD__) \ + && !defined(__DragonFly__) \ && !defined(__NetBSD__) F(umount) #endif @@ -208,7 +211,7 @@ F(utimes) #ifndef irix F(vfork) #endif -#if !defined(osf1) && !defined(__FreeBSD__) && !defined(__OpenBSD__) && !defined(__NetBSD__) +#if !defined(osf1) && !defined(__FreeBSD__) && !defined(__OpenBSD__) && !defined(__NetBSD__) && !defined(__DragonFly__) F(vhangup) #endif F(wait) diff --git a/src/runtime/x86-64-arch.c b/src/runtime/x86-64-arch.c index 15f446d..a58e275 100644 --- a/src/runtime/x86-64-arch.c +++ b/src/runtime/x86-64-arch.c @@ -68,7 +68,7 @@ context_eflags_addr(os_context_t *context) * we need to do this nasty absolute index magic number thing * instead. */ return &context->uc_mcontext.gregs[17]; -#elif defined LISP_FEATURE_FREEBSD +#elif defined LISP_FEATURE_FREEBSD || defined(__DragonFly__) return &context->uc_mcontext.mc_rflags; #elif defined LISP_FEATURE_DARWIN return CONTEXT_ADDR_FROM_STEM(rflags); diff --git a/src/runtime/x86-64-assem.S b/src/runtime/x86-64-assem.S index d19855c..22c3124 100644 --- a/src/runtime/x86-64-assem.S +++ b/src/runtime/x86-64-assem.S @@ -25,7 +25,7 @@ #include "genesis/thread.h" /* Minimize conditionalization for different OS naming schemes. */ -#if defined __linux__ || defined __FreeBSD__ || defined __OpenBSD__ || defined __NetBSD__ || defined __sun || defined _WIN64 +#if defined __linux__ || defined __FreeBSD__ || defined __OpenBSD__ || defined __NetBSD__ || defined __sun || defined _WIN64 || defined __DragonFly__ #define GNAME(var) var #else #define GNAME(var) _##var @@ -33,7 +33,7 @@ /* Get the right type of alignment. Linux, FreeBSD and OpenBSD * want alignment in bytes. */ -#if defined(__linux__) || defined(__FreeBSD__) || defined(__OpenBSD__) || defined __NetBSD__ || defined(__sun) || defined _WIN64 +#if defined(__linux__) || defined(__FreeBSD__) || defined(__OpenBSD__) || defined __NetBSD__ || defined(__sun) || defined _WIN64 || defined(__DragonFly__) #define align_4byte 4 #define align_8byte 8 #define align_16byte 16 diff --git a/src/runtime/x86-64-bsd-os.c b/src/runtime/x86-64-bsd-os.c index 3d9a9c7..b394118 100644 --- a/src/runtime/x86-64-bsd-os.c +++ b/src/runtime/x86-64-bsd-os.c @@ -12,6 +12,10 @@ #include <machine/fpu.h> #endif +#if defined(LISP_FEATURE_DRAGONFLY) +#include <machine/npx.h> +#endif + /* KLUDGE: There is strong family resemblance in the signal context * stuff in FreeBSD and OpenBSD, but in detail they're different in * almost every line of code. It would be nice to find some way to @@ -23,7 +27,7 @@ * entails; unfortunately, currently the situation is worse, not * better, than in the above paragraph. */ -#if defined(LISP_FEATURE_FREEBSD) || defined(LISP_FEATURE_DARWIN) || defined(LISP_FEATURE_OPENBSD) +#if defined(LISP_FEATURE_FREEBSD) || defined(LISP_FEATURE_DARWIN) || defined(LISP_FEATURE_OPENBSD) || defined(LISP_FEATURE_DRAGONFLY) os_context_register_t * os_context_register_addr(os_context_t *context, int offset) { @@ -168,6 +172,19 @@ int arch_os_thread_cleanup(struct thread *thread) { return 1; /* success */ } +#if defined(LISP_FEATURE_DRAGONFLY) +void +os_restore_fp_control(os_context_t *context) +{ + struct envxmm *ex = (struct envxmm*)(&context->uc_mcontext.mc_fpregs); + /* reset exception flags and restore control flags on SSE2 FPU */ + unsigned int temp = (ex->en_mxcsr) & ~0x3F; + asm ("ldmxcsr %0" : : "m" (temp)); + /* same for x87 FPU. */ + asm ("fldcw %0" : : "m" (ex->en_cw)); +} +#endif + #if defined(LISP_FEATURE_FREEBSD) void os_restore_fp_control(os_context_t *context) diff --git a/src/runtime/x86-64-bsd-os.h b/src/runtime/x86-64-bsd-os.h index 036f47b..4bff08b 100644 --- a/src/runtime/x86-64-bsd-os.h +++ b/src/runtime/x86-64-bsd-os.h @@ -5,6 +5,10 @@ #include <machine/fpu.h> #endif +#ifdef LISP_FEATURE_DRAGONFLY +#include <machine/npx.h> +#endif + typedef register_t os_context_register_t; static inline os_context_t *arch_os_get_context(void **void_context) @@ -16,7 +20,7 @@ static inline os_context_t *arch_os_get_context(void **void_context) * store signal context information, but at least they tend to use the * same stems to name the structure fields, so by using this macro we * can share a fair amount of code between different variants. */ -#if defined LISP_FEATURE_FREEBSD +#if defined LISP_FEATURE_FREEBSD || defined(__DragonFly__) #define CONTEXT_ADDR_FROM_STEM(stem) &context->uc_mcontext.mc_ ## stem #elif defined(__OpenBSD__) #define CONTEXT_ADDR_FROM_STEM(stem) &context->sc_ ## stem @@ -26,6 +30,24 @@ static inline os_context_t *arch_os_get_context(void **void_context) #error unsupported BSD variant #endif +#if defined LISP_FEATURE_DRAGONFLY +/* I am not sure if following definition is needed after this: + http://gitweb.dragonflybsd.org/dragonfly.git/commit/e6e019a801e99ba7888ed009c5c3b3c7b047af1e + + But It will not harm if I leave it here. */ +#define RESTORE_FP_CONTROL_FROM_CONTEXT +void os_restore_fp_control(os_context_t *context); + +#define X86_64_SIGFPE_FIXUP + +static inline unsigned int * +arch_os_context_mxcsr_addr(os_context_t *context) +{ + struct envxmm *ex = (struct envxmm *)(&context->uc_mcontext.mc_fpregs); + return &ex->en_mxcsr; +} +#endif + #if defined LISP_FEATURE_FREEBSD #define RESTORE_FP_CONTROL_FROM_CONTEXT void os_restore_fp_control(os_context_t *context); diff --git a/src/runtime/x86-arch.c b/src/runtime/x86-arch.c index d00f26b..3692625 100644 --- a/src/runtime/x86-arch.c +++ b/src/runtime/x86-arch.c @@ -66,7 +66,7 @@ context_eflags_addr(os_context_t *context) * we need to do this nasty absolute index magic number thing * instead. */ return &context->uc_mcontext.gregs[16]; -#elif defined __FreeBSD__ +#elif defined(__FreeBSD__) || defined(__DragonFly__) return &context->uc_mcontext.mc_eflags; #elif defined __OpenBSD__ return &context->sc_eflags; diff --git a/src/runtime/x86-assem.S b/src/runtime/x86-assem.S index 97aeff7..157721a 100644 --- a/src/runtime/x86-assem.S +++ b/src/runtime/x86-assem.S @@ -32,7 +32,8 @@ * * (Except Win32, which is unlikely ever to be ELF, sorry. -- AB 2005-12-08) */ -#if defined __linux__ || defined LISP_FEATURE_FREEBSD || defined __NetBSD__ || defined __OpenBSD__ || defined __sun +#if defined __linux__ || defined LISP_FEATURE_FREEBSD || defined __NetBSD__ || defined __OpenBSD__ || \ + defined __sun || defined __DragonFly__ #define GNAME(var) var #else #define GNAME(var) _##var @@ -47,7 +48,8 @@ * matter any more, perhaps it's just clutter we could get * rid of? -- WHN 2004-04-18) */ -#if defined(__linux__) || defined(LISP_FEATURE_FREEBSD) || defined(__NetBSD__) || defined(__OpenBSD__) || defined(__sun) || defined(LISP_FEATURE_WIN32) +#if defined(__linux__) || defined(LISP_FEATURE_FREEBSD) || defined(__NetBSD__) || defined(__OpenBSD__) || \ + defined(__sun) || defined(LISP_FEATURE_WIN32) || defined(__DragonFly__) #define align_4byte 4 #define align_8byte 8 #define align_16byte 16 @@ -131,7 +133,8 @@ # define LoadCurrentThreadSlot(offset,reg); \ movl SBCL_THREAD_BASE_EA, reg ; \ movl offset(reg), reg ; -#elif defined(LISP_FEATURE_LINUX) || defined(LISP_FEATURE_SUNOS) || defined(LISP_FEATURE_FREEBSD) +#elif defined(LISP_FEATURE_LINUX) || defined(LISP_FEATURE_SUNOS) || defined(LISP_FEATURE_FREEBSD) || \ + defined(LISP_FEATURE_DRAGONFLY) /* see comment in arch_os_thread_init */ # define SBCL_THREAD_BASE_EA %fs:THREAD_SELFPTR_OFFSET # define MAYBE_FS(addr) addr diff --git a/src/runtime/x86-bsd-os.c b/src/runtime/x86-bsd-os.c index fe75566..4f985fe 100644 --- a/src/runtime/x86-bsd-os.c +++ b/src/runtime/x86-bsd-os.c @@ -16,7 +16,7 @@ #endif /* LISP_FEATURE_DARWIN */ #endif -#if defined(LISP_FEATURE_FREEBSD) +#if defined(LISP_FEATURE_FREEBSD) || defined(LISP_FEATURE_DRAGONFLY) #include "machine/npx.h" #endif @@ -40,7 +40,7 @@ * entails; unfortunately, currently the situation is worse, not * better, than in the above paragraph. */ -#if defined(__FreeBSD__) || defined(__OpenBSD__) || defined(LISP_FEATURE_DARWIN) +#if defined(__FreeBSD__) || defined(__OpenBSD__) || defined(LISP_FEATURE_DARWIN) || defined(__DragonFly__) int * os_context_register_addr(os_context_t *context, int offset) { @@ -72,7 +72,7 @@ os_context_sp_addr(os_context_t *context) return (int *)CONTEXT_ADDR_FROM_STEM(esp); } -#endif /* __FreeBSD__ || __OpenBSD__ */ +#endif /* __FreeBSD__ || __OpenBSD__ || __DragonFly__ */ #ifdef __NetBSD__ int * @@ -112,7 +112,7 @@ os_context_sp_addr(os_context_t *context) int *os_context_pc_addr(os_context_t *context) { -#if defined __FreeBSD__ +#if defined(__FreeBSD__) || defined(__DragonFly__) return CONTEXT_ADDR_FROM_STEM(eip); #elif defined __OpenBSD__ return CONTEXT_ADDR_FROM_STEM(pc); @@ -264,6 +264,14 @@ os_restore_fp_control(os_context_t *context) } #endif +#if defined(LISP_FEATURE_DRAGONFLY) +void os_restore_fp_control (os_context_t *context) +{ + struct envxmm *ex = (struct envxmm *)(context->uc_mcontext.mc_fpregs); + __asm__ __volatile__ ("fldcw %0" : : "m" (ex->en_cw)); +} +#endif /* LISP_FEATURE_DRAGONFLY */ + #if defined(LISP_FEATURE_OPENBSD) void os_restore_fp_control(os_context_t *context) diff --git a/src/runtime/x86-bsd-os.h b/src/runtime/x86-bsd-os.h index dc9d9f7..cfe1409 100644 --- a/src/runtime/x86-bsd-os.h +++ b/src/runtime/x86-bsd-os.h @@ -17,7 +17,7 @@ static inline os_context_t *arch_os_get_context(void **void_context) * store signal context information, but at least they tend to use the * same stems to name the structure fields, so by using this macro we * can share a fair amount of code between different variants. */ -#if defined __FreeBSD__ +#if defined(__FreeBSD__) || defined(__DragonFly__) #define CONTEXT_ADDR_FROM_STEM(stem) &context->uc_mcontext.mc_ ## stem #elif defined(__OpenBSD__) #define CONTEXT_ADDR_FROM_STEM(stem) &context->sc_ ## stem @@ -35,7 +35,7 @@ void os_restore_tls_segment_register(os_context_t *context); void os_restore_fp_control(os_context_t *context); #endif -#if defined LISP_FEATURE_OPENBSD +#if defined(LISP_FEATURE_OPENBSD) || defined(LISP_FEATURE_DRAGONFLY) #define RESTORE_FP_CONTROL_FROM_CONTEXT void os_restore_fp_control(os_context_t *context); #endif diff --git a/tests/run-compiler.sh b/tests/run-compiler.sh index fbe1930..32bd1cd 100755 --- a/tests/run-compiler.sh +++ b/tests/run-compiler.sh @@ -37,6 +37,8 @@ while [ $# -gt 0 ]; do SunOS-SPARC) new=-fPIC ;; SunOS-X86) new=-fPIC ;; SunOS-X86-64) new=-fPIC ;; + DragonFly-X86-64)new=-fPIC ;; + DragonFly-X86) new=-fPIC ;; esac ;; diff --git a/tools-for-build/ldso-stubs.lisp b/tools-for-build/ldso-stubs.lisp index 8a76ac4..557ccfc 100644 --- a/tools-for-build/ldso-stubs.lisp +++ b/tools-for-build/ldso-stubs.lisp @@ -323,7 +323,7 @@ ldso_stub__ ## fct: ; \\ '("ptsname" #!-android "grantpt" "unlockpt") - #!+(or openbsd freebsd) + #!+(or openbsd freebsd dragonfly) '("openpty") '("dlclose" "dlerror" ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Stas B. <sta...@gm...> - 2014-06-19 16:49:08
|
"Douglas Katzman" <sn...@us...> writes: > The branch "master" has been updated in SBCL: > via 1d796c22c86e8be5e49857edb3637cc9b70d0d94 (commit) > from 758126197a609c34445dbd643f65aebb19bd602c (commit) > > - Log ----------------------------------------------------------------- > commit 1d796c22c86e8be5e49857edb3637cc9b70d0d94 > Author: Douglas Katzman <do...@go...> > Date: Wed Jun 18 22:32:25 2014 -0400 > > Derive that (INTERN x "KEYWORD") produces a KEYWORD What happens when unintern is called on x? -- With best regards, Stas. |
From: Douglas K. <sn...@us...> - 2014-06-19 13:19:01
|
The branch "master" has been updated in SBCL: via 233cf1b2e0734dc50cb96df86bdcf215f17ff626 (commit) from 9bbf8df88feefad7c362d2c620c95e6ce760aa16 (commit) - Log ----------------------------------------------------------------- commit 233cf1b2e0734dc50cb96df86bdcf215f17ff626 Author: Douglas Katzman <do...@go...> Date: Thu Jun 19 09:14:08 2014 -0400 Make -EMPTY-,-UNIVERSAL-,-WILD- types into defglobals (Renaming with double-earmuffs would be gratuitous noise.) --- src/code/late-type.lisp | 2 ++ src/code/primordial-type.lisp | 7 ++++--- src/code/typedefs.lisp | 5 +++-- src/compiler/globaldb.lisp | 9 +++------ src/compiler/macros.lisp | 2 +- 5 files changed, 13 insertions(+), 12 deletions(-) diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 5cba3f5..b0e9dc5 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -1144,6 +1144,8 @@ (frob * *wild-type*) (frob nil *empty-type*) (frob t *universal-type*) + (setf (sb!c::type-info-default (sb!c::type-info-or-lose :variable :type)) + *universal-type*) ;; new in sbcl-0.9.5: these used to be CLASSOID types, but that ;; view of them was incompatible with requirements on the MOP ;; metaobject class hierarchy: the INSTANCE and diff --git a/src/code/primordial-type.lisp b/src/code/primordial-type.lisp index 154aba2..e6c6ea1 100644 --- a/src/code/primordial-type.lisp +++ b/src/code/primordial-type.lisp @@ -13,9 +13,10 @@ ;;; use it?) (defvar *type-system-initialized* #+sb-xc-host nil) ; (set in cold load) -(defvar *wild-type*) -(defvar *empty-type*) -(defvar *universal-type*) +;; These are set by cold-init-forms in 'late-type' (look for "macrolet frob"). +(defglobal *wild-type* -1) +(defglobal *empty-type* -1) +(defglobal *universal-type* -1) (defvar *universal-fun-type*) (defvar *instance-type*) (defvar *funcallable-instance-type*) diff --git a/src/code/typedefs.lisp b/src/code/typedefs.lisp index 4e9191f..bfb0416 100644 --- a/src/code/typedefs.lisp +++ b/src/code/typedefs.lisp @@ -58,8 +58,6 @@ (setf (info :type :translator ',name) fun))) ',name)))) -;;; DEFVARs for these come later, after we have enough stuff defined. -(declaim (special *wild-type* *universal-type* *empty-type*)) (defvar *type-random-state*) @@ -81,6 +79,9 @@ (enumerable nil :read-only t) ;; an arbitrary hash code used in EQ-style hashing of identity ;; (since EQ hashing can't be done portably) + ;; In the target lisp, we could grab some bits of the address and assign + ;; them into this slot rather than use RANDOM. The object isn't created + ;; yet, so there's a chicken-and-egg issue to solve. (hash-value (random #.(ash 1 28) (if (boundp '*type-random-state*) *type-random-state* diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp index 0b69c56..5ebfff4 100644 --- a/src/compiler/globaldb.lisp +++ b/src/compiler/globaldb.lisp @@ -36,10 +36,6 @@ (!begin-collecting-cold-init-forms) #!+sb-show (!cold-init-forms (/show0 "early in globaldb.lisp cold init")) -;;; The DEFVAR for this appears later. -;;; FIXME: centralize -(declaim (special *universal-type*)) - ;;; This is sorta semantically equivalent to SXHASH, but better-behaved for ;;; legal function names. It performs more work by not cutting off as soon ;;; in the CDR direction, thereby improving the distribution of method names. @@ -474,6 +470,7 @@ (if (fboundp name) (handler-bind ((style-warning #'muffle-warning)) (specifier-type (sb!impl::%fun-type (fdefinition name)))) + ;; I think this should be *universal-fun-type* (specifier-type 'function)))) ;;; the ASSUMED-TYPE for this function, if we have to infer the type @@ -572,8 +569,8 @@ ;;; the declared type for this variable (define-info-type (:variable :type) :type-spec ctype - ;; Delay evaluation of *UNIVERSAL-TYPE* since it can't work yet - :default (lambda (x) (declare (ignore x)) *universal-type*)) + ;; This gets set to *UNIVERSAL-TYPE* in 'late-type' + :default (lambda (x) (declare (ignore x)) (error "Too early for INFO"))) ;;; where this type and kind information came from (define-info-type (:variable :where-from) diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index 20b0aa5..131eced 100644 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -11,7 +11,7 @@ (in-package "SB!C") -(declaim (special *wild-type* *universal-type* *compiler-error-context*)) +(declaim (special *compiler-error-context*)) ;;; An INLINEP value describes how a function is called. The values ;;; have these meanings: ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2014-06-19 13:01:17
|
The branch "master" has been updated in SBCL: via 9bbf8df88feefad7c362d2c620c95e6ce760aa16 (commit) from 1d796c22c86e8be5e49857edb3637cc9b70d0d94 (commit) - Log ----------------------------------------------------------------- commit 9bbf8df88feefad7c362d2c620c95e6ce760aa16 Author: Douglas Katzman <do...@go...> Date: Thu Jun 19 08:58:31 2014 -0400 Add a remark about meta-compile. --- src/compiler/knownfun.lisp | 13 +++++++++++++ 1 files changed, 13 insertions(+), 0 deletions(-) diff --git a/src/compiler/knownfun.lisp b/src/compiler/knownfun.lisp index 25b09e6..7e71ff8 100644 --- a/src/compiler/knownfun.lisp +++ b/src/compiler/knownfun.lisp @@ -270,6 +270,19 @@ ;;; shared, we copy it. We don't have to copy the lists, since each ;;; function that has generators or transforms has already been ;;; through here. +;;; +;;; Note that this operation is somewhat garbage-producing in the current +;;; globaldb implementation. Setting a piece of INFO for a name makes +;;; a shallow copy of the name's info-vector. FUN-INFO-OR-LOSE sounds +;;; like a data reader, and you might be disinclined to think that it +;;; copies at all, but: +;;; (TIME (LOOP REPEAT 1000 COUNT (FUN-INFO-OR-LOSE '*))) +;;; 294,160 bytes consed +;;; whereas just copying the info per se is not half as bad: +;;; (LET ((X (INFO :FUNCTION :INFO '*))) +;;; (TIME (LOOP REPEAT 1000 COUNT (COPY-FUN-INFO X)))) +;;; 130,992 bytes consed +;;; (declaim (ftype (sfunction (t) fun-info) fun-info-or-lose)) (defun fun-info-or-lose (name) (let ((old (info :function :info name))) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2014-06-19 12:55:32
|
The branch "master" has been updated in SBCL: via 1d796c22c86e8be5e49857edb3637cc9b70d0d94 (commit) from 758126197a609c34445dbd643f65aebb19bd602c (commit) - Log ----------------------------------------------------------------- commit 1d796c22c86e8be5e49857edb3637cc9b70d0d94 Author: Douglas Katzman <do...@go...> Date: Wed Jun 18 22:32:25 2014 -0400 Derive that (INTERN x "KEYWORD") produces a KEYWORD --- src/compiler/fndb.lisp | 3 ++- src/compiler/knownfun.lisp | 24 ++++++++++++++++++++++++ 2 files changed, 26 insertions(+), 1 deletions(-) diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 358288e..b0124ba 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -201,7 +201,8 @@ (defknown list-all-packages () list (flushable)) (defknown intern (string &optional package-designator) (values symbol (member :internal :external :inherited nil)) - ()) + () + :derive-type #'intern-derive-type) (defknown find-symbol (string &optional package-designator) (values symbol (member :internal :external :inherited nil)) (flushable)) diff --git a/src/compiler/knownfun.lisp b/src/compiler/knownfun.lisp index 9b20a6f..25b09e6 100644 --- a/src/compiler/knownfun.lisp +++ b/src/compiler/knownfun.lisp @@ -424,4 +424,28 @@ (type-union unexceptional-type null-type) unexceptional-type)))) +;; This deriver avoids a spurious call to KEYWORDP when user code +;; in a safe policy does something like: +;; (declaim (ftype (function ((or string symbol)) keyword) keywordize)) +;; (defun keywordize (x) (values (intern (string x) 'keyword))) +;; The call to INTERN is otherwise not known to produce a keyword. +(defun intern-derive-type (call) + (let* ((pkg (second (combination-args call))) + (1st-val-type + (if (and pkg + (constant-lvar-p pkg) + (string= "KEYWORD" + (let ((val (lvar-value pkg))) + (typecase val + (string val) + (package (package-name val)) + (symbol (symbol-name val)) + (t ""))))) + 'keyword + 'symbol))) + (make-values-type + :required (list (specifier-type 1st-val-type) + (specifier-type + '(member :internal :external :inherited nil)))))) + (/show0 "knownfun.lisp end of file") ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2014-06-18 22:48:57
|
The branch "master" has been updated in SBCL: via 758126197a609c34445dbd643f65aebb19bd602c (commit) from 957829d2a0092ae01d7c41bffbf9bf291b997851 (commit) - Log ----------------------------------------------------------------- commit 758126197a609c34445dbd643f65aebb19bd602c Author: Douglas Katzman <do...@go...> Date: Wed Jun 18 16:48:47 2014 -0400 Don't memoize the trivial case of a few 2-arg type functions. TYPE=, TYPE-{INTERSECTION,UNION}2, and CSUBTYPEP can test (EQ type1 type2) faster than computing the hash. --- src/code/early-extensions.lisp | 46 +++++++++++++++++++++++++++------------ src/code/late-type.lisp | 29 ++++++++++++++++-------- 2 files changed, 51 insertions(+), 24 deletions(-) diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index a631def..807c1de 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -543,9 +543,11 @@ (dolist (name *cache-vector-symbols*) (set name nil))) -(defmacro define-hash-cache (name args &key hash-function hash-bits default +(defmacro define-hash-cache (name args + &key hash-function hash-bits memoizer default (init-wrapper 'progn) (values 1)) + (declare (ignore memoizer)) (let* ((var-name (symbolicate "**" name "-CACHE-VECTOR**")) (statistics-name (when *profile-hash-cache* (symbolicate "**" name "-CACHE-STATISTICS**"))) @@ -663,7 +665,20 @@ ;;; some syntactic sugar for defining a function whose values are ;;; cached by DEFINE-HASH-CACHE +;;; These keywords are mostly defined at DEFINE-HASH-CACHE. +;;; Additional options: +;;; :MEMOIZER <name> +;;; If provided, it is the name of a local macro that must be called +;;; within the body forms to perform cache lookup/insertion. +;;; If not provided, then the function's behavior is to automatically +;;; attempt cache lookup, and on miss, execute the body code and +;;; insert into the cache. +;;; Manual control over memoization is useful if there are cases for +;;; which computing the result is simpler than cache lookup. + (defmacro defun-cached ((name &rest options &key (values 1) default + (memoizer (make-symbol "MEMOIZE") + memoizer-supplied-p) &allow-other-keys) args &body body-decls-doc) (let ((default-values (if (and (consp default) (eq (car default) 'values)) @@ -671,13 +686,15 @@ (list default))) (arg-names (mapcar #'car args)) (values-names (make-gensym-list values))) + ;; What I wouldn't give to be able to use BINDING*, right? (multiple-value-bind (body decls doc) (parse-body body-decls-doc) `(progn (define-hash-cache ,name ,args ,@options) (defun ,name ,arg-names ,@decls - ,doc - (cond #!+sb-show + ,@(if doc (list doc)) + (macrolet ((,memoizer (&body body) + `(cond #!+sb-show ((not (boundp '*hash-caches-initialized-p*)) ;; This shouldn't happen, but it did happen to me ;; when revising the type system, and it's a lot @@ -692,17 +709,18 @@ (/hexstr ,(first arg-names)) ,@body) (t - (multiple-value-bind ,values-names - (,(symbolicate name "-CACHE-LOOKUP") ,@arg-names) - (if (and ,@(mapcar (lambda (val def) - `(eq ,val ,def)) - values-names default-values)) - (multiple-value-bind ,values-names - (progn ,@body) - (,(symbolicate name "-CACHE-ENTER") ,@arg-names - ,@values-names) - (values ,@values-names)) - (values ,@values-names)))))))))) + (multiple-value-bind ,',values-names + ,'(,(symbolicate name "-CACHE-LOOKUP") ,@arg-names) + (if ,'(and ,@(mapcar (lambda (val def) `(eq ,val ,def)) + values-names default-values)) + (multiple-value-bind ,',values-names (progn ,@body) + ,'(,(symbolicate name "-CACHE-ENTER") ,@arg-names + ,@values-names) + (values ,@',values-names)) + (values ,@',values-names))))))) + ,@(if memoizer-supplied-p + body + `((,memoizer ,@body))))))))) (defmacro define-cached-synonym (name &optional (original (symbolicate "%" name))) diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 6e6de63..5cba3f5 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -798,6 +798,7 @@ ;;; like SUBTYPEP, only works on CTYPE structures (defun-cached (csubtypep :hash-function #'type-cache-hash :hash-bits 10 + :memoizer memoize :values 2 :default (values nil :empty) :init-wrapper !cold-init-forms) @@ -811,9 +812,10 @@ ((eq type1 *universal-type*) (values nil t)) (t - (!invoke-type-method :simple-subtypep :complex-subtypep-arg2 - type1 type2 - :complex-arg1 :complex-subtypep-arg1)))) + (memoize + (!invoke-type-method :simple-subtypep :complex-subtypep-arg2 + type1 type2 + :complex-arg1 :complex-subtypep-arg1))))) ;;; Just parse the type specifiers and call CSUBTYPE. (defun sb!xc:subtypep (type1 type2 &optional environment) @@ -830,6 +832,7 @@ ;;; This should only fail in the presence of HAIRY types. (defun-cached (type= :hash-function #'type-cache-hash :hash-bits 11 + :memoizer memoize :values 2 :default (values nil :empty) :init-wrapper !cold-init-forms) @@ -837,7 +840,7 @@ (declare (type ctype type1 type2)) (if (eq type1 type2) (values t t) - (!invoke-type-method :simple-= :complex-= type1 type2))) + (memoize (!invoke-type-method :simple-= :complex-= type1 type2)))) ;;; Not exactly the negation of TYPE=, since when the relationship is ;;; uncertain, we still return NIL, NIL. This is useful in cases where @@ -872,6 +875,7 @@ ;;; unless we find no other way to represent the result. (defun-cached (type-union2 :hash-function #'type-cache-hash :hash-bits 8 + :memoizer memoize :init-wrapper !cold-init-forms) ((type1 eq) (type2 eq)) ;; KLUDGE: This was generated from TYPE-INTERSECTION2 by Ye Olde Cut And @@ -880,8 +884,10 @@ ;; should probably become shared code. -- WHN 2001-03-16 (declare (type ctype type1 type2)) (let ((t2 nil)) - (cond ((eq type1 type2) - type1) + (if (eq type1 type2) + type1 + (memoize + (cond ;; CSUBTYPEP for array-types answers questions about the ;; specialized type, yet for union we want to take the ;; expressed type in account too. @@ -897,7 +903,7 @@ (type-union type1 type2)) (t ;; the ordinary case: we dispatch to type methods - (%type-union2 type1 type2))))) + (%type-union2 type1 type2))))))) ;;; the type method dispatch case of TYPE-INTERSECTION2 (defun %type-intersection2 (type1 type2) @@ -934,16 +940,19 @@ (defun-cached (type-intersection2 :hash-function #'type-cache-hash :hash-bits 9 + :memoizer memoize :values 1 :default nil :init-wrapper !cold-init-forms) ((type1 eq) (type2 eq)) (declare (type ctype type1 type2)) - (cond ((eq type1 type2) + (if (eq type1 type2) ;; FIXME: For some reason, this doesn't catch e.g. type1 = ;; type2 = (SPECIFIER-TYPE ;; 'SOME-UNKNOWN-TYPE). Investigate. - CSR, 2002-04-10 - type1) + type1 + (memoize + (cond ((or (intersection-type-p type1) (intersection-type-p type2)) ;; Intersections of INTERSECTION-TYPE should have the @@ -953,7 +962,7 @@ (type-intersection type1 type2)) (t ;; the ordinary case: we dispatch to type methods - (%type-intersection2 type1 type2)))) + (%type-intersection2 type1 type2)))))) ;;; Return as restrictive and simple a type as we can discover that is ;;; no more restrictive than the intersection of TYPE1 and TYPE2. At ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: stassats <sta...@us...> - 2014-06-18 20:41:38
|
The branch "master" has been updated in SBCL: via 957829d2a0092ae01d7c41bffbf9bf291b997851 (commit) from 7cdaadca09ba71e5642ae22b8414fe49ea1487fd (commit) - Log ----------------------------------------------------------------- commit 957829d2a0092ae01d7c41bffbf9bf291b997851 Author: Stas Boukarev <sta...@gm...> Date: Thu Jun 19 00:21:48 2014 +0400 Optimize assembly/x86-64/arith.lisp. Mostly dealing with fixnum type checking. --- src/assembly/x86-64/arith.lisp | 46 ++++++++++++++++++++++----------------- 1 files changed, 26 insertions(+), 20 deletions(-) diff --git a/src/assembly/x86-64/arith.lisp b/src/assembly/x86-64/arith.lisp index 6a1fe24..441925f 100644 --- a/src/assembly/x86-64/arith.lisp +++ b/src/assembly/x86-64/arith.lisp @@ -10,6 +10,23 @@ ;;;; files for more information. (in-package "SB!VM") + +(defun !both-fixnum-p (temp x y) + (inst mov (reg-in-size temp :dword) + (reg-in-size x :dword)) + (inst or (reg-in-size temp :dword) + (reg-in-size y :dword)) + (inst test (reg-in-size temp :byte) + fixnum-tag-mask)) + +(defun !some-fixnum-p (temp x y) + (inst mov (reg-in-size temp :dword) + (reg-in-size x :dword)) + (inst and (reg-in-size temp :dword) + (reg-in-size y :dword)) + (inst test (reg-in-size temp :byte) + fixnum-tag-mask)) + ;;;; addition, subtraction, and multiplication @@ -27,10 +44,7 @@ (:temp rax unsigned-reg rax-offset) (:temp rcx unsigned-reg rcx-offset)) - - (inst mov rcx x) - (inst or rcx y) - (inst test rcx fixnum-tag-mask) ; both fixnums? + (!both-fixnum-p rax x y) (inst jmp :nz DO-STATIC-FUN) ; no - do generic ,@body @@ -129,12 +143,12 @@ (:temp rax unsigned-reg rax-offset) (:temp rcx unsigned-reg rcx-offset)) - (inst test x fixnum-tag-mask) + (inst test (reg-in-size x :byte) fixnum-tag-mask) (inst jmp :z FIXNUM) (inst push rbp-tn) (inst mov rbp-tn rsp-tn) - (inst sub rsp-tn (* n-word-bytes 1)) + (inst sub rsp-tn n-word-bytes) (inst push (make-ea :qword :base rbp-tn :disp (frame-byte-offset return-pc-save-offset))) (inst mov rcx (fixnumize 1)) ; arg count @@ -165,10 +179,8 @@ (:temp rcx unsigned-reg rcx-offset)) - (inst mov rcx x) - (inst or rcx y) - (inst test rcx fixnum-tag-mask) - (inst jmp :nz DO-STATIC-FUN) ; are both fixnums? + (!both-fixnum-p rcx x y) + (inst jmp :nz DO-STATIC-FUN) (inst cmp x y) (inst ret) @@ -236,9 +248,7 @@ (:temp rcx unsigned-reg rcx-offset)) - (inst mov rcx x) - (inst and rcx y) - (inst test rcx fixnum-tag-mask) + (!some-fixnum-p rcx x y) (inst jmp :nz DO-STATIC-FUN) ;; At least one fixnum @@ -263,8 +273,7 @@ (inst mov rcx (fixnumize 2)) (inst call (make-ea :qword :disp (+ nil-value (static-fun-offset 'eql)))) - (load-symbol y t) - (inst cmp x y) + (inst cmp x (+ nil-value (static-symbol-offset t))) (inst pop rbp-tn) (inst ret)) @@ -300,9 +309,7 @@ (:arg y (descriptor-reg any-reg) rdi-offset) (:temp rcx unsigned-reg rcx-offset)) - (inst mov rcx x) - (inst or rcx y) - (inst test rcx fixnum-tag-mask) + (!both-fixnum-p rcx x y) (inst jmp :nz DO-STATIC-FUN) ;; Both fixnums @@ -328,8 +335,7 @@ (inst mov rcx (fixnumize 2)) (inst call (make-ea :qword :disp (+ nil-value (static-fun-offset 'two-arg-=)))) - (load-symbol y t) - (inst cmp x y) + (inst cmp x (+ nil-value (static-symbol-offset t))) (inst pop rbp-tn) (inst ret)) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Alastair B. <ala...@gm...> - 2014-06-18 19:26:01
|
Speaking of, almost anything in the gray stream interface which is declared (in SBCL) to return BOOLEAN probably shouldn't be (STREAM-DEFINITION-BY-USER says "true or false", and the CLHS for the corresponding CL functions says "generalized boolean"). With certain policies, this leads to typechecks being emitted on the calling side, causing strange errors. On Wed, Jun 18, 2014 at 1:45 PM, Stas Boukarev <sta...@gm...> wrote: > "Douglas Katzman" <sn...@us...> writes: > > > The branch "master" has been updated in SBCL: > > via 7cdaadca09ba71e5642ae22b8414fe49ea1487fd (commit) > > from 214b674f931b44ef389462a2351af0f668ab9c3c (commit) > > > > - Log ----------------------------------------------------------------- > > commit 7cdaadca09ba71e5642ae22b8414fe49ea1487fd > > Author: Douglas Katzman <do...@go...> > > Date: Wed Jun 18 12:22:02 2014 -0400 > > > > Add some type-derivers > What happens when a method for sb-gray:stream-read-char doesn't return a > character? > -- > With best regards, Stas. > > > ------------------------------------------------------------------------------ > HPCC Systems Open Source Big Data Platform from LexisNexis Risk Solutions > Find What Matters Most in Your Big Data with HPCC Systems > Open Source. Fast. Scalable. Simple. Ideal for Dirty Data. > Leverages Graph Analysis for Fast Processing & Easy Data Exploration > http://p.sf.net/sfu/hpccsystems > _______________________________________________ > Sbcl-devel mailing list > Sbc...@li... > https://lists.sourceforge.net/lists/listinfo/sbcl-devel > |
From: Stas B. <sta...@gm...> - 2014-06-18 17:45:42
|
"Douglas Katzman" <sn...@us...> writes: > The branch "master" has been updated in SBCL: > via 7cdaadca09ba71e5642ae22b8414fe49ea1487fd (commit) > from 214b674f931b44ef389462a2351af0f668ab9c3c (commit) > > - Log ----------------------------------------------------------------- > commit 7cdaadca09ba71e5642ae22b8414fe49ea1487fd > Author: Douglas Katzman <do...@go...> > Date: Wed Jun 18 12:22:02 2014 -0400 > > Add some type-derivers What happens when a method for sb-gray:stream-read-char doesn't return a character? -- With best regards, Stas. |
From: Douglas K. <sn...@us...> - 2014-06-18 16:46:06
|
The branch "master" has been updated in SBCL: via 7cdaadca09ba71e5642ae22b8414fe49ea1487fd (commit) from 214b674f931b44ef389462a2351af0f668ab9c3c (commit) - Log ----------------------------------------------------------------- commit 7cdaadca09ba71e5642ae22b8414fe49ea1487fd Author: Douglas Katzman <do...@go...> Date: Wed Jun 18 12:22:02 2014 -0400 Add some type-derivers --- src/compiler/fndb.lisp | 20 +++++++++++++++----- src/compiler/knownfun.lisp | 22 ++++++++++++++++++++++ 2 files changed, 37 insertions(+), 5 deletions(-) diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index ea9f2c4..358288e 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -1124,19 +1124,28 @@ ()) ;;; may return any type due to eof-value... -(defknown (read read-preserving-whitespace read-char-no-hang read-char) +;;; and because READ generally returns anything. +(defknown (read read-preserving-whitespace) (&optional stream-designator t t t) t (explicit-check)) +(defknown read-char (&optional stream-designator t t t) t (explicit-check) + :derive-type (read-elt-type-deriver nil 'character nil)) +(defknown read-char-no-hang (&optional stream-designator t t t) t + (explicit-check) + :derive-type (read-elt-type-deriver nil 'character t)) + (defknown read-delimited-list (character &optional stream-designator t) list (explicit-check)) +;; FIXME: add a type-deriver => (values (or string eof-value) boolean) (defknown read-line (&optional stream-designator t t t) (values t boolean) (explicit-check)) (defknown unread-char (character &optional stream-designator) t (explicit-check)) (defknown peek-char (&optional (or character (member nil t)) - stream-designator t t t) - t - (explicit-check)) + stream-designator t t t) t + (explicit-check) + :derive-type (read-elt-type-deriver t 'character nil)) + (defknown listen (&optional stream-designator) boolean (flushable explicit-check)) (defknown clear-input (&optional stream-designator) null (explicit-check)) @@ -1156,7 +1165,8 @@ (:junk-allowed t)) (values (or integer null ()) index)) -(defknown read-byte (stream &optional t t) t (explicit-check)) +(defknown read-byte (stream &optional t t) t (explicit-check) + :derive-type (read-elt-type-deriver nil 'integer nil)) (defknown (prin1 print princ) (t &optional stream-designator) t diff --git a/src/compiler/knownfun.lisp b/src/compiler/knownfun.lisp index 815c042..9b20a6f 100644 --- a/src/compiler/knownfun.lisp +++ b/src/compiler/knownfun.lisp @@ -402,4 +402,26 @@ (push (car list) result)))) (setf indices (cdr indices))))))) +(defun read-elt-type-deriver (skip-arg-p element-type-spec no-hang) + (lambda (call) + (let* ((element-type (specifier-type element-type-spec)) + (null-type (specifier-type 'null)) + (err-args (if skip-arg-p ; for PEEK-CHAR, skip 'peek-type' + 'stream' + (cddr (combination-args call)) + (cdr (combination-args call)))) ; else just 'stream' + (eof-error-p (first err-args)) + (eof-value (second err-args)) + (unexceptional-type ; the normally returned thing + (if (and eof-error-p + (types-equal-or-intersect (lvar-type eof-error-p) + null-type)) + ;; (READ-elt stream nil <x>) returns (OR (EQL <x>) elt-type) + (type-union (if eof-value (lvar-type eof-value) null-type) + element-type) + ;; If eof-error is unsupplied, or was but couldn't be nil + element-type))) + (if no-hang + (type-union unexceptional-type null-type) + unexceptional-type)))) + (/show0 "knownfun.lisp end of file") ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2014-06-18 16:45:58
|
The branch "master" has been updated in SBCL: via 214b674f931b44ef389462a2351af0f668ab9c3c (commit) from efc7996bdb3faec37fee01ba9d34a3fbf12399b3 (commit) - Log ----------------------------------------------------------------- commit 214b674f931b44ef389462a2351af0f668ab9c3c Author: Douglas Katzman <do...@go...> Date: Wed Jun 18 12:13:36 2014 -0400 Advise compiler that *{HANDLER,RESTART}-CLUSTERS* are always-bound. --- src/code/defboot.lisp | 12 ++++++++++++ 1 files changed, 12 insertions(+), 0 deletions(-) diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index d803866..636184f 100644 --- a/src/code/defboot.lisp +++ b/src/code/defboot.lisp @@ -424,6 +424,18 @@ evaluated as a PROGN." ;;; target-error.lisp. (sb!xc:proclaim '(special *handler-clusters* *restart-clusters*)) +;;; Generated code need not check for unbound-marker in *HANDLER-CLUSTERS* +;;; (resp *RESTART-). To elicit this we must poke at the info db. +;;; SB!XC:PROCLAIM SPECIAL doesn't advise the host Lisp that *HANDLER-CLUSTERS* +;;; is special and so it rightfully complains about a SETQ of the variable. +;;; But I must SETQ if proclaming ALWAYS-BOUND because the xc asks the host +;;; whether it's currently bound. +;;; But the DEFVARs are in target-error. So it's one hack or another. +(setf (info :variable :always-bound '*handler-clusters*) + #+sb-xc :always-bound #-sb-xc :eventually) +(setf (info :variable :always-bound '*restart-clusters*) + #+sb-xc :always-bound #-sb-xc :eventually) + (defmacro-mundanely with-condition-restarts (condition-form restarts-form &body body) #!+sb-doc ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: stassats <sta...@us...> - 2014-06-18 16:15:20
|
The branch "master" has been updated in SBCL: via efc7996bdb3faec37fee01ba9d34a3fbf12399b3 (commit) from 478ca18003ab9e6bcfdb92de36c8d69c4826bd82 (commit) - Log ----------------------------------------------------------------- commit efc7996bdb3faec37fee01ba9d34a3fbf12399b3 Author: Stas Boukarev <sta...@gm...> Date: Wed Jun 18 20:14:24 2014 +0400 Fix a GC assert error message. It was using %l for printing a number, change it to %ld. --- src/runtime/gc-common.c | 2 +- src/runtime/runtime.h | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/runtime/gc-common.c b/src/runtime/gc-common.c index 11ef7f9..fabad80 100644 --- a/src/runtime/gc-common.c +++ b/src/runtime/gc-common.c @@ -126,7 +126,7 @@ scavenge(lispobj *start, sword_t n_words) lispobj object = *object_ptr; #ifdef LISP_FEATURE_GENCGC if (forwarding_pointer_p(object_ptr)) - lose("unexpect forwarding pointer in scavenge: %p, start=%p, n=%l\n", + lose("unexpect forwarding pointer in scavenge: %p, start=%p, n=%ld\n", object_ptr, start, n_words); #endif if (is_lisp_pointer(object)) { diff --git a/src/runtime/runtime.h b/src/runtime/runtime.h index d9d9328..5a3d7ab 100644 --- a/src/runtime/runtime.h +++ b/src/runtime/runtime.h @@ -339,7 +339,7 @@ fixnum_word_value(lispobj n) { /* Convert bytes into words, double-word aligned. */ sword_t x = ((n >> N_FIXNUM_TAG_BITS) + LOWTAG_MASK) & ~LOWTAG_MASK; - + return x >> WORD_SHIFT; } ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2014-06-18 05:30:54
|
The branch "master" has been updated in SBCL: via 478ca18003ab9e6bcfdb92de36c8d69c4826bd82 (commit) from 42a3ceb22f8e6b14a49162e358229d995b34a9fa (commit) - Log ----------------------------------------------------------------- commit 478ca18003ab9e6bcfdb92de36c8d69c4826bd82 Author: Douglas Katzman <do...@go...> Date: Wed Jun 18 00:38:13 2014 -0400 Reconcile error messages between {MAKE,ADJUST}-ARRAY. Due to ADJUST-ARRAY's guts being extremely confusing, this code tries to perform more checks up front and re-orders them to be more user-friendly. There was no obvious reason why one place should say "~S is not an array with a fill-pointer" and another "~S is not of type (SATISFIES ARRAY-HAS-FILL-POINTER-P)". or :INITIAL-CONTENTS may not be specified with the :INITIAL-ELEMENT or :DISPLACED-TO option. vs Neither :INITIAL-ELEMENT nor :INITIAL-CONTENTS can be specified along with :DISPLACED-TO So those messages are more uniform now, and as a bonus, DATA-VECTOR-FROM-INITS takes only 7 args intead of 9. --- src/code/array.lisp | 139 +++++++++++++++++++++++------------------------ src/compiler/fndb.lisp | 13 ++++- tests/array.pure.lisp | 13 +++++ 3 files changed, 91 insertions(+), 74 deletions(-) diff --git a/src/code/array.lisp b/src/code/array.lisp index 4fe113e..04ebb82 100644 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@ -346,6 +346,21 @@ (let ((widetag (%other-pointer-widetag array))) (make-case)))) +;; Complain in various ways about wrong :INITIAL-foo arguments, +;; returning the two initialization arguments needed for DATA-VECTOR-FROM-INITS. +(defun validate-array-initargs (element-p element contents-p contents displaced) + (cond ((and displaced (or element-p contents-p)) + (if (and element-p contents-p) + (error "Neither :INITIAL-ELEMENT nor :INITIAL-CONTENTS ~ + may be specified with the :DISPLACED-TO option") + (error "~S may not be specified with the :DISPLACED-TO option" + (if element-p :initial-element :initial-contents)))) + ((and element-p contents-p) + (error "Can't specify both :INITIAL-ELEMENT and :INITIAL-CONTENTS")) + (element-p (values :initial-element element)) + (contents-p (values :initial-contents contents)) + (t (values nil nil)))) + ;;; Widetag is the widetag of the underlying vector, ;;; it'll be the same as the resulting array widetag only for simple vectors (defun %make-array (dimensions widetag n-bits @@ -356,12 +371,16 @@ adjustable fill-pointer displaced-to displaced-index-offset) (declare (ignore element-type)) - (let* ((dimensions (if (listp dimensions) dimensions (list dimensions))) - (array-rank (length (the list dimensions))) - (simple (and (null fill-pointer) - (not adjustable) - (null displaced-to)))) - (declare (fixnum array-rank)) + (binding* ((dimensions (if (listp dimensions) dimensions (list dimensions))) + (array-rank (length (the list dimensions))) + ((initialize initial-data) + (validate-array-initargs initial-element-p initial-element + initial-contents-p initial-contents + displaced-to)) + (simple (and (null fill-pointer) + (not adjustable) + (null displaced-to)))) + (declare (type array-rank array-rank)) (cond ((and displaced-index-offset (null displaced-to)) (error "can't specify :DISPLACED-INDEX-OFFSET without :DISPLACED-TO")) ((and simple (= array-rank 1)) @@ -372,9 +391,6 @@ (when initial-element-p (fill array initial-element)) (when initial-contents-p - (when initial-element-p - (error "can't specify both :INITIAL-ELEMENT and ~ - :INITIAL-CONTENTS")) (unless (= length (length initial-contents)) (error "There are ~W elements in the :INITIAL-CONTENTS, but ~ the vector length is ~W." @@ -391,8 +407,7 @@ (data (or displaced-to (data-vector-from-inits dimensions total-size nil widetag n-bits - initial-contents initial-contents-p - initial-element initial-element-p))) + initialize initial-data))) (array (make-array-header (cond ((= array-rank 1) (%complex-vector-widetag widetag)) @@ -407,13 +422,11 @@ (setf (%array-fill-pointer array) (cond ((eq fill-pointer t) length) - (t - (unless (and (fixnump fill-pointer) - (>= fill-pointer 0) - (<= fill-pointer length)) + ((not (<= fill-pointer length)) ;; FIXME: should be TYPE-ERROR? (error "invalid fill-pointer ~W" fill-pointer)) + (t fill-pointer)))) (setf (%array-fill-pointer-p array) t)) (t @@ -423,9 +436,6 @@ (setf (%array-data-vector array) data) (setf (%array-displaced-from array) nil) (cond (displaced-to - (when (or initial-element-p initial-contents-p) - (error "Neither :INITIAL-ELEMENT nor :INITIAL-CONTENTS ~ - can be specified along with :DISPLACED-TO")) (let ((offset (or displaced-index-offset 0))) (when (> (+ offset total-size) (array-total-size displaced-to)) @@ -469,9 +479,9 @@ of specialized arrays is supported." (when (eq t (upgraded-array-element-type element-type)) (error "Static arrays of type ~S not supported." element-type)) + (validate-array-initargs initial-element-p initial-element + initial-contents-p initial-contents nil) ; for effect (when initial-contents-p - (when initial-element-p - (error "can't specify both :INITIAL-ELEMENT and :INITIAL-CONTENTS")) (unless (= length (length initial-contents)) (error "There are ~W elements in the :INITIAL-CONTENTS, but the ~ vector length is ~W." @@ -506,25 +516,19 @@ of specialized arrays is supported." ;;; initial-contents. (defun data-vector-from-inits (dimensions total-size element-type widetag n-bits - initial-contents initial-contents-p - initial-element initial-element-p) - (when initial-element-p - (when initial-contents-p - (error "cannot supply both :INITIAL-CONTENTS and :INITIAL-ELEMENT to - either MAKE-ARRAY or ADJUST-ARRAY.")) + initialize initial-data) ;; FIXME: element-type can be NIL when widetag is non-nil, ;; and FILL will check the type, although the error will be not as nice. ;; (cond (typep initial-element element-type) ;; (error "~S cannot be used to initialize an array of type ~S." ;; initial-element element-type)) - ) (let ((data (if widetag (allocate-vector-with-widetag widetag total-size n-bits) (make-array total-size :element-type element-type)))) - (cond (initial-element-p - (fill (the vector data) initial-element)) - (initial-contents-p - (fill-data-vector data dimensions initial-contents))) + (ecase initialize + (:initial-element (fill (the vector data) initial-data)) + (:initial-contents (fill-data-vector data dimensions initial-data)) + ((nil))) data)) (defun vector (&rest objects) @@ -1055,33 +1059,36 @@ of specialized arrays is supported." "Adjust ARRAY's dimensions to the given DIMENSIONS and stuff." (when (invalid-array-p array) (invalid-array-error array)) - (let ((dimensions (if (listp dimensions) dimensions (list dimensions)))) - (cond ((/= (the fixnum (length (the list dimensions))) - (the fixnum (array-rank array))) - (error "The number of dimensions not equal to rank of array.")) - ((and element-type-p + (binding* ((dimensions (if (listp dimensions) dimensions (list dimensions))) + (array-rank (array-rank array)) + (() + (unless (= (length dimensions) array-rank) + (error "The number of dimensions not equal to rank of array."))) + ((initialize initial-data) + (validate-array-initargs initial-element-p initial-element + initial-contents-p initial-contents + displaced-to))) + (cond ((and element-type-p (not (subtypep element-type (array-element-type array)))) + ;; This is weird. Should check upgraded type against actual + ;; array element type I think. See lp#1331299. CLHS says that + ;; "consequences are unspecified" so current behavior isn't wrong. (error "The new element type, ~S, is incompatible with old type." element-type)) + ((and fill-pointer (/= array-rank 1)) + (error "Only vectors can have fill pointers.")) ((and fill-pointer (not (array-has-fill-pointer-p array))) - (error 'type-error - :datum array - :expected-type '(satisfies array-has-fill-pointer-p)))) - (let ((array-rank (length (the list dimensions)))) - (declare (fixnum array-rank)) - (unless (= array-rank 1) - (when fill-pointer - (error "Only vectors can have fill pointers."))) - (cond (initial-contents-p + ;; This case always struck me as odd. It seems like it might mean + ;; that the user asks that the array gain a fill-pointer if it didn't + ;; have one, yet CLHS is clear that the argument array must have a + ;; fill-pointer or else signal a type-error. + (fill-pointer-error array))) + (cond (initial-contents-p ;; array former contents replaced by INITIAL-CONTENTS - (if (or initial-element-p displaced-to) - (error ":INITIAL-CONTENTS may not be specified with ~ - the :INITIAL-ELEMENT or :DISPLACED-TO option.")) (let* ((array-size (apply #'* dimensions)) (array-data (data-vector-from-inits dimensions array-size element-type nil nil - initial-contents initial-contents-p - initial-element initial-element-p))) + initialize initial-data))) (if (adjustable-array-p array) (set-array-header array array-data array-size (get-new-fill-pointer array array-size @@ -1093,12 +1100,10 @@ of specialized arrays is supported." :element-type element-type :initial-contents initial-contents) array-data)))) - (displaced-to + (displaced-to ;; We already established that no INITIAL-CONTENTS was supplied. - (when initial-element - (error "The :INITIAL-ELEMENT option may not be specified ~ - with :DISPLACED-TO.")) (unless (subtypep element-type (array-element-type displaced-to)) + ;; See lp#1331299 again. Require exact match on upgraded type? (error "can't displace an array of type ~S into another of ~ type ~S" element-type (array-element-type displaced-to))) @@ -1120,7 +1125,7 @@ of specialized arrays is supported." :displaced-to displaced-to :displaced-index-offset displaced-index-offset)))) - ((= array-rank 1) + ((= array-rank 1) (let ((old-length (array-total-size array)) (new-length (car dimensions)) new-data) @@ -1134,8 +1139,7 @@ of specialized arrays is supported." (data-vector-from-inits dimensions new-length element-type (%other-pointer-widetag old-data) nil - initial-contents initial-contents-p - initial-element initial-element-p)) + initialize initial-data)) ;; Provide :END1 to avoid full call to LENGTH ;; inside REPLACE. (replace new-data old-data @@ -1149,7 +1153,7 @@ of specialized arrays is supported." fill-pointer) 0 dimensions nil nil) new-data)))) - (t + (t (let ((old-length (%array-available-elements array)) (new-length (apply #'* dimensions))) (declare (fixnum old-length new-length)) @@ -1163,8 +1167,8 @@ of specialized arrays is supported." dimensions new-length element-type (%other-pointer-widetag old-data) nil - () nil - initial-element initial-element-p) + (if initial-element-p :initial-element) + initial-element) old-data))) (if (or (zerop old-length) (zerop new-length)) (when initial-element-p (fill new-data initial-element)) @@ -1180,23 +1184,19 @@ of specialized arrays is supported." (make-array-header sb!vm:simple-array-widetag array-rank))) (set-array-header new-array new-data new-length - nil 0 dimensions nil t))))))))))) + nil 0 dimensions nil t)))))))))) (defun get-new-fill-pointer (old-array new-array-size fill-pointer) (cond ((not fill-pointer) + ;; "The consequences are unspecified if array is adjusted to a + ;; size smaller than its fill pointer ..." (when (array-has-fill-pointer-p old-array) (when (> (%array-fill-pointer old-array) new-array-size) (error "cannot ADJUST-ARRAY an array (~S) to a size (~S) that is ~ smaller than its fill pointer (~S)" old-array new-array-size (fill-pointer old-array))) (%array-fill-pointer old-array))) - ((not (array-has-fill-pointer-p old-array)) - (error "cannot supply a non-NIL value (~S) for :FILL-POINTER ~ - in ADJUST-ARRAY unless the array (~S) was originally ~ - created with a fill pointer" - fill-pointer - old-array)) ((numberp fill-pointer) (when (> fill-pointer new-array-size) (error "can't supply a value for :FILL-POINTER (~S) that is larger ~ @@ -1204,10 +1204,7 @@ of specialized arrays is supported." fill-pointer new-array-size)) fill-pointer) ((eq fill-pointer t) - new-array-size) - (t - (error "bogus value for :FILL-POINTER in ADJUST-ARRAY: ~S" - fill-pointer)))) + new-array-size))) ;;; Destructively alter VECTOR, changing its length to NEW-LENGTH, ;;; which must be less than or equal to its current length. This can diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 57079c6..ea9f2c4 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -886,7 +886,9 @@ (:initial-element t) (:initial-contents t) (:adjustable t) - (:fill-pointer t) + ;; the type constraint doesn't do anything + ;; on account of EXPLICIT-CHECK. it's documentation. + (:fill-pointer (or index boolean)) (:displaced-to (or array null)) (:displaced-index-offset index)) array (flushable explicit-check)) @@ -899,7 +901,7 @@ (:initial-element t) (:initial-contents t) (:adjustable t) - (:fill-pointer t) + (:fill-pointer (or index boolean)) (:displaced-to (or array null)) (:displaced-index-offset index)) array (flushable)) @@ -913,6 +915,10 @@ type-specifier (foldable flushable recursive)) (defknown array-rank (array) array-rank (foldable flushable)) +;; FIXME: there's a fencepost bug, but for all practical purposes our +;; ARRAY-RANK-LIMIT is infinite, thus masking the bug. e.g. if the +;; exclusive limit on rank were 8, then your dimension numbers can +;; be in the range 0 through 6, not 0 through 7. (defknown array-dimension (array array-rank) index (foldable flushable)) (defknown array-dimensions (array) list (foldable flushable)) (defknown array-in-bounds-p (array &rest integer) boolean (foldable flushable)) @@ -963,7 +969,8 @@ (defknown adjust-array (array (or index list) &key (:element-type type-specifier) (:initial-element t) (:initial-contents t) - (:fill-pointer t) (:displaced-to (or array null)) + (:fill-pointer (or index boolean)) + (:displaced-to (or array null)) (:displaced-index-offset index)) array ()) ; :derive-type 'result-type-arg1) Not even close... diff --git a/tests/array.pure.lisp b/tests/array.pure.lisp index 93f6955..9d4332d 100644 --- a/tests/array.pure.lisp +++ b/tests/array.pure.lisp @@ -298,3 +298,16 @@ t) (:no-error (&rest args) nil)))) + +(with-test (:name :dont-make-array-bad-keywords) + ;; This used to get a heap exhaustion error because of trying + ;; to make the array before checking keyword validity. + (handler-case + (locally + (declare (notinline make-array)) + (make-array (1- array-total-size-limit) + :initial-contents '(a b c) :initial-element 9)) + (simple-error (c) + (assert + (string= (simple-condition-format-control c) + "Can't specify both :INITIAL-ELEMENT and :INITIAL-CONTENTS"))))) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2014-06-18 02:58:49
|
The branch "master" has been updated in SBCL: via 42a3ceb22f8e6b14a49162e358229d995b34a9fa (commit) from 4b770969853f2548e6f1505ba30ff2d92e72e3b5 (commit) - Log ----------------------------------------------------------------- commit 42a3ceb22f8e6b14a49162e358229d995b34a9fa Author: Douglas Katzman <do...@go...> Date: Tue Jun 17 22:38:12 2014 -0400 Improve cache hit rate for some memoized functions. TYPE= and CSUBTYPEP forced eviction another entry at least 70% to 80% of the time. Enlarging them fixed that. Also we now choose (arbitrarily) one of two possible lines for any cache entry, giving another slight performance boost. The :hash-function specified in DEFUN-CACHED must not perform masking any more. It's done automatically. --- make-host-2.lisp | 27 ++++++++ src/code/early-extensions.lisp | 121 +++++++++++++++++++++++++---------- src/code/early-type.lisp | 14 ++-- src/code/late-type.lisp | 42 +++++-------- src/code/target-type.lisp | 2 +- src/code/typedefs.lisp | 23 +++---- src/compiler/checkgen.lisp | 4 +- src/compiler/generic/primtype.lisp | 3 +- 8 files changed, 148 insertions(+), 88 deletions(-) diff --git a/make-host-2.lisp b/make-host-2.lisp index df05559..aca0cce 100644 --- a/make-host-2.lisp +++ b/make-host-2.lisp @@ -95,6 +95,33 @@ (not (gethash spec sb!c::*checkgen-used-types*))) do (format t " ~S~%" spec))) +;; Print some information about how well the function caches performed +(when sb!impl::*profile-hash-cache* + (sb!impl::show-hash-cache-statistics)) +#| +Sample output +------------- + Seek Hit (%) Evict (%) Size full + 23698219 18382256 ( 77.6%) 5313915 ( 22.4%) 2048 100.0% TYPE=-CACHE + 23528751 23416735 ( 99.5%) 46242 ( 0.2%) 1024 20.1% VALUES-SPECIFIER-TYPE-CACHE + 16755212 13072420 ( 78.0%) 3681768 ( 22.0%) 1024 100.0% CSUBTYPEP-CACHE + 9913114 8374965 ( 84.5%) 1537893 ( 15.5%) 256 100.0% MAKE-VALUES-TYPE-CACHED-CACHE + 7718160 4702069 ( 60.9%) 3675019 ( 47.6%) 512 100.0% TYPE-INTERSECTION2-CACHE + 5184706 1626512 ( 31.4%) 3557973 ( 68.6%) 256 86.3% %TYPE-INTERSECTION-CACHE + 5156044 3986450 ( 77.3%) 1169338 ( 22.7%) 256 100.0% VALUES-SUBTYPEP-CACHE + 4550163 2969409 ( 65.3%) 1580498 ( 34.7%) 256 100.0% VALUES-TYPE-INTERSECTION-CACHE + 3544211 2607658 ( 73.6%) 936300 ( 26.4%) 256 98.8% %TYPE-UNION-CACHE + 2545070 2110741 ( 82.9%) 433817 ( 17.0%) 512 100.0% PRIMITIVE-TYPE-AUX-CACHE + 2164841 1112785 ( 51.4%) 1706097 ( 78.8%) 256 100.0% TYPE-UNION2-CACHE + 1568022 1467575 ( 93.6%) 100191 ( 6.4%) 256 100.0% TYPE-SINGLETON-P-CACHE + 779941 703208 ( 90.2%) 76477 ( 9.8%) 256 100.0% %COERCE-TO-VALUES-CACHE + 618605 448427 ( 72.5%) 169922 ( 27.5%) 256 100.0% VALUES-TYPE-UNION-CACHE + 145805 29403 ( 20.2%) 116206 ( 79.7%) 256 76.6% %%MAKE-UNION-TYPE-CACHED-CACHE + 118634 76203 ( 64.2%) 42188 ( 35.6%) 256 94.9% %%MAKE-ARRAY-TYPE-CACHED-CACHE + 12319 12167 ( 98.8%) 47 ( 0.4%) 128 82.0% WEAKEN-TYPE-CACHE + 10416 9492 ( 91.1%) 668 ( 6.4%) 256 100.0% TYPE-NEGATION-CACHE +|# + ;;; miscellaneous tidying up and saving results (let ((filename "output/object-filenames-for-genesis.lisp-expr")) (ensure-directories-exist filename :verbose t) diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index e81066c..a631def 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -529,7 +529,7 @@ ;;; The size of the cache as a power of 2. ;;; :HASH-FUNCTION function ;;; Some thing that can be placed in CAR position which will compute -;;; a value between 0 and (1- (expt 2 <hash-bits>)). +;;; a fixnum with at least (* 2 <hash-bits>) of information in it. ;;; :VALUES <n> ;;; the number of return values cached for each function call ;;; :INIT-WRAPPER <name> @@ -547,20 +547,18 @@ (init-wrapper 'progn) (values 1)) (let* ((var-name (symbolicate "**" name "-CACHE-VECTOR**")) - (probes-name (when *profile-hash-cache* - (symbolicate "**" name "-CACHE-PROBES**"))) - (misses-name (when *profile-hash-cache* - (symbolicate "**" name "-CACHE-MISSES**"))) + (statistics-name (when *profile-hash-cache* + (symbolicate "**" name "-CACHE-STATISTICS**"))) (nargs (length args)) (size (ash 1 hash-bits)) (default-values (if (and (consp default) (eq (car default) 'values)) (cdr default) (list default))) (args-and-values (sb!xc:gensym "ARGS-AND-VALUES")) - (args-and-values-size (+ nargs values)) (n-index (sb!xc:gensym "INDEX")) (n-cache (sb!xc:gensym "CACHE"))) - (declare (ignorable probes-name misses-name)) + (declare (ignorable statistics-name)) + (assert (typep hash-bits '(integer 5 14))) ; reasonable bounds (unless (= (length default-values) values) (error "The number of default values ~S differs from :VALUES ~W." default values)) @@ -568,7 +566,6 @@ (collect ((inlines) (forms) (inits) - (sets) (tests) (arg-vars) (values-refs) @@ -576,8 +573,7 @@ (dotimes (i values) (let ((name (sb!xc:gensym "VALUE"))) (values-names name) - (values-refs `(svref ,args-and-values (+ ,nargs ,i))) - (sets `(setf (svref ,args-and-values (+ ,nargs ,i)) ,name)))) + (values-refs `(svref ,args-and-values (+ ,nargs ,i))))) (let ((n 0)) (dolist (arg args) (unless (= (length arg) 2) @@ -585,44 +581,63 @@ (let ((arg-name (first arg)) (test (second arg))) (arg-vars arg-name) - (tests `(,test (svref ,args-and-values ,n) ,arg-name)) - (sets `(setf (svref ,args-and-values ,n) ,arg-name))) + (tests `(,test (svref ,args-and-values ,n) ,arg-name))) (incf n))) (when *profile-hash-cache* - (inits `(setq ,probes-name 0)) - (inits `(setq ,misses-name 0)) - (forms `(declaim (fixnum ,probes-name ,misses-name)))) + (inits `(setq ,statistics-name (make-array 3 :element-type 'fixnum))) + (forms `(declaim (type (simple-array fixnum (3)) ,statistics-name)))) (let ((fun-name (symbolicate name "-CACHE-LOOKUP"))) (inlines fun-name) (forms `(defun ,fun-name ,(arg-vars) ,@(when *profile-hash-cache* - `((incf ,probes-name))) + `((incf (aref ,statistics-name 0)))) (flet ((miss () ,@(when *profile-hash-cache* - `((incf ,misses-name))) - (return-from ,fun-name ,default))) - (let* ((,n-index (,hash-function ,@(arg-vars))) - (,n-cache (or ,var-name (miss))) - (,args-and-values (svref ,n-cache ,n-index))) - (cond ((and (not (eql 0 ,args-and-values)) - ,@(tests)) - (values ,@(values-refs))) - (t - (miss)))))))) + `((incf (aref ,statistics-name 1)))) + (return-from ,fun-name ,default)) + (try (,args-and-values) + (if (and (not (eql 0 ,args-and-values)) + ,@(tests)) + (return-from ,fun-name + (values ,@(values-refs)))))) + (let ((,n-cache (or ,var-name (miss))) + (,n-index (funcall ,hash-function ,@(arg-vars)))) + ;; The matching entry might be in either index. + ;; Replacement picks one at random if both choices were taken. + (try (svref ,n-cache (ldb (byte ,hash-bits 0) ,n-index))) + (try (svref ,n-cache (ldb (byte ,hash-bits ,hash-bits) + ,n-index))) + (miss)))))) (let ((fun-name (symbolicate name "-CACHE-ENTER"))) (inlines fun-name) (forms `(defun ,fun-name (,@(arg-vars) ,@(values-names)) - (let ((,n-index (,hash-function ,@(arg-vars))) + (let ((,n-index (funcall ,hash-function ,@(arg-vars))) (,n-cache (or ,var-name (setq ,var-name (make-array ,size :initial-element 0)))) - (,args-and-values (make-array ,args-and-values-size))) - ,@(sets) - (setf (svref ,n-cache ,n-index) ,args-and-values)) + ;; TODO: 1-arg/1-result should use CONS instead of VECTOR. + (,args-and-values (vector ,@(arg-vars) ,@(values-names)))) + (let ((idx1 (ldb (byte ,hash-bits 0) ,n-index)) + (idx2 (ldb (byte ,hash-bits ,hash-bits) ,n-index))) + (cond ((eql (svref ,n-cache idx1) 0) + (setf (svref ,n-cache idx1) ,args-and-values)) + ((eql (svref ,n-cache idx2) 0) + (setf (svref ,n-cache idx2) ,args-and-values)) + (t + ,@(when *profile-hash-cache* ; tally up the evictions + `((incf (aref ,statistics-name 2)))) + ;; Use one bit of randomness to pick a victim. + (setf (svref ,n-cache + (if #-sb-xc-host + (logbitp 4 (sb!kernel:get-lisp-obj-address + ,(car (arg-vars)))) + #+sb-xc-host (zerop (random 2)) + idx1 idx2)) + ,args-and-values))))) (values)))) (let ((fun-name (symbolicate name "-CACHE-CLEAR"))) @@ -638,8 +653,8 @@ (pushnew ',var-name *cache-vector-symbols*) (defglobal ,var-name nil) ,@(when *profile-hash-cache* - `((defglobal ,probes-name 0) - (defglobal ,misses-name 0))) + `((defglobal ,statistics-name + (make-array 3 :element-type 'fixnum)))) (declaim (type (or null (simple-vector ,size)) ,var-name)) #!-sb-fluid (declaim (inline ,@(inlines))) (,init-wrapper ,@(inits)) @@ -693,9 +708,7 @@ (name &optional (original (symbolicate "%" name))) (let ((cached-name (symbolicate "%%" name "-CACHED"))) `(progn - (defun-cached (,cached-name :hash-bits 8 - :hash-function (lambda (x) - (logand (sxhash x) #xff))) + (defun-cached (,cached-name :hash-bits 8 :hash-function #'sxhash) ((args equal)) (apply #',original args)) (defun ,name (&rest args) @@ -1466,6 +1479,44 @@ to :INTERPRET, an interpreter will be used.") bindings))) ,@forms)) +;; This is not my preferred name for this function, but chosen for harmony +;; with everything else that refers to these as 'hash-caches'. +;; Hashing is just one particular way of memoizing, and it would have been +;; slightly more abstract and yet at the same time more concrete to say +;; "memoized-function-caches". "hash-caches" is pretty nonspecific. +#.(if *profile-hash-cache* +'(defun show-hash-cache-statistics () + (flet ((cache-stats (symbol) + (let* ((name (string symbol)) + (prefix + (subseq name 0 (- (length name) (length "VECTOR**"))))) + (values + (symbol-value (let ((*package* (symbol-package symbol))) + (symbolicate prefix "STATISTICS**"))) + (subseq prefix 2 (1- (length prefix))))))) + (format t "~%Type function memoization:~% Seek Hit (%)~: + Evict (%) Size full~%") + ;; Sort by descending seek count to rank by likely relative importance + (dolist (symbol (sort (copy-list *cache-vector-symbols*) #'> + :key (lambda (x) (aref (cache-stats x) 0)))) + ;; Sadly we can't use BINDING* within this file + (multiple-value-bind (stats short-name) (cache-stats symbol) + (let* ((seek (aref stats 0)) + (miss (aref stats 1)) + (hit (- seek miss)) + (evict (aref stats 2)) + (cache (symbol-value symbol))) + (format t "~9d ~9d (~5,1f%) ~8d (~5,1f%) ~4d ~6,1f% ~A~%" + seek hit + (if (plusp seek) (* 100 (/ hit seek))) + evict + (if (plusp seek) (* 100 (/ evict seek))) + (length cache) + (if (plusp (length cache)) + (* 100 (/ (count-if-not #'fixnump cache) + (length cache)))) + short-name))))))) + (in-package "SB!KERNEL") (defun fp-zero-p (x) diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp index 263f5b7..3be7825 100644 --- a/src/code/early-type.lisp +++ b/src/code/early-type.lisp @@ -146,18 +146,19 @@ :hash-bits 8 :hash-function (lambda (req opt rest allowp) - (logand (logxor - (type-list-cache-hash req) - (type-list-cache-hash opt) + (logxor (type-list-cache-hash req) + (type-list-cache-hash opt) (if rest (type-hash-value rest) 42) ;; Results (logand #xFF (sxhash t/nil)) ;; hardcoded to avoid relying on the xc host. + ;; [but (logand (sxhash nil) #xff) => 2 + ;; for me, so the code and comment disagree, + ;; but not in a way that matters.] (if allowp 194 - 11)) - #xFF))) + 11)))) ((required equal-but-no-car-recursion) (optional equal-but-no-car-recursion) (rest eq) @@ -570,8 +571,7 @@ ;;; Note: VALUES-SPECIFIER-TYPE-CACHE-CLEAR must be called whenever a ;;; type is defined (or redefined). (defun-cached (values-specifier-type - :hash-function (lambda (x) - (logand (sxhash x) #x3FF)) + :hash-function #'sxhash :hash-bits 10 :init-wrapper !cold-init-forms) ((orig equal-but-no-car-recursion)) diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index ea1d1c3..6e6de63 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -573,11 +573,7 @@ exact))) ;;; If TYPE isn't a values type, then make it into one. -(defun-cached (%coerce-to-values - :hash-bits 8 - :hash-function (lambda (type) - (logand (type-hash-value type) - #xff))) +(defun-cached (%coerce-to-values :hash-bits 8 :hash-function #'type-hash-value) ((type eq)) (cond ((multiple-value-bind (res sure) (csubtypep (specifier-type 'null) type) @@ -705,7 +701,7 @@ ;;; ;;; The return convention seems to be analogous to ;;; TYPES-EQUAL-OR-INTERSECT. -- WHN 19990910. -(defun-cached (values-type-union :hash-function type-cache-hash +(defun-cached (values-type-union :hash-function #'type-cache-hash :hash-bits 8 :default nil :init-wrapper !cold-init-forms) @@ -717,7 +713,7 @@ (t (values (values-type-op type1 type2 #'type-union #'min))))) -(defun-cached (values-type-intersection :hash-function type-cache-hash +(defun-cached (values-type-intersection :hash-function #'type-cache-hash :hash-bits 8 :default (values nil) :init-wrapper !cold-init-forms) @@ -758,7 +754,7 @@ ;;; a SUBTYPEP-like operation that can be used on any types, including ;;; VALUES types -(defun-cached (values-subtypep :hash-function type-cache-hash +(defun-cached (values-subtypep :hash-function #'type-cache-hash :hash-bits 8 :values 2 :default (values nil :empty) @@ -800,8 +796,8 @@ ;;;; type method interfaces ;;; like SUBTYPEP, only works on CTYPE structures -(defun-cached (csubtypep :hash-function type-cache-hash - :hash-bits 8 +(defun-cached (csubtypep :hash-function #'type-cache-hash + :hash-bits 10 :values 2 :default (values nil :empty) :init-wrapper !cold-init-forms) @@ -832,8 +828,8 @@ ;;; If two types are definitely equivalent, return true. The second ;;; value indicates whether the first value is definitely correct. ;;; This should only fail in the presence of HAIRY types. -(defun-cached (type= :hash-function type-cache-hash - :hash-bits 8 +(defun-cached (type= :hash-function #'type-cache-hash + :hash-bits 11 :values 2 :default (values nil :empty) :init-wrapper !cold-init-forms) @@ -874,7 +870,7 @@ ;;; that is precise to the best of our knowledge. This result is ;;; simplified into the canonical form, thus is not a UNION-TYPE ;;; unless we find no other way to represent the result. -(defun-cached (type-union2 :hash-function type-cache-hash +(defun-cached (type-union2 :hash-function #'type-cache-hash :hash-bits 8 :init-wrapper !cold-init-forms) ((type1 eq) (type2 eq)) @@ -936,8 +932,8 @@ (t nil)))))))) -(defun-cached (type-intersection2 :hash-function type-cache-hash - :hash-bits 8 +(defun-cached (type-intersection2 :hash-function #'type-cache-hash + :hash-bits 9 :values 1 :default nil :init-wrapper !cold-init-forms) @@ -995,9 +991,7 @@ (declare (type ctype type)) (funcall (type-class-unparse (type-class-info type)) type)) -(defun-cached (type-negation :hash-function (lambda (type) - (logand (type-hash-value type) - #xff)) +(defun-cached (type-negation :hash-function #'type-hash-value :hash-bits 8 :values 1 :default nil @@ -1006,9 +1000,7 @@ (declare (type ctype type)) (funcall (type-class-negate (type-class-info type)) type)) -(defun-cached (type-singleton-p :hash-function (lambda (type) - (logand (type-hash-value type) - #xff)) +(defun-cached (type-singleton-p :hash-function #'type-hash-value :hash-bits 8 :values 2 :default (values nil t) @@ -1082,9 +1074,7 @@ (defun type-intersection (&rest input-types) (%type-intersection input-types)) -(defun-cached (%type-intersection :hash-bits 8 - :hash-function (lambda (x) - (logand (sxhash x) #xff))) +(defun-cached (%type-intersection :hash-bits 8 :hash-function #'sxhash) ((input-types equal)) (let ((simplified-types (simplify-intersections input-types))) (declare (type list simplified-types)) @@ -1117,9 +1107,7 @@ (defun type-union (&rest input-types) (%type-union input-types)) -(defun-cached (%type-union :hash-bits 8 - :hash-function (lambda (x) - (logand (sxhash x) #xff))) +(defun-cached (%type-union :hash-bits 8 :hash-function #'sxhash) ((input-types equal)) (let ((simplified-types (simplify-unions input-types))) (cond diff --git a/src/code/target-type.lisp b/src/code/target-type.lisp index 19abb5a..15263e3 100644 --- a/src/code/target-type.lisp +++ b/src/code/target-type.lisp @@ -144,7 +144,7 @@ ;;; user might find most informative. (declaim (ftype (function (t) ctype) ctype-of)) (defun-cached (ctype-of - :hash-function (lambda (x) (logand (sxhash x) #x1FF)) + :hash-function #'sxhash :hash-bits 9 :init-wrapper !cold-init-forms) ((x eq)) diff --git a/src/code/typedefs.lisp b/src/code/typedefs.lisp index e652fc4..4e9191f 100644 --- a/src/code/typedefs.lisp +++ b/src/code/typedefs.lisp @@ -81,7 +81,7 @@ (enumerable nil :read-only t) ;; an arbitrary hash code used in EQ-style hashing of identity ;; (since EQ hashing can't be done portably) - (hash-value (random #.(ash 1 15) + (hash-value (random #.(ash 1 28) (if (boundp '*type-random-state*) *type-random-state* (setf *type-random-state* @@ -123,7 +123,7 @@ ((csubtypep type2 type1) type1) (t nil))) -;;; Hash two things (types) down to 8 bits. In CMU CL this was an EQ +;;; Hash two things (types) down to a fixnum. In CMU CL this was an EQ ;;; hash, but since it now needs to run in vanilla ANSI Common Lisp at ;;; cross-compile time, it's now based on the CTYPE-HASH-VALUE field ;;; instead. @@ -132,20 +132,17 @@ ;;; it important for it to be INLINE, or could be become an ordinary ;;; function without significant loss? -- WHN 19990413 #!-sb-fluid (declaim (inline type-cache-hash)) -(declaim (ftype (function (ctype ctype) (unsigned-byte 8)) type-cache-hash)) +(declaim (ftype (function (ctype ctype) fixnum) type-cache-hash)) (defun type-cache-hash (type1 type2) - (logand (logxor (ash (type-hash-value type1) -3) - (type-hash-value type2)) - #xFF)) + (logxor (ash (type-hash-value type1) -3) (type-hash-value type2))) + #!-sb-fluid (declaim (inline type-list-cache-hash)) -(declaim (ftype (function (list) (unsigned-byte 8)) type-list-cache-hash)) +(declaim (ftype (function (list) fixnum) type-list-cache-hash)) (defun type-list-cache-hash (types) - (logand #xFF - (loop with res fixnum = 0 - for type in types - for hash = (type-hash-value type) - do (setq res (logxor res hash)) - finally (return res)))) + (loop with res fixnum = 0 + for type in types + do (setq res (logxor (ash res -1) (type-hash-value type))) + finally (return res))) ;;;; cold loading initializations diff --git a/src/compiler/checkgen.lisp b/src/compiler/checkgen.lisp index 5fcdd10..c161d54 100644 --- a/src/compiler/checkgen.lisp +++ b/src/compiler/checkgen.lisp @@ -131,9 +131,7 @@ (weaken-integer-type-part type 'integer))) (defun-cached - (weaken-type :hash-bits 8 - :hash-function (lambda (x) - (logand (type-hash-value x) #xFF))) + (weaken-type :hash-bits 7 :hash-function #'type-hash-value) ((type eq)) (declare (type ctype type)) (cond ((named-type-p type) diff --git a/src/compiler/generic/primtype.lisp b/src/compiler/generic/primtype.lisp index 3567287..5df627c 100644 --- a/src/compiler/generic/primtype.lisp +++ b/src/compiler/generic/primtype.lisp @@ -154,8 +154,7 @@ (primitive-type-aux type)) (/show0 "primtype.lisp 191") (defun-cached (primitive-type-aux - :hash-function (lambda (x) - (logand (type-hash-value x) #x1FF)) + :hash-function #'type-hash-value :hash-bits 9 :values 2 :default (values nil :empty)) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2014-06-18 00:29:48
|
The branch "master" has been updated in SBCL: via 4b770969853f2548e6f1505ba30ff2d92e72e3b5 (commit) from 48793e3dd3edcdf65aaf550d13d5a075a811127c (commit) - Log ----------------------------------------------------------------- commit 4b770969853f2548e6f1505ba30ff2d92e72e3b5 Author: Douglas Katzman <do...@go...> Date: Tue Jun 17 20:17:27 2014 -0400 Further change to BINDING* to make it more really right. --- src/code/early-extensions.lisp | 20 ++++++++++++++++---- tests/macroexpand.impure.lisp | 10 ++++++++++ 2 files changed, 26 insertions(+), 4 deletions(-) diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index dd394e0..e81066c 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -1251,7 +1251,7 @@ (cond ((eq id 'type) (cddr decl)) ((or (listp id) ; must be a type-specifier - (memq id '(special ignorable ignore + (memq id '(special ignorable ignore dynamic-extent truly-dynamic-extent)) (info :type :kind id)) @@ -1298,8 +1298,9 @@ ;;; them into the appropriate places. This qualifies as an extreme KLUDGE, ;;; but has desirable behavior of allowing declarations in the innermost form. ;;; -;;; Caution: don't use declarations of the form (<type-id> <var>) before the -;;; INFO database is set up in building the cross-compiler, or you will lose. +;;; Caution: don't use declarations of the form (<non-builtin-type-id> <var>) +;;; before the INFO database is set up in building the cross-compiler, +;;; or you will probably lose. ;;; Of course, since some other host Lisps don't seem to think that's ;;; acceptable syntax anyway, you're pretty much prevented from writing it. ;;; @@ -1326,7 +1327,8 @@ ;; If no more bindings, and no (WHEN ...) before the FORMS, ;; then don't bother parsing decls. (if (or (cdr bindings) flag) - (extract-var-decls decls names) + (extract-var-decls decls + (filter-names names (cdr bindings))) (values nil decls)) (let ((continue (acond ((cdr bindings) (recurse it rest-decls)) (t (append decls forms))))) @@ -1349,6 +1351,16 @@ bindings) ,@(decl-expr nil ignores) ,@body))))) + (filter-names (names more-bindings) + ;; Return the subset of SYMBOLs that does not intersect any + ;; symbol in MORE-BINDINGS. This makes declarations apply only + ;; to the final occurrence of a repeated name, as is the custom. + (remove-if (lambda (x) (subsequently-bound-p x more-bindings)) names)) + (subsequently-bound-p (name more-bindings) + (member-if (lambda (binding) + (let ((names (car binding))) + (if (listp names) (memq name names) (eq name names)))) + more-bindings)) (decl-expr (binding-decls ignores) (nconc (if binding-decls (list binding-decls)) ;; IGNORABLE, not IGNORE, just in case :EXIT-IF-NULL reads a gensym diff --git a/tests/macroexpand.impure.lisp b/tests/macroexpand.impure.lisp index 7a3b0ee..9934648 100644 --- a/tests/macroexpand.impure.lisp +++ b/tests/macroexpand.impure.lisp @@ -88,3 +88,13 @@ (WHEN FOO (MULTIPLE-VALUE-BIND (BAZ Y) (G BAR) (DECLARE (SPECIAL Y)) (DECLARE (SPECIAL L) (REAL Q)) (THING)))))) + +(assert (equal (macroexpand-1 + '(sb-int:binding* (((x y) (f)) + (x (g y x))) + (declare (integer x)) + (foo))) + '(MULTIPLE-VALUE-BIND (X Y) (F) + (LET* ((X (G Y X))) + (DECLARE (INTEGER X)) + (FOO))))) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: stassats <sta...@us...> - 2014-06-17 21:56:39
|
The branch "master" has been updated in SBCL: via 48793e3dd3edcdf65aaf550d13d5a075a811127c (commit) from d31e787921c0b704d77f4d89ebae8b6008bc6b53 (commit) - Log ----------------------------------------------------------------- commit 48793e3dd3edcdf65aaf550d13d5a075a811127c Author: Stas Boukarev <sta...@gm...> Date: Wed Jun 18 01:40:02 2014 +0400 Remove TRACE-TABLE-OFFSET slot from CODE. It stored the byte offset to the location where the code ended and where the trace table started, but since there's no trace tables, it was only used for getting the byte size of the code. The code size is already stored in the CODE-SIZE slot, but in words and rounded up to two words. Store verbatim bytes instead and do the conversions when necessary. --- build-order.lisp-expr | 1 - package-data-list.lisp-expr | 3 +- src/code/debug-int.lisp | 10 +--- src/code/room.lisp | 103 +-------------------------------- src/code/target-load.lisp | 30 +++++----- src/compiler/alpha/alloc.lisp | 7 +- src/compiler/arm/alloc.lisp | 8 +- src/compiler/arm/sanctify.lisp | 3 +- src/compiler/dump.lisp | 16 +----- src/compiler/generic/genesis.lisp | 12 +--- src/compiler/generic/objdef.lisp | 5 +- src/compiler/generic/target-core.lisp | 4 +- src/compiler/hppa/alloc.lisp | 6 +- src/compiler/hppa/sanctify.lisp | 3 +- src/compiler/mips/alloc.lisp | 7 +- src/compiler/mips/sanctify.lisp | 3 +- src/compiler/ppc/alloc.lisp | 8 +- src/compiler/ppc/sanctify.lisp | 3 +- src/compiler/sparc/alloc.lisp | 6 +- src/compiler/sparc/sanctify.lisp | 3 +- src/compiler/target-disassem.lisp | 38 +++--------- src/runtime/alloc.c | 20 +++--- src/runtime/breakpoint.c | 2 +- src/runtime/gc-common.c | 8 +- src/runtime/gencgc.c | 18 ++---- src/runtime/purify.c | 18 +----- src/runtime/runtime.h | 9 +++ 27 files changed, 99 insertions(+), 255 deletions(-) diff --git a/build-order.lisp-expr b/build-order.lisp-expr index f8b7030..7034431 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -497,7 +497,6 @@ ("src/code/debug-info") ;; Compiling this requires fop definitions from code/fop.lisp and - ;; trace table definitions from compiler/trace-table.lisp. ("src/compiler/dump") ("src/compiler/main") ; needs DEFSTRUCT FASL-OUTPUT from dump.lisp diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 0da62c0..de78540 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -2729,8 +2729,7 @@ structure representations" "CLOSURE-HEADER-WIDETAG" "CLOSURE-INFO-OFFSET" "CODE-CODE-SIZE-SLOT" "CODE-CONSTANTS-OFFSET" "CODE-DEBUG-INFO-SLOT" "CODE-ENTRY-POINTS-SLOT" - "CODE-HEADER-WIDETAG" - "CODE-TRACE-TABLE-OFFSET-SLOT" "COMPLEX-ARRAY-WIDETAG" + "CODE-HEADER-WIDETAG" "COMPLEX-ARRAY-WIDETAG" "COMPLEX-BIT-VECTOR-WIDETAG" "COMPLEX-DOUBLE-FLOAT-FILLER-SLOT" "COMPLEX-DOUBLE-FLOAT-IMAG-SLOT" "COMPLEX-DOUBLE-FLOAT-REAL-SLOT" "COMPLEX-DOUBLE-FLOAT-SIZE" "COMPLEX-DOUBLE-FLOAT-WIDETAG" diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 9361f10..c3c5659 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -897,9 +897,7 @@ sb!vm:other-pointer-lowtag) code-header-len))) (/noshow "got PC-OFFSET") - (unless (<= 0 pc-offset - (* (code-header-ref code sb!vm:code-code-size-slot) - sb!vm:n-word-bytes)) + (unless (<= 0 pc-offset (%code-code-size code)) ;; We were in an assembly routine. Therefore, use the ;; LRA as the pc. ;; @@ -933,9 +931,7 @@ (- (get-lisp-obj-address code) sb!vm:other-pointer-lowtag) code-header-len))) - (let ((code-size (* (code-header-ref code - sb!vm:code-code-size-slot) - sb!vm:n-word-bytes))) + (let ((code-size (%code-code-size code))) (unless (<= 0 pc-offset code-size) ;; We were in an assembly routine. (multiple-value-bind (new-pc-offset computed-return) @@ -3228,8 +3224,6 @@ register." src-start src-end dst-start trap-loc) (type index length)) (setf (%code-debug-info code-object) :bogus-lra) - (setf (code-header-ref code-object sb!vm:code-trace-table-offset-slot) - length) #!-(or x86 x86-64) (setf (code-header-ref code-object real-lra-slot) real-lra) #!+(or x86 x86-64) diff --git a/src/code/room.lisp b/src/code/room.lisp index 7ca3484..843061c 100644 --- a/src/code/room.lisp +++ b/src/code/room.lisp @@ -255,12 +255,11 @@ (values (tagged-object other-pointer-lowtag) code-header-widetag (round-to-dualword - (* (+ header-value - (the fixnum + (+ (* header-value n-word-bytes) + (the fixnum (sap-ref-lispobj object-sap (* code-code-size-slot - n-word-bytes)))) - n-word-bytes)))) + n-word-bytes))))))) (t (error "Unrecognized room-info-kind ~S in reconstitute-object" @@ -532,102 +531,6 @@ (values)) -;;; Print info about how much code and no-ops there are in SPACE. -(defun count-no-ops (space) - (declare (type spaces space)) - (let ((code-words 0) - (no-ops 0) - (total-bytes 0)) - (declare (fixnum code-words no-ops) - (type unsigned-byte total-bytes)) - (map-allocated-objects - (lambda (obj type size) - (when (eql type code-header-widetag) - (let ((words (truly-the fixnum (%code-code-size obj))) - (sap (%primitive code-instructions obj)) - (size size)) - (declare (fixnum size)) - (incf total-bytes size) - (incf code-words words) - (dotimes (i words) - (when (zerop (sap-ref-word sap (* i n-word-bytes))) - (incf no-ops)))))) - space) - - (format t - "~:D code-object bytes, ~:D code words, with ~:D no-ops (~D%).~%" - total-bytes code-words no-ops - (round (* no-ops 100) code-words))) - - (values)) - -(defun descriptor-vs-non-descriptor-storage (&rest spaces) - (let ((descriptor-words 0) - (non-descriptor-headers 0) - (non-descriptor-bytes 0)) - (declare (type unsigned-byte descriptor-words non-descriptor-headers - non-descriptor-bytes)) - (dolist (space (or spaces '(:read-only :static :dynamic))) - (declare (inline map-allocated-objects)) - (map-allocated-objects - (lambda (obj type size) - (case type - (#.code-header-widetag - (let ((inst-words (truly-the fixnum (%code-code-size obj))) - (size size)) - (declare (type fixnum size inst-words)) - (incf non-descriptor-bytes (* inst-words n-word-bytes)) - (incf descriptor-words - (- (truncate size n-word-bytes) inst-words)))) - ((#.bignum-widetag - #.single-float-widetag - #.double-float-widetag - #.simple-base-string-widetag - #!+sb-unicode #.simple-character-string-widetag - #.simple-array-nil-widetag - #.simple-bit-vector-widetag - #.simple-array-unsigned-byte-2-widetag - #.simple-array-unsigned-byte-4-widetag - #.simple-array-unsigned-byte-8-widetag - #.simple-array-unsigned-byte-16-widetag - #.simple-array-unsigned-byte-32-widetag - #.simple-array-signed-byte-8-widetag - #.simple-array-signed-byte-16-widetag - #.simple-array-signed-byte-32-widetag - #.simple-array-single-float-widetag - #.simple-array-double-float-widetag - #.simple-array-complex-single-float-widetag - #.simple-array-complex-double-float-widetag) - (incf non-descriptor-headers) - (incf non-descriptor-bytes (- size n-word-bytes))) - ((#.list-pointer-lowtag - #.instance-pointer-lowtag - #.ratio-widetag - #.complex-widetag - #.simple-array-widetag - #.simple-vector-widetag - #.complex-base-string-widetag - #.complex-vector-nil-widetag - #.complex-bit-vector-widetag - #.complex-vector-widetag - #.complex-array-widetag - #.closure-header-widetag - #.funcallable-instance-header-widetag - #.value-cell-header-widetag - #.symbol-header-widetag - #.sap-widetag - #.weak-pointer-widetag - #.instance-header-widetag) - (incf descriptor-words (truncate (the fixnum size) n-word-bytes))) - (t - (error "bogus widetag: ~W" type)))) - space)) - (format t "~:D words allocated for descriptor objects.~%" - descriptor-words) - (format t "~:D bytes data/~:D words header for non-descriptor objects.~%" - non-descriptor-bytes non-descriptor-headers) - (values))) - ;;; Print a breakdown by instance type of all the instances allocated ;;; in SPACE. If TOP-N is true, print only information for the ;;; TOP-N types with largest usage. diff --git a/src/code/target-load.lisp b/src/code/target-load.lisp index 9577d66..ac19093 100644 --- a/src/code/target-load.lisp +++ b/src/code/target-load.lisp @@ -211,7 +211,7 @@ (declare (fixnum box-num code-length)) (with-fop-stack t (let ((code (sb!c:allocate-code-object box-num code-length)) - (index (+ sb!vm:code-trace-table-offset-slot box-num))) + (index (+ sb!vm:code-constants-offset box-num))) (declare (type index index)) (setf (%code-debug-info code) (pop-stack)) (dotimes (i box-num) @@ -240,24 +240,22 @@ (dotimes (i box-num) (declare (fixnum i)) (push (pop-stack) stuff)) - (let* ((dbi (car (last stuff))) ; debug-info - (tto (first stuff))) ; trace-table-offset + (let* ((dbi (car (last stuff)))) ; debug-info (setq stuff (nreverse stuff)) ;; FIXME: *LOAD-CODE-VERBOSE* should probably be #!+SB-SHOW. (when *load-code-verbose* - (format t "stuff: ~S~%" stuff) - (format t - " : ~S ~S ~S ~S~%" - (sb!c::compiled-debug-info-p dbi) - (sb!c::debug-info-p dbi) - (sb!c::compiled-debug-info-name dbi) - tto) - (format t " loading to the dynamic space~%")) + (format t "stuff: ~S~%" stuff) + (format t + " : ~S ~S ~S~%" + (sb!c::compiled-debug-info-p dbi) + (sb!c::debug-info-p dbi) + (sb!c::compiled-debug-info-name dbi)) + (format t " loading to the dynamic space~%")) (let ((code (sb!c:allocate-code-object box-num code-length)) - (index (+ sb!vm:code-trace-table-offset-slot box-num))) + (index (+ sb!vm:code-constants-offset box-num))) (declare (type index index)) (when *load-code-verbose* (format t @@ -268,10 +266,10 @@ (declare (fixnum i)) (setf (code-header-ref code (decf index)) (pop stuff))) (without-gcing - (read-n-bytes *fasl-input-stream* - (code-instructions code) - 0 - code-length)) + (read-n-bytes *fasl-input-stream* + (code-instructions code) + 0 + code-length)) code))))) ;;;; linkage fixups diff --git a/src/compiler/alpha/alloc.lisp b/src/compiler/alpha/alloc.lisp index c88ecce..74b281b 100644 --- a/src/compiler/alpha/alloc.lisp +++ b/src/compiler/alpha/alloc.lisp @@ -82,11 +82,10 @@ (:results (result :scs (descriptor-reg))) (:temporary (:scs (non-descriptor-reg)) ndescr) (:temporary (:scs (any-reg) :from (:argument 0)) boxed) - (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) unboxed) + (:temporary (:scs (non-descriptor-reg)) unboxed) (:generator 100 (inst li (lognot lowtag-mask) ndescr) - (inst lda boxed (fixnumize (1+ code-trace-table-offset-slot)) - boxed-arg) + (inst lda boxed (fixnumize (1+ code-constants-offset)) boxed-arg) (inst and boxed ndescr boxed) (inst srl unboxed-arg word-shift unboxed) (inst lda unboxed lowtag-mask unboxed) @@ -97,7 +96,7 @@ (pseudo-atomic () (inst bis alloc-tn other-pointer-lowtag result) (storew ndescr result 0 other-pointer-lowtag) - (storew unboxed result code-code-size-slot other-pointer-lowtag) + (storew unboxed-arg result code-code-size-slot other-pointer-lowtag) (storew null-tn result code-entry-points-slot other-pointer-lowtag) (inst addq alloc-tn boxed alloc-tn) (inst addq alloc-tn unboxed alloc-tn)) diff --git a/src/compiler/arm/alloc.lisp b/src/compiler/arm/alloc.lisp index 4205f68..39230a7 100644 --- a/src/compiler/arm/alloc.lisp +++ b/src/compiler/arm/alloc.lisp @@ -68,7 +68,7 @@ (:variant t)) ;;;; Special purpose inline allocators. - +#!-gencgc (define-vop (allocate-code-object) (:args (boxed-arg :scs (any-reg)) (unboxed-arg :scs (any-reg))) @@ -76,10 +76,10 @@ (:temporary (:scs (non-descriptor-reg)) ndescr) (:temporary (:scs (non-descriptor-reg)) size) (:temporary (:scs (any-reg) :from (:argument 0)) boxed) - (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) unboxed) + (:temporary (:scs (non-descriptor-reg)) unboxed) (:temporary (:sc non-descriptor-reg :offset ocfp-offset) pa-flag) (:generator 100 - (inst add boxed boxed-arg (fixnumize (1+ code-trace-table-offset-slot))) + (inst add boxed boxed-arg (fixnumize (1+ code-constants-offset))) (inst bic boxed boxed lowtag-mask) (inst mov unboxed (lsr unboxed-arg word-shift)) (inst add unboxed unboxed lowtag-mask) @@ -90,7 +90,7 @@ (pseudo-atomic (pa-flag) (allocation result size other-pointer-lowtag :flag-tn pa-flag) (storew ndescr result 0 other-pointer-lowtag) - (storew unboxed result code-code-size-slot other-pointer-lowtag) + (storew unboxed-arg result code-code-size-slot other-pointer-lowtag) (storew null-tn result code-entry-points-slot other-pointer-lowtag) (storew null-tn result code-debug-info-slot other-pointer-lowtag)))) diff --git a/src/compiler/arm/sanctify.lisp b/src/compiler/arm/sanctify.lisp index 6f235fe..5d54a78 100644 --- a/src/compiler/arm/sanctify.lisp +++ b/src/compiler/arm/sanctify.lisp @@ -25,6 +25,5 @@ system-area-pointer unsigned-long)) (code-instructions component) - (* (code-header-ref component code-code-size-slot) - n-word-bytes))) + (%code-code-size component))) nil) diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp index 472a611..2e094d1 100644 --- a/src/compiler/dump.lisp +++ b/src/compiler/dump.lisp @@ -1021,19 +1021,9 @@ (type fasl-output fasl-output)) (let* ((2comp (component-info component)) - (constants (sb!c::ir2-component-constants 2comp)) + (constants (sb!c:ir2-component-constants 2comp)) (header-length (length constants))) (collect ((patches)) - - ;; Dump the offset of the trace table. - (dump-object code-length fasl-output) - ;; FIXME: As long as we don't have GENGC, the trace table is - ;; hardwired to be empty. And SBCL doesn't have GENGC (and as - ;; far as I know no modern CMU CL does either -- WHN - ;; 2001-10-05). So might we be able to get rid of trace tables? - ;; - ;; Note that gencgc also does something with the trace table. - ;; Dump the constants, noting any :ENTRY constants that have to ;; be patched. (loop for i from sb!vm:code-constants-offset below header-length do @@ -1074,7 +1064,7 @@ (dump-push info-handle fasl-output) (push info-handle (fasl-output-debug-info fasl-output)))) - (let ((num-consts (- header-length sb!vm:code-trace-table-offset-slot))) + (let ((num-consts (- header-length sb!vm:code-constants-offset))) (cond ((and (< num-consts #x100) (< code-length #x10000)) (dump-fop 'fop-small-code fasl-output) (dump-byte num-consts fasl-output) @@ -1084,8 +1074,6 @@ (dump-word num-consts fasl-output) (dump-word code-length fasl-output)))) - ;; These two dumps are only ones which contribute to our - ;; LENGTH value. (dump-segment code-segment code-length fasl-output) ;; DUMP-FIXUPS does its own internal DUMP-FOPs: the bytes it diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index f4fe6df..b0e85ff 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -2543,7 +2543,7 @@ core and return a descriptor to it." `(define-cold-fop (,name) (let* ((nconst ,nconst) (code-size ,code-size) - (raw-header-n-words (+ sb!vm:code-trace-table-offset-slot nconst)) + (raw-header-n-words (+ sb!vm:code-constants-offset nconst)) (header-n-words ;; Note: we round the number of constants up to ensure ;; that the code vector will be properly aligned. @@ -2558,9 +2558,7 @@ core and return a descriptor to it." header-n-words sb!vm:code-header-widetag)) (write-wordindexed des sb!vm:code-code-size-slot - (make-fixnum-descriptor - (ash (+ code-size (1- (ash 1 sb!vm:word-shift))) - (- sb!vm:word-shift)))) + (make-fixnum-descriptor code-size)) (write-wordindexed des sb!vm:code-entry-points-slot *nil-descriptor*) (write-wordindexed des sb!vm:code-debug-info-slot (pop-stack)) (when (oddp raw-header-n-words) @@ -2568,7 +2566,7 @@ core and return a descriptor to it." raw-header-n-words (make-random-descriptor 0))) (do ((index (1- raw-header-n-words) (1- index))) - ((< index sb!vm:code-trace-table-offset-slot)) + ((< index sb!vm:code-constants-offset)) (write-wordindexed des index (pop-stack))) (let* ((start (+ (descriptor-byte-offset des) (ash header-n-words sb!vm:word-shift))) @@ -2726,9 +2724,7 @@ core and return a descriptor to it." header-n-words sb!vm:code-header-widetag)) (write-wordindexed des sb!vm:code-code-size-slot - (make-fixnum-descriptor - (ash (+ length (1- (ash 1 sb!vm:word-shift))) - (- sb!vm:word-shift)))) + (make-fixnum-descriptor length)) (write-wordindexed des sb!vm:code-entry-points-slot *nil-descriptor*) (write-wordindexed des sb!vm:code-debug-info-slot *nil-descriptor*) diff --git a/src/compiler/generic/objdef.lisp b/src/compiler/generic/objdef.lisp index 0aa22a7..0b8f17b 100644 --- a/src/compiler/generic/objdef.lisp +++ b/src/compiler/generic/objdef.lisp @@ -145,9 +145,13 @@ :type index) (data :rest-p t :c-type #!-alpha "uword_t" #!+alpha "u32")) +;;; The header contains the size of slots and constants in words. (define-primitive-object (code :type code-component :lowtag other-pointer-lowtag :widetag t) + ;; This is the size of instructions in bytes, not aligned. + ;; Adding the size from the header and aligned code-size will yield + ;; the total size of the code-object. (code-size :type index :ref-known (flushable movable) :ref-trans %code-code-size) @@ -161,7 +165,6 @@ :ref-trans %code-debug-info :set-known () :set-trans (setf %code-debug-info)) - (trace-table-offset) (constants :rest-p t)) (define-primitive-object (fdefn :type fdefn diff --git a/src/compiler/generic/target-core.lisp b/src/compiler/generic/target-core.lisp index a3153bc..d6d177e 100644 --- a/src/compiler/generic/target-core.lisp +++ b/src/compiler/generic/target-core.lisp @@ -56,7 +56,7 @@ (without-gcing (let* ((2comp (component-info component)) (constants (ir2-component-constants 2comp)) - (box-num (- (length constants) sb!vm:code-trace-table-offset-slot)) + (box-num (- (length constants) sb!vm:code-constants-offset)) (code-obj (allocate-code-object box-num length)) (fill-ptr (code-instructions code-obj))) (declare (type index box-num length)) @@ -78,8 +78,6 @@ (push info (core-object-debug-info object)) (setf (%code-debug-info code-obj) info)) - (setf (code-header-ref code-obj sb!vm:code-trace-table-offset-slot) - length) (do ((index sb!vm:code-constants-offset (1+ index))) ((>= index (length constants))) (let ((const (aref constants index))) diff --git a/src/compiler/hppa/alloc.lisp b/src/compiler/hppa/alloc.lisp index 18c5eae..ecea0a3 100644 --- a/src/compiler/hppa/alloc.lisp +++ b/src/compiler/hppa/alloc.lisp @@ -126,9 +126,9 @@ (:results (result :scs (descriptor-reg))) (:temporary (:scs (non-descriptor-reg)) ndescr) (:temporary (:scs (any-reg) :from (:argument 0)) boxed) - (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) unboxed) + (:temporary (:scs (non-descriptor-reg)) unboxed) (:generator 100 - (inst addi (fixnumize (1+ code-trace-table-offset-slot)) boxed-arg boxed) + (inst addi (fixnumize (1+ code-constants-offset)) boxed-arg boxed) (inst dep 0 31 n-lowtag-bits boxed) (inst srl unboxed-arg word-shift unboxed) (inst addi lowtag-mask unboxed unboxed) @@ -140,7 +140,7 @@ (inst add alloc-tn boxed alloc-tn) (inst add alloc-tn unboxed alloc-tn) (storew ndescr result 0 other-pointer-lowtag) - (storew unboxed result code-code-size-slot other-pointer-lowtag) + (storew unboxed-arg result code-code-size-slot other-pointer-lowtag) (storew null-tn result code-entry-points-slot other-pointer-lowtag) (storew null-tn result code-debug-info-slot other-pointer-lowtag)))) diff --git a/src/compiler/hppa/sanctify.lisp b/src/compiler/hppa/sanctify.lisp index fa0aa0f..37e7b85 100644 --- a/src/compiler/hppa/sanctify.lisp +++ b/src/compiler/hppa/sanctify.lisp @@ -22,6 +22,5 @@ system-area-pointer unsigned-long)) (code-instructions component) - (* (code-header-ref component code-code-size-slot) - n-word-bytes))) + (%code-code-size component))) nil) diff --git a/src/compiler/mips/alloc.lisp b/src/compiler/mips/alloc.lisp index 0567e30..7bd1147 100644 --- a/src/compiler/mips/alloc.lisp +++ b/src/compiler/mips/alloc.lisp @@ -138,12 +138,11 @@ (:results (result :scs (descriptor-reg))) (:temporary (:scs (non-descriptor-reg)) ndescr) (:temporary (:scs (any-reg) :from (:argument 0)) boxed) - (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) unboxed) + (:temporary (:scs (non-descriptor-reg)) unboxed) (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag) (:generator 100 (inst li ndescr (lognot lowtag-mask)) - (inst addu boxed boxed-arg - (fixnumize (1+ code-trace-table-offset-slot))) + (inst addu boxed boxed-arg (fixnumize (1+ code-code-size-slot))) (inst and boxed ndescr) (inst srl unboxed unboxed-arg word-shift) (inst addu unboxed unboxed lowtag-mask) @@ -155,7 +154,7 @@ (inst or result alloc-tn other-pointer-lowtag) (inst addu alloc-tn boxed) (storew ndescr result 0 other-pointer-lowtag) - (storew unboxed result code-code-size-slot other-pointer-lowtag) + (storew unboxed-arg result code-code-size-slot other-pointer-lowtag) (inst addu alloc-tn unboxed) (storew null-tn result code-entry-points-slot other-pointer-lowtag) (storew null-tn result code-debug-info-slot other-pointer-lowtag)))) diff --git a/src/compiler/mips/sanctify.lisp b/src/compiler/mips/sanctify.lisp index d100fe0..9841dc8 100644 --- a/src/compiler/mips/sanctify.lisp +++ b/src/compiler/mips/sanctify.lisp @@ -21,6 +21,5 @@ system-area-pointer unsigned-long)) (code-instructions component) - (* (code-header-ref component code-code-size-slot) - n-word-bytes))) + (%code-code-size component))) nil) diff --git a/src/compiler/ppc/alloc.lisp b/src/compiler/ppc/alloc.lisp index f903dd4..2730068 100644 --- a/src/compiler/ppc/alloc.lisp +++ b/src/compiler/ppc/alloc.lisp @@ -78,7 +78,7 @@ ;;;; Special purpose inline allocators. - +#!-gencgc (define-vop (allocate-code-object) (:args (boxed-arg :scs (any-reg)) (unboxed-arg :scs (any-reg))) @@ -86,10 +86,10 @@ (:temporary (:scs (non-descriptor-reg)) ndescr) (:temporary (:scs (non-descriptor-reg)) size) (:temporary (:scs (any-reg) :from (:argument 0)) boxed) - (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) unboxed) + (:temporary (:scs (non-descriptor-reg)) unboxed) (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag) (:generator 100 - (inst addi boxed boxed-arg (fixnumize (1+ code-trace-table-offset-slot))) + (inst addi boxed boxed-arg (fixnumize (1+ code-constants-offset))) (inst clrrwi boxed boxed n-lowtag-bits) (inst srwi unboxed unboxed-arg word-shift) (inst addi unboxed unboxed lowtag-mask) @@ -103,7 +103,7 @@ (inst slwi ndescr boxed (- n-widetag-bits word-shift)) (inst ori ndescr ndescr code-header-widetag) (storew ndescr result 0 other-pointer-lowtag) - (storew unboxed result code-code-size-slot other-pointer-lowtag) + (storew unboxed-arg result code-code-size-slot other-pointer-lowtag) (storew null-tn result code-entry-points-slot other-pointer-lowtag) (storew null-tn result code-debug-info-slot other-pointer-lowtag)))) diff --git a/src/compiler/ppc/sanctify.lisp b/src/compiler/ppc/sanctify.lisp index de4cd40..0eb6f8e 100644 --- a/src/compiler/ppc/sanctify.lisp +++ b/src/compiler/ppc/sanctify.lisp @@ -26,8 +26,7 @@ system-area-pointer unsigned-long)) (code-instructions component) - (* (code-header-ref component code-code-size-slot) - n-word-bytes))) + (%code-code-size component))) nil) diff --git a/src/compiler/sparc/alloc.lisp b/src/compiler/sparc/alloc.lisp index 8ba7aca..fdb8796 100644 --- a/src/compiler/sparc/alloc.lisp +++ b/src/compiler/sparc/alloc.lisp @@ -79,9 +79,9 @@ (:temporary (:scs (non-descriptor-reg)) ndescr) (:temporary (:scs (any-reg) :from (:argument 0)) boxed) (:temporary (:scs (non-descriptor-reg)) size) - (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) unboxed) + (:temporary (:scs (non-descriptor-reg)) unboxed) (:generator 100 - (inst add boxed boxed-arg (fixnumize (1+ code-trace-table-offset-slot))) + (inst add boxed boxed-arg (fixnumize (1+ code-constants-offset))) (inst and boxed (lognot lowtag-mask)) (inst srl unboxed unboxed-arg word-shift) (inst add unboxed lowtag-mask) @@ -100,7 +100,7 @@ (inst sll ndescr boxed (- n-widetag-bits word-shift)) (inst or ndescr code-header-widetag) (storew ndescr result 0 other-pointer-lowtag) - (storew unboxed result code-code-size-slot other-pointer-lowtag) + (storew unboxed-arg result code-code-size-slot other-pointer-lowtag) (storew null-tn result code-entry-points-slot other-pointer-lowtag) (storew null-tn result code-debug-info-slot other-pointer-lowtag)))) diff --git a/src/compiler/sparc/sanctify.lisp b/src/compiler/sparc/sanctify.lisp index 06bbfe0..ec4bd70 100644 --- a/src/compiler/sparc/sanctify.lisp +++ b/src/compiler/sparc/sanctify.lisp @@ -27,6 +27,5 @@ system-area-pointer unsigned-long)) (code-instructions component) - (* (code-header-ref component code-code-size-slot) - n-word-bytes))) + (%code-code-size component))) nil) diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp index b8d41a2..4d158b5 100644 --- a/src/compiler/target-disassem.lisp +++ b/src/compiler/target-disassem.lisp @@ -209,10 +209,9 @@ ;;; Code object layout: ;;; header-word -;;; code-size (starting from first inst, in words) +;;; code-size (starting from first inst, in bytes) ;;; entry-points (points to first function header) ;;; debug-info -;;; trace-table-offset (starting from first inst, in bytes) ;;; constant1 ;;; constant2 ;;; ... @@ -221,7 +220,6 @@ ;;; ... ;;; fun-headers and lra's buried in here randomly ;;; ... -;;; start of trace-table ;;; <padding to dual-word boundary> ;;; ;;; Function header layout (dual word aligned): @@ -320,23 +318,13 @@ ;;; Return the length of the instruction area in CODE-COMPONENT. (defun code-inst-area-length (code-component) (declare (type sb!kernel:code-component code-component)) - (sb!kernel:code-header-ref code-component - sb!vm:code-trace-table-offset-slot)) + (sb!kernel:%code-code-size code-component)) ;;; Return the address of the instruction area in CODE-COMPONENT. (defun code-inst-area-address (code-component) (declare (type sb!kernel:code-component code-component)) (sb!sys:sap-int (sb!kernel:code-instructions code-component))) -;;; unused as of sbcl-0.pre7.129 -#| -;;; Return the first function in CODE-COMPONENT. -(defun code-first-function (code-component) - (declare (type sb!kernel:code-component code-component)) - (sb!kernel:code-header-ref code-component - sb!vm:code-trace-table-offset-slot)) -|# - (defun segment-offs-to-code-offs (offset segment) (sb!sys:without-gcing (let* ((seg-base-addr (sb!sys:sap-int (funcall (seg-sap-maker segment)))) @@ -982,12 +970,9 @@ (declare (type compiled-function function)) (let* ((self (fun-self function)) (code (sb!kernel:fun-code-header self))) - (format t "Code-header ~S: size: ~S, trace-table-offset: ~S~%" + (format t "Code-header ~S: size: ~S~%" code - (sb!kernel:code-header-ref code - sb!vm:code-code-size-slot) - (sb!kernel:code-header-ref code - sb!vm:code-trace-table-offset-slot)) + (sb!kernel:%code-code-size code)) (do ((fun (sb!kernel:code-header-ref code sb!vm:code-entry-points-slot) (fun-next fun))) ((null fun)) @@ -1690,19 +1675,16 @@ (if (null code) (return-from get-code-constant-absolute (values nil nil))) (sb!sys:without-gcing - (let* ((n-header-words (sb!kernel:get-header-data code)) - (n-code-words (sb!kernel:%code-code-size code)) + (let* ((n-header-bytes (* (sb!kernel:get-header-data code) sb!vm:n-word-bytes)) + (n-code-bytes (sb!kernel:%code-code-size code)) (header-addr (- (sb!kernel:get-lisp-obj-address code) - sb!vm:other-pointer-lowtag))) - (cond ((<= header-addr addr (+ header-addr (ash (1- n-header-words) - sb!vm:word-shift))) + sb!vm:other-pointer-lowtag)) + (code-start (+ header-addr n-header-bytes))) + (cond ((< header-addr addr code-start) (values (sb!sys:sap-ref-lispobj (sb!sys:int-sap addr) 0) t)) ;; guess it's a non-descriptor constant from the instructions ((and (eq width :qword) - (< n-header-words - ;; convert ADDR to header-relative Nth word - (ash (- addr header-addr) (- sb!vm:word-shift)) - (+ n-header-words n-code-words))) + (< code-start addr (+ code-start n-code-bytes))) (values (make-code-constant-raw :value (sb!sys:sap-ref-64 (sb!sys:int-sap addr) 0)) t)) diff --git a/src/runtime/alloc.c b/src/runtime/alloc.c index 92e237b..b8a4772 100644 --- a/src/runtime/alloc.c +++ b/src/runtime/alloc.c @@ -196,20 +196,20 @@ alloc_sap(void *ptr) lispobj alloc_code_object (unsigned boxed, unsigned unboxed) { struct code * code; - /* Coming in, boxed is the number of boxed words requested. - * Converting it to a fixnum makes it measured in bytes. It's also - * rounded up to double word along the way. */ + /* boxed is the number of constants, add other slots, align it to + * two words, so that the code start is aligned, and convert it to + * bytes. */ boxed = (boxed + 1 + - (offsetof(struct code, trace_table_offset) >> + (offsetof(struct code, constants) >> WORD_SHIFT)) << WORD_SHIFT; boxed &= ~LOWTAG_MASK; - /* Unboxed is in bytes, round it up to double word boundary. Now - * it's also a fixnum containing the number of unboxed words. */ - unboxed += LOWTAG_MASK; - unboxed &= ~LOWTAG_MASK; + /* Unboxed is the size of instructions in bytes. It will be stored + * as is in the code_size slot, but it needs to be allocated with + * double-word alignment. */ + unsigned unboxed_aligned = (unboxed + LOWTAG_MASK) & ~LOWTAG_MASK; - code = (struct code *)pa_alloc(boxed + unboxed, CODE_PAGE_FLAG); + code = (struct code *)pa_alloc(boxed + unboxed_aligned, CODE_PAGE_FLAG); /* It used to be that even on gencgc builds the * ALLOCATE-CODE-OBJECT VOP did all this initialization within @@ -218,7 +218,7 @@ alloc_code_object (unsigned boxed, unsigned unboxed) { lose("alloc_code_object called with GC enabled."); boxed = boxed << (N_WIDETAG_BITS - WORD_SHIFT); code->header = boxed | CODE_HEADER_WIDETAG; - code->code_size = unboxed >> (WORD_SHIFT - N_FIXNUM_TAG_BITS); + code->code_size = make_fixnum(unboxed); code->entry_points = NIL; code->debug_info = NIL; return make_lispobj(code, OTHER_POINTER_LOWTAG); diff --git a/src/runtime/breakpoint.c b/src/runtime/breakpoint.c index 3c99cc4..21e12b2 100644 --- a/src/runtime/breakpoint.c +++ b/src/runtime/breakpoint.c @@ -116,7 +116,7 @@ static long compute_offset(os_context_t *context, lispobj code) return 0; else { uword_t offset = pc - code_start; - if (offset >= (N_WORD_BYTES * fixnum_value(codeptr->code_size))) + if (offset >= fixnum_value(codeptr->code_size)) return 0; else return make_fixnum(offset); diff --git a/src/runtime/gc-common.c b/src/runtime/gc-common.c index ca48daf..11ef7f9 100644 --- a/src/runtime/gc-common.c +++ b/src/runtime/gc-common.c @@ -250,7 +250,7 @@ trans_code(struct code *code) /* prepare to transport the code vector */ l_code = (lispobj) LOW_WORD(code) | OTHER_POINTER_LOWTAG; - ncode_words = fixnum_value(code->code_size); + ncode_words = fixnum_word_value(code->code_size); nheader_words = HeaderValue(code->header); nwords = ncode_words + nheader_words; nwords = CEILING(nwords, 2); @@ -333,7 +333,7 @@ scav_code_header(lispobj *where, lispobj object) struct simple_fun *function_ptr; /* untagged pointer to entry point */ code = (struct code *) where; - n_code_words = fixnum_value(code->code_size); + n_code_words = fixnum_word_value(code->code_size); n_header_words = HeaderValue(object); n_words = n_code_words + n_header_words; n_words = CEILING(n_words, 2); @@ -381,7 +381,7 @@ size_code_header(lispobj *where) code = (struct code *) where; - ncode_words = fixnum_value(code->code_size); + ncode_words = fixnum_word_value(code->code_size); nheader_words = HeaderValue(code->header); nwords = ncode_words + nheader_words; nwords = CEILING(nwords, 2); @@ -1883,7 +1883,7 @@ scan_weak_hash_tables (void) static sword_t scav_lose(lispobj *where, lispobj object) { - lose("no scavenge function for object 0x%08x (widetag 0x%x)\n", + lose("no scavenge function for object %p (widetag 0x%x)\n", (uword_t)object, widetag_of(*where)); diff --git a/src/runtime/gencgc.c b/src/runtime/gencgc.c index 31ce079..43b148f 100644 --- a/src/runtime/gencgc.c +++ b/src/runtime/gencgc.c @@ -1667,7 +1667,7 @@ sniff_code_object(struct code *code, os_vm_size_t displacement) FSHOW((stderr, "/sniffing code: %p, %lu\n", code, displacement)); - ncode_words = fixnum_value(code->code_size); + ncode_words = fixnum_word_value(code->code_size); nheader_words = HeaderValue(*(lispobj *)code); nwords = ncode_words + nheader_words; @@ -1840,7 +1840,7 @@ gencgc_apply_code_fixups(struct code *old_code, struct code *new_code) lispobj fixups = NIL; struct vector *fixups_vector; - ncode_words = fixnum_value(new_code->code_size); + ncode_words = fixnum_word_value(new_code->code_size); nheader_words = HeaderValue(*(lispobj *)new_code); nwords = ncode_words + nheader_words; /* FSHOW((stderr, @@ -3038,17 +3038,9 @@ verify_space(lispobj *start, size_t words) /* Check that it's not in the dynamic space. * FIXME: Isn't is supposed to be OK for code * objects to be in the dynamic space these days? */ + /* It is for byte compiled code, but there's + * no byte compilation in SBCL anymore. */ if (is_in_dynamic_space - /* It's ok if it's byte compiled code. The trace - * table offset will be a fixnum if it's x86 - * compiled code - check. - * - * FIXME: #^#@@! lack of abstraction here.. - * This line can probably go away now that - * there's no byte compiler, but I've got - * too much to worry about right now to try - * to make sure. -- WHN 2001-10-06 */ - && fixnump(code->trace_table_offset) /* Only when enabled */ && verify_dynamic_code_check) { FSHOW((stderr, @@ -3056,7 +3048,7 @@ verify_space(lispobj *start, size_t words) start)); } - ncode_words = fixnum_value(code->code_size); + ncode_words = fixnum_word_value(code->code_size); nheader_words = HeaderValue(object); nwords = ncode_words + nheader_words; nwords = CEILING(nwords, 2); diff --git a/src/runtime/purify.c b/src/runtime/purify.c index ebb237d..091be5c 100644 --- a/src/runtime/purify.c +++ b/src/runtime/purify.c @@ -281,7 +281,7 @@ ptrans_code(lispobj thing) lispobj func, result; code = (struct code *)native_pointer(thing); - nwords = CEILING(HeaderValue(code->header) + fixnum_value(code->code_size), + nwords = CEILING(HeaderValue(code->header) + fixnum_word_value(code->code_size), 2); new = (struct code *)newspace_alloc(nwords,1); /* constant */ @@ -306,20 +306,10 @@ ptrans_code(lispobj thing) /* Arrange to scavenge the debug info later. */ pscav_later(&new->debug_info, 1); - /* FIXME: why would this be a fixnum? */ - /* "why" is a hard word, but apparently for compiled functions the - trace_table_offset contains the length of the instructions, as - a fixnum. See CODE-INST-AREA-LENGTH in - src/compiler/target-disassem.lisp. -- CSR, 2004-01-08 */ - if (!(fixnump(new->trace_table_offset))) -#if 0 - pscav(&new->trace_table_offset, 1, 0); -#else - new->trace_table_offset = NIL; /* limit lifetime */ -#endif - /* Scavenge the constants. */ - pscav(new->constants, HeaderValue(new->header)-5, 1); + pscav(new->constants, + HeaderValue(new->header) - (offsetof(struct code, constants) >> WORD_SHIFT), + 1); /* Scavenge all the functions. */ pscav(&new->entry_points, 1, 1); diff --git a/src/runtime/runtime.h b/src/runtime/runtime.h index fec8c77..d9d9328 100644 --- a/src/runtime/runtime.h +++ b/src/runtime/runtime.h @@ -334,6 +334,15 @@ fixnum_value(lispobj n) return n >> N_FIXNUM_TAG_BITS; } +static inline sword_t +fixnum_word_value(lispobj n) +{ + /* Convert bytes into words, double-word aligned. */ + sword_t x = ((n >> N_FIXNUM_TAG_BITS) + LOWTAG_MASK) & ~LOWTAG_MASK; + + return x >> WORD_SHIFT; +} + #if defined(LISP_FEATURE_WIN32) /* KLUDGE: Avoid double definition of boolean by rpcndr.h included via * shlobj.h. ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: stassats <sta...@us...> - 2014-06-17 21:56:37
|
The branch "master" has been updated in SBCL: via d31e787921c0b704d77f4d89ebae8b6008bc6b53 (commit) from 11471916c5f556f759e6df433d7c569133251b77 (commit) - Log ----------------------------------------------------------------- commit d31e787921c0b704d77f4d89ebae8b6008bc6b53 Author: Stas Boukarev <sta...@gm...> Date: Sat Jun 14 23:30:03 2014 +0400 Remove trace-table. It hasn't been ever used in SBCL, and it was supposed to be used for making precise backtraces for the precise GC. There are probably better ways to achieve precises backtraces. --- build-order.lisp-expr | 2 - package-data-list.lisp-expr | 9 ++---- src/compiler/alpha/call.lisp | 43 +++++++-------------------- src/compiler/arm/call.lisp | 42 ++++++-------------------- src/compiler/codegen.lisp | 3 -- src/compiler/dump.lisp | 24 ++++---------- src/compiler/early-c.lisp | 1 - src/compiler/generic/parms.lisp | 6 ---- src/compiler/generic/target-core.lisp | 25 ++------------- src/compiler/hppa/call.lisp | 47 +++++++---------------------- src/compiler/main.lisp | 4 +-- src/compiler/mips/call.lisp | 53 ++++++++------------------------- src/compiler/ppc/call.lisp | 48 +++++++---------------------- src/compiler/sparc/call.lisp | 48 +++++++---------------------- src/compiler/trace-table.lisp | 42 -------------------------- src/compiler/x86-64/call.lisp | 40 +++++------------------- src/compiler/x86/call.lisp | 39 +++++------------------ 17 files changed, 102 insertions(+), 374 deletions(-) diff --git a/build-order.lisp-expr b/build-order.lisp-expr index 0a0d143..f8b7030 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -495,8 +495,6 @@ ("src/compiler/disassem") ("src/compiler/assem") - ("src/compiler/trace-table") ; needs EMIT-LABEL macro from compiler/assem.lisp - ("src/code/debug-info") ;; Compiling this requires fop definitions from code/fop.lisp and ;; trace table definitions from compiler/trace-table.lisp. diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 520dd8c..0da62c0 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -308,7 +308,7 @@ of SBCL which maintained the CMU-CL-style split into two packages.)" "NLX-ENTRY" "NLX-ENTRY-MULTIPLE" "NODE-STACK-ALLOCATE-P" "NON-DESCRIPTOR-STACK" "NOTE-ENVIRONMENT-START" - "NOTE-THIS-LOCATION" "OPTIMIZER" "PACK-TRACE-TABLE" + "NOTE-THIS-LOCATION" "OPTIMIZER" "PARSE-EVAL-WHEN-SITUATIONS" "POLICY" "%%POP-DX" @@ -336,7 +336,7 @@ of SBCL which maintained the CMU-CL-style split into two packages.)" "TN" "TN-OFFSET" "TN-P" "TN-REF" "TN-REF-ACROSS" "TN-REF-LOAD-TN" "TN-REF-NEXT" "TN-REF-NEXT-REF" "TN-REF-P" "TN-REF-TARGET" "TN-REF-TN" "TN-REF-VOP" "TN-REF-WRITE-P" "TN-SC" "TN-VALUE" - "TRACE-TABLE-ENTRY" "TYPE-CHECK-ERROR" "UNBIND" "UNBIND-TO-HERE" + "TYPE-CHECK-ERROR" "UNBIND" "UNBIND-TO-HERE" "UNSAFE" "UNSAFELY-FLUSHABLE" "UNWIND" "UWP-ENTRY" "VERIFY-ARG-COUNT" "WRITE-PACKED-BIT-VECTOR" "WRITE-VAR-INTEGER" "WRITE-VAR-STRING" "XEP-ALLOCATE-FRAME" @@ -2935,10 +2935,7 @@ structure representations" #!+linkage-table "LINKAGE-TABLE-SPACE-END" #!+linkage-table "LINKAGE-TABLE-ENTRY-SIZE" #!+sb-safepoint "GC-SAFEPOINT-PAGE-ADDR" - "TLS-SIZE" - "TRACE-TABLE-CALL-SITE" - "TRACE-TABLE-FUN-EPILOGUE" "TRACE-TABLE-FUN-PROLOGUE" - "TRACE-TABLE-NORMAL" "N-WIDETAG-BITS" "WIDETAG-MASK" + "TLS-SIZE" "N-WIDETAG-BITS" "WIDETAG-MASK" "UNBOUND-MARKER-WIDETAG" "NO-TLS-VALUE-MARKER-WIDETAG" "UNSIGNED-REG-SC-NUMBER" "UNSIGNED-STACK-SC-NUMBER" diff --git a/src/compiler/alpha/call.lisp b/src/compiler/alpha/call.lisp index 7143f19..d5ab251 100644 --- a/src/compiler/alpha/call.lisp +++ b/src/compiler/alpha/call.lisp @@ -150,7 +150,6 @@ ;; Make sure the function is aligned, and drop a label pointing to ;; this function header. (emit-alignment n-lowtag-bits) - (trace-table-entry trace-table-fun-prologue) (emit-label start-lab) ;; Allocate function header. (inst simple-fun-header-word) @@ -173,15 +172,13 @@ (when nfp (inst subq nsp-tn (bytes-needed-for-non-descriptor-stack-frame) nsp-tn) - (move nsp-tn nfp))) - (trace-table-entry trace-table-normal))) + (move nsp-tn nfp))))) (define-vop (allocate-frame) (:results (res :scs (any-reg)) (nfp :scs (any-reg))) (:info callee) (:generator 2 - (trace-table-entry trace-table-fun-prologue) (move csp-tn res) (inst lda csp-tn @@ -190,8 +187,7 @@ (when (ir2-physenv-number-stack-p callee) (inst subq nsp-tn (bytes-needed-for-non-descriptor-stack-frame) nsp-tn) - (move nsp-tn nfp)) - (trace-table-entry trace-table-normal))) + (move nsp-tn nfp)))) ;;; Allocate a partial frame for passing stack arguments in a full ;;; call. NARGS is the number of arguments passed. If no stack @@ -461,12 +457,10 @@ default-value-8 (let ((callee-nfp (callee-nfp-tn callee))) (maybe-load-stack-nfp-tn callee-nfp nfp temp)) (maybe-load-stack-tn cfp-tn fp) - (trace-table-entry trace-table-call-site) (inst compute-lra-from-code (callee-return-pc-tn callee) code-tn label temp) (note-this-location vop :call-site) (inst br zero-tn target) - (trace-table-entry trace-table-normal) (emit-return-pc label) (default-unknown-values vop values nvals move-temp temp label) (maybe-load-stack-nfp-tn cur-nfp nfp-save temp)))) @@ -498,12 +492,10 @@ default-value-8 (let ((callee-nfp (callee-nfp-tn callee))) (maybe-load-stack-nfp-tn callee-nfp nfp temp)) (maybe-load-stack-tn cfp-tn fp) - (trace-table-entry trace-table-call-site) (inst compute-lra-from-code (callee-return-pc-tn callee) code-tn label temp) (note-this-location vop :call-site) (inst bsr zero-tn target) - (trace-table-entry trace-table-normal) (emit-return-pc label) (note-this-location vop :unknown-return) (receive-unknown-values values-start nvals start count label temp) @@ -538,12 +530,10 @@ default-value-8 (let ((callee-nfp (callee-nfp-tn callee))) (maybe-load-stack-nfp-tn callee-nfp nfp temp)) (maybe-load-stack-tn cfp-tn fp) - (trace-table-entry trace-table-call-site) (inst compute-lra-from-code (callee-return-pc-tn callee) code-tn label temp) (note-this-location vop :call-site) (inst bsr zero-tn target) - (trace-table-entry trace-table-normal) (emit-return-pc label) (note-this-location vop :known-return) (maybe-load-stack-nfp-tn cur-nfp nfp-save temp)))) @@ -568,7 +558,6 @@ default-value-8 (:ignore val-locs vals) (:vop-var vop) (:generator 6 - (trace-table-entry trace-table-fun-epilogue) (maybe-load-stack-tn ocfp-temp ocfp) (maybe-load-stack-tn return-pc-temp return-pc) (move cfp-tn csp-tn) @@ -578,8 +567,7 @@ default-value-8 nsp-tn))) (inst subq return-pc-temp (- other-pointer-lowtag n-word-bytes) lip) (move ocfp-temp cfp-tn) - (inst ret zero-tn lip 1) - (trace-table-entry trace-table-normal))) + (inst ret zero-tn lip 1))) ;;;; full call: ;;;; @@ -783,8 +771,7 @@ default-value-8 '(move new-fp cfp-tn) '(if (> nargs register-arg-count) (move new-fp cfp-tn) - (move csp-tn cfp-tn))) - (trace-table-entry trace-table-call-site)))) + (move csp-tn cfp-tn)))))) ((nil)))))) ,@(if named @@ -841,17 +828,15 @@ default-value-8 ,@(ecase return (:fixed - '((trace-table-entry trace-table-normal) - (emit-return-pc lra-label) + '((emit-return-pc lra-label) (default-unknown-values vop values nvals - move-temp temp lra-label) + move-temp temp lra-label) (maybe-load-stack-nfp-tn cur-nfp nfp-save temp))) (:unknown - '((trace-table-entry trace-table-normal) - (emit-return-pc lra-label) + '((emit-return-pc lra-label) (note-this-location vop :unknown-return) (receive-unknown-values values-start nvals start count - lra-label temp) + lra-label temp) (maybe-load-stack-nfp-tn cur-nfp nfp-save temp))) (:tail)))))) @@ -916,7 +901,6 @@ default-value-8 (:vop-var vop) (:generator 6 ;; Clear the number stack. - (trace-table-entry trace-table-fun-epilogue) (let ((cur-nfp (current-nfp-tn vop))) (when cur-nfp (inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame) @@ -931,8 +915,7 @@ default-value-8 (inst addq return-pc (* 2 n-word-bytes) temp) (unless (location= ra return-pc) (inst move ra return-pc)) - (inst ret zero-tn temp 1)) - (trace-table-entry trace-table-normal))) + (inst ret zero-tn temp 1)))) ;;; Do unknown-values return of a fixed number of values. The Values ;;; are required to be set up in the standard passing locations. Nvals @@ -967,7 +950,6 @@ default-value-8 (:vop-var vop) (:generator 6 ;; Clear the number stack. - (trace-table-entry trace-table-fun-epilogue) (let ((cur-nfp (current-nfp-tn vop))) (when cur-nfp (inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame) @@ -989,8 +971,7 @@ default-value-8 (dolist (reg (subseq (list a0 a1 a2 a3 a4 a5) nvals)) (move null-tn reg))) ;; And away we go. - (lisp-return return-pc lip) - (trace-table-entry trace-table-normal))) + (lisp-return return-pc lip))) ;;; Do unknown-values return of an arbitrary number of values (passed ;;; on the stack.) We check for the common case of a single return @@ -1019,7 +1000,6 @@ default-value-8 (:vop-var vop) (:generator 13 - (trace-table-entry trace-table-fun-epilogue) (let ((not-single (gen-label))) ;; Clear the number stack. (let ((cur-nfp (current-nfp-tn vop))) @@ -1045,8 +1025,7 @@ default-value-8 (move vals-arg vals) (move nvals-arg nvals) (inst li (make-fixup 'return-multiple :assembly-routine) temp) - (inst jmp zero-tn temp)) - (trace-table-entry trace-table-normal))) + (inst jmp zero-tn temp)))) ;;;; XEP hackery diff --git a/src/compiler/arm/call.lisp b/src/compiler/arm/call.lisp index 239e33d..4315142 100644 --- a/src/compiler/arm/call.lisp +++ b/src/compiler/arm/call.lisp @@ -153,7 +153,6 @@ ;; Make sure the function is aligned, and drop a label pointing to this ;; function header. (emit-alignment n-lowtag-bits) - (trace-table-entry trace-table-fun-prologue) (emit-label start-lab) ;; Allocate function header. (inst simple-fun-header-word) @@ -170,15 +169,13 @@ (when nfp-tn (let* ((nbytes (bytes-needed-for-non-descriptor-stack-frame))) (inst sub nfp-tn nsp-tn nbytes) - (move nsp-tn nfp-tn))))) - (trace-table-entry trace-table-normal))) + (move nsp-tn nfp-tn))))))) (define-vop (allocate-frame) (:results (res :scs (any-reg)) (nfp :scs (any-reg))) (:info callee) (:generator 2 - (trace-table-entry trace-table-fun-prologue) (load-csp res) (composite-immediate-instruction add nfp res @@ -188,8 +185,7 @@ (when (ir2-physenv-number-stack-p callee) (let* ((nbytes (bytes-needed-for-non-descriptor-stack-frame))) (inst sub nfp nsp-tn nbytes) - (inst mov nsp-tn nfp))) - (trace-table-entry trace-table-normal))) + (inst mov nsp-tn nfp))))) ;;; Allocate a partial frame for passing stack arguments in a full call. Nargs ;;; is the number of arguments passed. If no stack arguments are passed, then @@ -653,7 +649,6 @@ (:temporary (:scs (interior-reg)) lip) (:ignore arg-locs args ocfp) (:generator 5 - (trace-table-entry trace-table-call-site) (let ((label (gen-label)) (cur-nfp (current-nfp-tn vop))) (when cur-nfp @@ -671,8 +666,7 @@ ;; alpha uses (maybe-load-stack-nfp-tn cur-nfp nfp-save temp) ;; instead of the clause below (when cur-nfp - (load-stack-tn cur-nfp nfp-save))) - (trace-table-entry trace-table-normal))) + (load-stack-tn cur-nfp nfp-save))))) ;;; Non-TR local call for a variable number of return values passed according @@ -695,7 +689,6 @@ (:temporary (:scs (non-descriptor-reg)) temp) (:temporary (:scs (interior-reg)) lip) (:generator 20 - (trace-table-entry trace-table-call-site) (let ((label (gen-label)) (cur-nfp (current-nfp-tn vop))) (when cur-nfp @@ -713,8 +706,7 @@ (note-this-location vop :unknown-return) (receive-unknown-values values-start nvals start count label temp lip) (when cur-nfp - (load-stack-tn cur-nfp nfp-save))) - (trace-table-entry trace-table-normal))) + (load-stack-tn cur-nfp nfp-save))))) ;;;; Local call with known values return: @@ -737,7 +729,6 @@ (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) (:temporary (:scs (interior-reg)) lip) (:generator 5 - (trace-table-entry trace-table-call-site) (let ((label (gen-label)) (cur-nfp (current-nfp-tn vop))) (when cur-nfp @@ -753,8 +744,7 @@ (emit-return-pc label) (note-this-location vop :known-return) (when cur-nfp - (load-stack-tn cur-nfp nfp-save))) - (trace-table-entry trace-table-normal))) + (load-stack-tn cur-nfp nfp-save))))) ;;; Return from known values call. We receive the return locations as ;;; arguments to terminate their lifetimes in the returning function. We @@ -774,7 +764,6 @@ (:ignore val-locs vals) (:vop-var vop) (:generator 6 - (trace-table-entry trace-table-fun-epilogue) (maybe-load-stack-tn old-fp-temp old-fp) (maybe-load-stack-tn return-pc-temp return-pc) (store-csp cfp-tn) @@ -783,8 +772,7 @@ (inst add cur-nfp cur-nfp (bytes-needed-for-non-descriptor-stack-frame)) (move nsp-tn cur-nfp))) (move cfp-tn old-fp-temp) - (lisp-return return-pc-temp :known) - (trace-table-entry trace-table-normal))) + (lisp-return return-pc-temp :known))) ;;;; Full call: ;;; @@ -896,7 +884,6 @@ (if (eq return :tail) 0 10) 15 (if (eq return :unknown) 25 0)) - (trace-table-entry trace-table-call-site) (let* ((cur-nfp (current-nfp-tn vop)) ,@(unless (eq return :tail) '((lra-label (gen-label)))) @@ -1020,9 +1007,7 @@ lra-label temp lip) (when cur-nfp (load-stack-tn cur-nfp nfp-save)))) - (:tail))) - (trace-table-entry trace-table-normal)))) - + (:tail)))))) (define-full-call call nil :fixed nil) (define-full-call call-named t :fixed nil) @@ -1072,7 +1057,6 @@ (:ignore value) (:vop-var vop) (:generator 6 - (trace-table-entry trace-table-fun-epilogue) ;; Clear the number stack. (let ((cur-nfp (current-nfp-tn vop))) (when cur-nfp @@ -1082,8 +1066,7 @@ (store-csp cfp-tn) (move cfp-tn old-fp) ;; Out of here. - (lisp-return return-pc :single-value) - (trace-table-entry trace-table-normal))) + (lisp-return return-pc :single-value))) ;;; Do unknown-values return of a fixed number of values. The Values are ;;; required to be set up in the standard passing locations. Nvals is the @@ -1112,7 +1095,6 @@ (:temporary (:sc any-reg :offset ocfp-offset) val-ptr) (:vop-var vop) (:generator 6 - (trace-table-entry trace-table-fun-epilogue) (move lra return-pc) ;; Clear the number stack. (let ((cur-nfp (current-nfp-tn vop))) @@ -1141,8 +1123,7 @@ (dolist (reg (subseq (list r0 r1 r2) nvals)) (move reg null-tn))) ;; And away we go. - (lisp-return lra :multiple-values))) - (trace-table-entry trace-table-normal))) + (lisp-return lra :multiple-values))))) ;;; Do unknown-values return of an arbitrary number of values (passed ;;; on the stack.) We check for the common case of a single return @@ -1162,7 +1143,6 @@ (:temporary (:sc descriptor-reg :offset r0-offset) r0) (:vop-var vop) (:generator 13 - (trace-table-entry trace-table-fun-epilogue) (move lra lra-arg) ;; Clear the number stack. (let ((cur-nfp (current-nfp-tn vop))) @@ -1188,9 +1168,7 @@ (move nvals nvals-arg) (inst ldr pc-tn (@ fixup)) FIXUP - (inst word (make-fixup 'return-multiple :assembly-routine)) - - (trace-table-entry trace-table-normal))) + (inst word (make-fixup 'return-multiple :assembly-routine)))) ;;; Single-stepping diff --git a/src/compiler/codegen.lisp b/src/compiler/codegen.lisp index b0107e1..7260240 100644 --- a/src/compiler/codegen.lisp +++ b/src/compiler/codegen.lisp @@ -55,7 +55,6 @@ ;;;; specials used during code generation -(defvar *trace-table-info*) (defvar *code-segment* nil) (defvar *elsewhere* nil) (defvar *elsewhere-label* nil) @@ -135,7 +134,6 @@ "~|~%assembly code for ~S~2%" component)) (let ((prev-env nil) - (*trace-table-info* nil) (*prev-segment* nil) (*prev-vop* nil) (*fixup-notes* nil)) @@ -201,7 +199,6 @@ *constant-vector* nil *constant-table* nil)) (values (sb!assem:finalize-segment *code-segment*) - (nreverse *trace-table-info*) *fixup-notes*))) (defun emit-label-elsewhere (label) diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp index 4a40de1..472a611 100644 --- a/src/compiler/dump.lisp +++ b/src/compiler/dump.lisp @@ -1013,23 +1013,16 @@ (defun dump-code-object (component code-segment code-length - trace-table-as-list fixups fasl-output) (declare (type component component) - (list trace-table-as-list) (type index code-length) (type fasl-output fasl-output)) (let* ((2comp (component-info component)) (constants (sb!c::ir2-component-constants 2comp)) - (header-length (length constants)) - (packed-trace-table (pack-trace-table trace-table-as-list)) - (total-length (+ code-length - (* (length packed-trace-table) - sb!c::tt-bytes-per-entry)))) - + (header-length (length constants))) (collect ((patches)) ;; Dump the offset of the trace table. @@ -1082,22 +1075,21 @@ (push info-handle (fasl-output-debug-info fasl-output)))) (let ((num-consts (- header-length sb!vm:code-trace-table-offset-slot))) - (cond ((and (< num-consts #x100) (< total-length #x10000)) + (cond ((and (< num-consts #x100) (< code-length #x10000)) (dump-fop 'fop-small-code fasl-output) (dump-byte num-consts fasl-output) - (dump-integer-as-n-bytes total-length (/ sb!vm:n-word-bytes 2) fasl-output)) + (dump-integer-as-n-bytes code-length (/ sb!vm:n-word-bytes 2) fasl-output)) (t (dump-fop 'fop-code fasl-output) (dump-word num-consts fasl-output) - (dump-word total-length fasl-output)))) + (dump-word code-length fasl-output)))) ;; These two dumps are only ones which contribute to our - ;; TOTAL-LENGTH value. + ;; LENGTH value. (dump-segment code-segment code-length fasl-output) - (dump-specialized-vector packed-trace-table fasl-output :data-only t) ;; DUMP-FIXUPS does its own internal DUMP-FOPs: the bytes it - ;; dumps aren't included in the TOTAL-LENGTH passed to our + ;; dumps aren't included in the LENGTH passed to our ;; FOP-CODE/FOP-SMALL-CODE fop. (dump-fixups fixups fasl-output) @@ -1155,10 +1147,9 @@ (defun fasl-dump-component (component code-segment code-length - trace-table fixups file) - (declare (type component component) (list trace-table)) + (declare (type component component)) (declare (type fasl-output file)) (dump-fop 'fop-verify-table-size file) @@ -1172,7 +1163,6 @@ (let ((code-handle (dump-code-object component code-segment code-length - trace-table fixups file)) (2comp (component-info component))) diff --git a/src/compiler/early-c.lisp b/src/compiler/early-c.lisp index 48b852e..dc45975 100644 --- a/src/compiler/early-c.lisp +++ b/src/compiler/early-c.lisp @@ -113,7 +113,6 @@ (defvar *source-info*) (defvar *source-plist*) (defvar *source-namestring*) -(defvar *trace-table*) (defvar *undefined-warnings*) (defvar *warnings-p*) (defvar *lambda-conversions*) diff --git a/src/compiler/generic/parms.lisp b/src/compiler/generic/parms.lisp index 4a681c1..dbda8e3 100644 --- a/src/compiler/generic/parms.lisp +++ b/src/compiler/generic/parms.lisp @@ -205,9 +205,3 @@ (progn (def!constant +highest-normal-generation+ 5) (def!constant +pseudo-static-generation+ 6)) - -(defenum () - trace-table-normal - trace-table-call-site - trace-table-fun-prologue - trace-table-fun-epilogue) diff --git a/src/compiler/generic/target-core.lisp b/src/compiler/generic/target-core.lisp index 32e9ed8..a3153bc 100644 --- a/src/compiler/generic/target-core.lisp +++ b/src/compiler/generic/target-core.lisp @@ -47,24 +47,19 @@ ;;; Dump a component to core. We pass in the assembler fixups, code ;;; vector and node info. -(defun make-core-component (component segment length trace-table fixup-notes object) +(defun make-core-component (component segment length fixup-notes object) (declare (type component component) (type sb!assem:segment segment) (type index length) - (list trace-table fixup-notes) + (list fixup-notes) (type core-object object)) (without-gcing (let* ((2comp (component-info component)) (constants (ir2-component-constants 2comp)) - (trace-table (pack-trace-table trace-table)) - (trace-table-len (length trace-table)) - (trace-table-bits (* trace-table-len tt-bits-per-entry)) - (total-length (+ length - (ceiling trace-table-bits sb!vm:n-byte-bits))) (box-num (- (length constants) sb!vm:code-trace-table-offset-slot)) - (code-obj (allocate-code-object box-num total-length)) + (code-obj (allocate-code-object box-num length)) (fill-ptr (code-instructions code-obj))) - (declare (type index box-num total-length)) + (declare (type index box-num length)) (let ((v (sb!assem:segment-contents-as-vector segment))) (declare (type (simple-array sb!assem:assembly-unit 1) v)) @@ -85,18 +80,6 @@ (setf (code-header-ref code-obj sb!vm:code-trace-table-offset-slot) length) - ;; KLUDGE: the "old" COPY-TO-SYSTEM-AREA automagically worked if - ;; somebody changed the number of bytes in a trace table entry. - ;; This version is a bit more fragile; if only there were some way - ;; to insulate ourselves against changes like that... - ;; - ;; Then again, PACK-TRACE-TABLE in src/compiler/trace-table.lisp - ;; doesn't appear to do anything interesting, returning a 0-length - ;; array. So it seemingly doesn't matter what we do here. Is this - ;; stale code? - ;; --njf, 2005-03-23 - (copy-ub16-to-system-area trace-table 0 fill-ptr 0 trace-table-len) - (do ((index sb!vm:code-constants-offset (1+ index))) ((>= index (length constants))) (let ((const (aref constants index))) diff --git a/src/compiler/hppa/call.lisp b/src/compiler/hppa/call.lisp index cfaedde..fdb7064 100644 --- a/src/compiler/hppa/call.lisp +++ b/src/compiler/hppa/call.lisp @@ -154,7 +154,6 @@ ;; Make sure the function is aligned, and drop a label pointing to this ;; function header. (emit-alignment n-lowtag-bits) - (trace-table-entry trace-table-fun-prologue) (emit-label start-lab) ;; Allocate function header. (inst simple-fun-header-word) @@ -175,23 +174,20 @@ (when nfp (move nsp-tn nfp) (inst addi (bytes-needed-for-non-descriptor-stack-frame) - nsp-tn nsp-tn))) - (trace-table-entry trace-table-normal))) + nsp-tn nsp-tn))))) (define-vop (allocate-frame) (:results (res :scs (any-reg)) (nfp :scs (any-reg))) (:info callee) (:generator 2 - (trace-table-entry trace-table-fun-prologue) (move csp-tn res) (inst addi (* n-word-bytes (sb-allocated-size 'control-stack)) csp-tn csp-tn) (when (ir2-physenv-number-stack-p callee) (move nsp-tn nfp) (inst addi (bytes-needed-for-non-descriptor-stack-frame) - nsp-tn nsp-tn)) - (trace-table-entry trace-table-normal))) + nsp-tn nsp-tn)))) ;;; Allocate a partial frame for passing stack arguments in a full call. Nargs ;;; is the number of arguments passed. If no stack arguments are passed, then @@ -339,15 +335,13 @@ default-value-8 (aver defaults) (assemble (*elsewhere*) (emit-label default-stack-vals) - (trace-table-entry trace-table-fun-prologue) (do ((remaining defaults (cdr remaining))) ((null remaining)) (let ((def (car remaining))) (emit-label (car def)) (when (null (cdr remaining)) (inst b defaulting-done)) - (store-stack-tn (cdr def) null-tn))) - (trace-table-entry trace-table-normal))))) + (store-stack-tn (cdr def) null-tn))))))) (when lra-label (inst compute-code-from-lra code-tn lra-label temp code-tn))))) (values)) @@ -389,7 +383,6 @@ default-value-8 (emit-label done) (assemble (*elsewhere*) - (trace-table-entry trace-table-fun-prologue) (emit-label variable-values) (when lra-label (inst compute-code-from-lra code-tn lra-label temp code-tn)) @@ -399,8 +392,7 @@ default-value-8 (storew (first arg) args i)) (move args start) (inst b done) - (move nargs count t) - (trace-table-entry trace-table-normal))) + (move nargs count t))) (values)) ;;; VOP that can be inherited by unknown values receivers. The main thing this @@ -471,12 +463,10 @@ default-value-8 (when callee-nfp (maybe-load-stack-tn callee-nfp nfp))) (maybe-load-stack-tn cfp-tn cfp) - (trace-table-entry trace-table-call-site) (inst compute-lra-from-code code-tn label temp (callee-return-pc-tn callee)) (note-this-location vop :call-site) (inst b target :nullify t) - (trace-table-entry trace-table-normal) (emit-return-pc label) (default-unknown-values vop values nvals move-temp temp label) (when cur-nfp @@ -510,12 +500,10 @@ default-value-8 (when callee-nfp (maybe-load-stack-tn callee-nfp nfp))) (maybe-load-stack-tn cfp-tn cfp) - (trace-table-entry trace-table-call-site) (inst compute-lra-from-code code-tn label temp (callee-return-pc-tn callee)) (note-this-location vop :call-site) (inst b target :nullify t) - (trace-table-entry trace-table-normal) (emit-return-pc label) (note-this-location vop :unknown-return) (receive-unknown-values values-start nvals start count label temp) @@ -553,12 +541,10 @@ default-value-8 (when callee-nfp (maybe-load-stack-tn callee-nfp nfp))) (maybe-load-stack-tn cfp-tn cfp) - (trace-table-entry trace-table-call-site) (inst compute-lra-from-code code-tn label temp (callee-return-pc-tn callee)) (note-this-location vop :call-site) (inst b target :nullify t) - (trace-table-entry trace-table-normal) (emit-return-pc label) (note-this-location vop :known-return) (when cur-nfp @@ -584,7 +570,6 @@ default-value-8 (:ignore val-locs vals) (:vop-var vop) (:generator 6 - (trace-table-entry trace-table-fun-epilogue) (maybe-load-stack-tn ocfp-temp ocfp) (maybe-load-stack-tn return-pc-temp return-pc) (move cfp-tn csp-tn) @@ -593,8 +578,7 @@ default-value-8 (move cur-nfp nsp-tn))) (inst addi (- n-word-bytes other-pointer-lowtag) return-pc-temp lip) (inst bv lip) - (move ocfp-temp cfp-tn t) - (trace-table-entry trace-table-normal))) + (move ocfp-temp cfp-tn t))) ;;;; Full call: @@ -794,8 +778,7 @@ default-value-8 '(move new-fp cfp-tn) '(if (> nargs register-arg-count) (move new-fp cfp-tn) - (move csp-tn cfp-tn))) - (trace-table-entry trace-table-call-site)))) + (move csp-tn cfp-tn)))))) ((nil) (inst nop))))) (insert-step-instrumenting (callable-tn) @@ -869,15 +852,13 @@ default-value-8 ,@(ecase return (:fixed - '((trace-table-entry trace-table-normal) - (emit-return-pc lra-label) + '((emit-return-pc lra-label) (default-unknown-values vop values nvals move-temp temp lra-label) (when cur-nfp (load-stack-tn cur-nfp nfp-save)))) (:unknown - '((trace-table-entry trace-table-normal) - (emit-return-pc lra-label) + '((emit-return-pc lra-label) (note-this-location vop :unknown-return) (receive-unknown-values values-start nvals start count lra-label temp) @@ -944,7 +925,6 @@ default-value-8 (:vop-var vop) (:generator 6 ;; Clear the number stack. - (trace-table-entry trace-table-fun-epilogue) (let ((cur-nfp (current-nfp-tn vop))) (when cur-nfp (move cur-nfp nsp-tn))) @@ -952,8 +932,7 @@ default-value-8 (move cfp-tn csp-tn) (move ocfp cfp-tn) ;; Out of here. - (lisp-return return-pc :offset 2) - (trace-table-entry trace-table-normal))) + (lisp-return return-pc :offset 2))) ;;; Do unknown-values return of a fixed number of values. The Values are ;;; required to be set up in the standard passing locations. Nvals is the @@ -986,7 +965,6 @@ default-value-8 (:vop-var vop) (:generator 6 ;; Clear the number stack. - (trace-table-entry trace-table-fun-epilogue) (let ((cur-nfp (current-nfp-tn vop))) (when cur-nfp (move cur-nfp nsp-tn))) @@ -1010,8 +988,7 @@ default-value-8 (dolist (reg (subseq (list a0 a1 a2 a3 a4 a5) nvals)) (move null-tn reg))) ;; And away we go. - (lisp-return return-pc))) - (trace-table-entry trace-table-normal))) + (lisp-return return-pc))))) ;;; Do unknown-values return of an arbitrary number of values (passed on the ;;; stack.) We check for the common case of a single return value, and do that @@ -1032,7 +1009,6 @@ default-value-8 (:temporary (:scs (any-reg) :from (:eval 0)) tmp) (:vop-var vop) (:generator 13 - (trace-table-entry trace-table-fun-epilogue) (let ((not-single (gen-label))) ;; Clear the number stack. (let ((cur-nfp (current-nfp-tn vop))) @@ -1056,8 +1032,7 @@ default-value-8 (move nvals-arg nvals) (let ((fixup (make-fixup 'return-multiple :assembly-routine))) (inst ldil fixup tmp) - (inst be fixup lisp-heap-space tmp :nullify t))) - (trace-table-entry trace-table-normal))) + (inst be fixup lisp-heap-space tmp :nullify t))))) ;;;; XEP hackery: diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index f6943d3..1faddd6 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -597,7 +597,7 @@ necessary, since type inference may take arbitrarily long to converge.") (describe-ir2-component component *compiler-trace-output*)) (maybe-mumble "code ") - (multiple-value-bind (code-length trace-table fixup-notes) + (multiple-value-bind (code-length fixup-notes) (generate-code component) #-sb-xc-host @@ -613,7 +613,6 @@ necessary, since type inference may take arbitrarily long to converge.") (fasl-dump-component component *code-segment* code-length - trace-table fixup-notes *compile-object*)) (core-object @@ -621,7 +620,6 @@ necessary, since type inference may take arbitrarily long to converge.") (make-core-component component *code-segment* code-length - trace-table fixup-notes *compile-object*)) (null)))))) diff --git a/src/compiler/mips/call.lisp b/src/compiler/mips/call.lisp index 0918fc3..2264d56 100644 --- a/src/compiler/mips/call.lisp +++ b/src/compiler/mips/call.lisp @@ -155,7 +155,6 @@ ;; Make sure the function is aligned, and drop a label pointing to this ;; function header. (emit-alignment n-lowtag-bits) - (trace-table-entry trace-table-fun-prologue) (emit-label start-lab) ;; Allocate function header. (inst simple-fun-header-word) @@ -176,23 +175,20 @@ (when nfp (inst addu nsp-tn nsp-tn (- (bytes-needed-for-non-descriptor-stack-frame))) - (move nfp nsp-tn))) - (trace-table-entry trace-table-normal))) + (move nfp nsp-tn))))) (define-vop (allocate-frame) (:results (res :scs (any-reg)) (nfp :scs (any-reg))) (:info callee) (:generator 2 - (trace-table-entry trace-table-fun-prologue) (move res csp-tn) (inst addu csp-tn csp-tn (* n-word-bytes (sb-allocated-size 'control-stack))) (when (ir2-physenv-number-stack-p callee) (inst addu nsp-tn nsp-tn (- (bytes-needed-for-non-descriptor-stack-frame))) - (move nfp nsp-tn)) - (trace-table-entry trace-table-normal))) + (move nfp nsp-tn)))) ;;; Allocate a partial frame for passing stack arguments in a full call. Nargs ;;; is the number of arguments passed. If no stack arguments are passed, then @@ -340,15 +336,13 @@ default-value-8 (aver defaults) (assemble (*elsewhere*) (emit-label default-stack-vals) - (trace-table-entry trace-table-fun-prologue) (do ((remaining defaults (cdr remaining))) ((null remaining)) (let ((def (car remaining))) (emit-label (car def)) (when (null (cdr remaining)) (inst b defaulting-done)) - (store-stack-tn (cdr def) null-tn))) - (trace-table-entry trace-table-normal))))) + (store-stack-tn (cdr def) null-tn))))))) (when lra-label (inst compute-code-from-lra code-tn code-tn lra-label temp)))) @@ -392,7 +386,6 @@ default-value-8 (emit-label done) (assemble (*elsewhere*) - (trace-table-entry trace-table-fun-prologue) (emit-label variable-values) (when lra-label (inst compute-code-from-lra code-tn code-tn lra-label temp)) @@ -402,8 +395,7 @@ default-value-8 (storew (first arg) args i)) (move start args) (inst b done) - (move count nargs t) - (trace-table-entry trace-table-normal))) + (move count nargs t))) (values)) @@ -476,13 +468,11 @@ default-value-8 (when callee-nfp (maybe-load-stack-tn callee-nfp nfp))) (maybe-load-stack-tn cfp-tn fp) - (trace-table-entry trace-table-call-site) (inst compute-lra-from-code (callee-return-pc-tn callee) code-tn label temp) (note-this-location vop :call-site) (inst b target) (inst nop) - (trace-table-entry trace-table-normal) (emit-return-pc label) (default-unknown-values vop values nvals move-temp temp label) (when cur-nfp @@ -517,13 +507,11 @@ default-value-8 (when callee-nfp (maybe-load-stack-tn callee-nfp nfp))) (maybe-load-stack-tn cfp-tn fp) - (trace-table-entry trace-table-call-site) (inst compute-lra-from-code (callee-return-pc-tn callee) code-tn label temp) (note-this-location vop :call-site) (inst b target) (inst nop) - (trace-table-entry trace-table-normal) (emit-return-pc label) (note-this-location vop :unknown-return) (receive-unknown-values values-start nvals start count label temp) @@ -561,13 +549,11 @@ default-value-8 (when callee-nfp (maybe-load-stack-tn callee-nfp nfp))) (maybe-load-stack-tn cfp-tn fp) - (trace-table-entry trace-table-call-site) (inst compute-lra-from-code (callee-return-pc-tn callee) code-tn label temp) (note-this-location vop :call-site) (inst b target) (inst nop) - (trace-table-entry trace-table-normal) (emit-return-pc label) (note-this-location vop :known-return) (when cur-nfp @@ -594,7 +580,6 @@ default-value-8 (:ignore val-locs vals) (:vop-var vop) (:generator 6 - (trace-table-entry trace-table-fun-epilogue) (maybe-load-stack-tn ocfp-temp ocfp) (maybe-load-stack-tn return-pc-temp return-pc) (move csp-tn cfp-tn) @@ -604,8 +589,7 @@ default-value-8 (bytes-needed-for-non-descriptor-stack-frame)))) (inst addu lip return-pc-temp (- n-word-bytes other-pointer-lowtag)) (inst j lip) - (move cfp-tn ocfp-temp t) - (trace-table-entry trace-table-normal))) + (move cfp-tn ocfp-temp t))) ;;;; Full call: @@ -802,8 +786,7 @@ default-value-8 '(move cfp-tn new-fp) '(if (> nargs register-arg-count) (move cfp-tn new-fp) - (move cfp-tn csp-tn))) - (trace-table-entry trace-table-call-site)))) + (move cfp-tn csp-tn)))))) ((nil) (inst nop))))) (insert-step-instrumenting (callable-tn) @@ -878,18 +861,16 @@ default-value-8 ,@(ecase return (:fixed - '((trace-table-entry trace-table-normal) - (emit-return-pc lra-label) + '((emit-return-pc lra-label) (default-unknown-values vop values nvals - move-temp temp lra-label) + move-temp temp lra-label) (when cur-nfp (load-stack-tn cur-nfp nfp-save)))) (:unknown - '((trace-table-entry trace-table-normal) - (emit-return-pc lra-label) + '((emit-return-pc lra-label) (note-this-location vop :unknown-return) (receive-unknown-values values-start nvals start count - lra-label temp) + lra-label temp) (when cur-nfp (load-stack-tn cur-nfp nfp-save)))) (:tail)))))) @@ -954,7 +935,6 @@ default-value-8 (:vop-var vop) (:generator 6 ;; Clear the number stack. - (trace-table-entry trace-table-fun-epilogue) (let ((cur-nfp (current-nfp-tn vop))) (when cur-nfp (inst addu nsp-tn cur-nfp @@ -963,8 +943,7 @@ default-value-8 (move csp-tn cfp-tn) (move cfp-tn ocfp) ;; Out of here. - (lisp-return return-pc lip :offset 2) - (trace-table-entry trace-table-normal))) + (lisp-return return-pc lip :offset 2))) ;;; Do unknown-values return of a fixed number of values. The Values are @@ -998,7 +977,6 @@ default-value-8 (:vop-var vop) (:generator 6 ;; Clear the number stack. - (trace-table-entry trace-table-fun-epilogue) (let ((cur-nfp (current-nfp-tn vop))) (when cur-nfp (inst addu nsp-tn cur-nfp @@ -1022,8 +1000,7 @@ default-value-8 (dolist (reg (subseq (list a0 a1 a2 a3 a4 a5) nvals)) (move reg null-tn))) ;; And away we go. - (lisp-return return-pc lip))) - (trace-table-entry trace-table-normal))) + (lisp-return return-pc lip))))) ;;; Do unknown-values return of an arbitrary number of values (passed on the ;;; stack.) We check for the common case of a single return value, and do that @@ -1046,7 +1023,6 @@ default-value-8 (:vop-var vop) (:generator 13 - (trace-table-entry trace-table-fun-epilogue) (let ((not-single (gen-label))) ;; Clear the number stack. (let ((cur-nfp (current-nfp-tn vop))) @@ -1071,10 +1047,7 @@ default-value-8 (move vals vals-arg) (inst j (make-fixup 'return-multiple :assembly-routine)) - (move nvals nvals-arg t)) - (trace-table-entry trace-table-normal))) - - + (move nvals nvals-arg t)))) ;;;; XEP hackery: diff --git a/src/compiler/ppc/call.lisp b/src/compiler/ppc/call.lisp index 1e0b5c5..198853b 100644 --- a/src/compiler/ppc/call.lisp +++ b/src/compiler/ppc/call.lisp @@ -148,7 +148,6 @@ ;; Make sure the function is aligned, and drop a label pointing to this ;; function header. (emit-alignment n-lowtag-bits) - (trace-table-entry trace-table-fun-prologue) (emit-label start-lab) ;; Allocate function header. (inst simple-fun-header-word) @@ -167,15 +166,13 @@ (let* ((nbytes (bytes-needed-for-non-descriptor-stack-frame))) (when (> nbytes number-stack-displacement) (inst stwu nsp-tn nsp-tn (- nbytes)) - (inst addi nfp-tn nsp-tn number-stack-displacement))))) - (trace-table-entry trace-table-normal))) + (inst addi nfp-tn nsp-tn number-stack-displacement))))))) (define-vop (allocate-frame) (:results (res :scs (any-reg)) (nfp :scs (any-reg))) (:info callee) (:generator 2 - (trace-table-entry trace-table-fun-prologue) (move res csp-tn) (inst addi csp-tn csp-tn (* n-word-bytes (sb-allocated-size 'control-stack))) @@ -183,8 +180,7 @@ (let* ((nbytes (bytes-needed-for-non-descriptor-stack-frame))) (when (> nbytes number-stack-displacement) (inst stwu nsp-tn nsp-tn (- (bytes-needed-for-non-descriptor-stack-frame))) - (inst addi nfp nsp-tn number-stack-displacement)))) - (trace-table-entry trace-table-normal))) + (inst addi nfp nsp-tn number-stack-displacement)))))) ;;; Allocate a partial frame for passing stack arguments in a full call. Nargs ;;; is the number of arguments passed. If no stack arguments are passed, then @@ -323,14 +319,12 @@ default-value-8 (when defaults (assemble (*elsewhere*) (emit-label default-stack-vals) - (trace-table-entry trace-table-fun-prologue) (do ((remaining defaults (cdr remaining))) ((null remaining)) (let ((def (car remaining))) (emit-label (car def)) (store-stack-tn (cdr def) null-tn))) - (inst b defaulting-done) - (trace-table-entry trace-table-normal)))))) + (inst b defaulting-done)))))) (inst compute-code-from-lra code-tn lra-tn lra-label temp))) (values)) @@ -371,7 +365,6 @@ default-value-8 (emit-label done) (assemble (*elsewhere*) - (trace-table-entry trace-table-fun-prologue) (emit-label variable-values) (inst compute-code-from-lra code-tn lra-tn lra-label temp) (do ((arg *register-arg-tns* (rest arg)) @@ -380,8 +373,7 @@ default-value-8 (storew (first arg) args i)) (move start args) (move count nargs) - (inst b done) - (trace-table-entry trace-table-normal))) + (inst b done))) (values)) @@ -444,7 +436,6 @@ default-value-8 (:temporary (:sc any-reg :offset ocfp-offset :from (:eval 0)) ocfp) (:ignore arg-locs args ocfp) (:generator 5 - (trace-table-entry trace-table-call-site) (let ((label (gen-label)) (cur-nfp (current-nfp-tn vop))) (when cur-nfp @@ -462,8 +453,7 @@ default-value-8 ;; alpha uses (maybe-load-stack-nfp-tn cur-nfp nfp-save temp) ;; instead of the clause below (when cur-nfp - (load-stack-tn cur-nfp nfp-save))) - (trace-table-entry trace-table-normal))) + (load-stack-tn cur-nfp nfp-save))))) ;;; Non-TR local call for a variable number of return values passed according @@ -485,7 +475,6 @@ default-value-8 (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) (:temporary (:scs (non-descriptor-reg)) temp) (:generator 20 - (trace-table-entry trace-table-call-site) (let ((label (gen-label)) (cur-nfp (current-nfp-tn vop))) (when cur-nfp @@ -503,8 +492,7 @@ default-value-8 (note-this-location vop :unknown-return) (receive-unknown-values values-start nvals start count label temp) (when cur-nfp - (load-stack-tn cur-nfp nfp-save))) - (trace-table-entry trace-table-normal))) + (load-stack-tn cur-nfp nfp-save))))) ;;;; Local call with known values return: @@ -528,7 +516,6 @@ default-value-8 (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) (:temporary (:scs (non-descriptor-reg)) temp) (:generator 5 - (trace-table-entry trace-table-call-site) (let ((label (gen-label)) (cur-nfp (current-nfp-tn vop))) (when cur-nfp @@ -544,8 +531,7 @@ default-value-8 (emit-return-pc label) (note-this-location vop :known-return) (when cur-nfp - (load-stack-tn cur-nfp nfp-save))) - (trace-table-entry trace-table-normal))) + (load-stack-tn cur-nfp nfp-save))))) ;;; Return from known values call. We receive the return locations as ;;; arguments to terminate their lifetimes in the returning function. We @@ -565,7 +551,6 @@ default-value-8 (:ignore val-locs vals) (:vop-var vop) (:generator 6 - (trace-table-entry trace-table-fun-epilogue) (maybe-load-stack-tn old-fp-temp old-fp) (maybe-load-stack-tn return-pc-temp return-pc) (move csp-tn cfp-tn) @@ -575,8 +560,7 @@ default-value-8 (- (bytes-needed-for-non-descriptor-stack-frame) number-stack-displacement)))) (move cfp-tn old-fp-temp) - (inst j return-pc-temp (- n-word-bytes other-pointer-lowtag)) - (trace-table-entry trace-table-normal))) + (inst j return-pc-temp (- n-word-bytes other-pointer-lowtag)))) ;;;; Full call: @@ -705,7 +689,6 @@ default-value-8 (if (eq return :tail) 0 10) 15 (if (eq return :unknown) 25 0)) - (trace-table-entry trace-table-call-site) (let* ((cur-nfp (current-nfp-tn vop)) ,@(unless (eq return :tail) @@ -866,8 +849,7 @@ default-value-8 lra-label temp) (when cur-nfp (load-stack-tn cur-nfp nfp-save)))) - (:tail))) - (trace-table-entry trace-table-normal)))) + (:tail)))))) (define-full-call call nil :fixed nil) @@ -923,7 +905,6 @@ default-value-8 (:temporary (:scs (interior-reg)) lip) (:vop-var vop) (:generator 6 - (trace-table-entry trace-table-fun-epilogue) (move lra return-pc) ;; Clear the number stack. (let ((cur-nfp (current-nfp-tn vop))) @@ -935,8 +916,7 @@ default-value-8 (move csp-tn cfp-tn) (move cfp-tn old-fp) ;; Out of here. - (lisp-return lra lip :offset 2) - (trace-table-entry trace-table-normal))) + (lisp-return lra lip :offset 2))) ;;; Do unknown-values return of a fixed number of values. The Values are ;;; required to be set up in the standard passing locations. Nvals is the @@ -967,7 +947,6 @@ default-value-8 (:temporary (:scs (interior-reg)) lip) (:vop-var vop) (:generator 6 - (trace-table-entry trace-table-fun-epilogue) (move lra return-pc) ;; Clear the number stack. (let ((cur-nfp (current-nfp-tn vop))) @@ -994,8 +973,7 @@ default-value-8 (dolist (reg (subseq (list a0 a1 a2 a3) nvals)) (move reg null-tn))) ;; And away we go. - (lisp-return lra lip))) - (trace-table-entry trace-table-normal))) + (lisp-return lra lip))))) ;;; Do unknown-values return of an arbitrary number of values (passed ;;; on the stack.) We check for the common case of a single return @@ -1017,7 +995,6 @@ default-value-8 (:temporary (:sc any-reg) temp) (:vop-var vop) (:generator 13 - (trace-table-entry trace-table-fun-epilogue) (move lra lra-arg) (let ((not-single (gen-label))) ;; Clear the number stack. @@ -1041,8 +1018,7 @@ default-value-8 (move nvals nvals-arg) (inst lr temp (make-fixup 'return-multiple :assembly-routine)) (inst mtlr temp) - (inst blr)) - (trace-table-entry trace-table-normal))) + (inst blr)))) ;;;; XEP hackery: diff --git a/src/compiler/sparc/call.lisp b/src/compiler/sparc/call.lisp index 23de71d..958746a 100644 --- a/src/compiler/sparc/call.lisp +++ b/src/compiler/sparc/call.lisp @@ -151,7 +151,6 @@ ;; Make sure the function is aligned, and drop a label pointing to this ;; function header. (emit-alignment n-lowtag-bits) - (trace-table-entry trace-table-fun-prologue) (emit-label start-lab) ;; Allocate function header. (inst simple-fun-header-word) @@ -166,22 +165,19 @@ (let ((nfp-tn (current-nfp-tn vop))) (when nfp-tn (inst sub nsp-tn (bytes-needed-for-non-descriptor-stack-frame)) - (inst add nfp-tn nsp-tn number-stack-displacement))) - (trace-table-entry trace-table-normal))) + (inst add nfp-tn nsp-tn number-stack-displacement))))) (define-vop (allocate-frame) (:results (res :scs (any-reg)) (nfp :scs (any-reg))) (:info callee) (:generator 2 - (trace-table-entry trace-table-fun-prologue) (move res csp-tn) (inst add csp-tn csp-tn (* n-word-bytes (sb-allocated-size 'control-stack))) (when (ir2-physenv-number-stack-p callee) (inst sub nsp-tn (bytes-needed-for-non-descriptor-stack-frame)) - (inst add nfp nsp-tn number-stack-displacement)) - (trace-table-entry trace-table-normal))) + (inst add nfp nsp-tn number-stack-displacement)))) ;;; Allocate a partial frame for passing stack arguments in a full call. Nargs ;;; is the number of arguments passed. If no stack arguments are passed, then @@ -320,15 +316,13 @@ default-value-8 (when defaults (assemble (*elsewhere*) (emit-label default-stack-vals) - (trace-table-entry trace-table-fun-prologue) (do ((remaining defaults (cdr remaining))) ((null remaining)) (let ((def (car remaining))) (emit-label (car def)) (when (null (cdr remaining)) (inst b defaulting-done)) - (store-stack-tn (cdr def) null-tn))) - (trace-table-entry trace-table-normal)))))) + (store-stack-tn (cdr def) null-tn)))))))) (inst compute-code-from-lra code-tn code-tn lra-label temp))) (values)) @@ -368,7 +362,6 @@ default-value-8 (emit-label done) (assemble (*elsewhere*) - (trace-table-entry trace-table-fun-prologue) (emit-label variable-values) (inst compute-code-from-lra code-tn code-tn lra-label temp) (do ((arg *register-arg-tns* (rest arg)) @@ -378,8 +371,7 @@ default-value-8 (move start args) (move count nargs) (inst b done) - (inst nop) - (trace-table-entry trace-table-normal))) + (inst nop))) (values)) @@ -442,7 +434,6 @@ default-value-8 (:temporary (:sc any-reg :offset ocfp-offset :from (:eval 0)) ocfp) (:ignore arg-locs args ocfp) (:generator 5 - (trace-table-entry trace-table-call-site) (let ((label (gen-label)) (cur-nfp (current-nfp-tn vop))) (when cur-nfp @@ -459,8 +450,7 @@ default-value-8 (emit-return-pc label) (default-unknown-values vop values nvals move-temp temp label) (when cur-nfp - (load-stack-tn cur-nfp nfp-save))) - (trace-table-entry trace-table-normal))) + (load-stack-tn cur-nfp nfp-save))))) ;;; Non-TR local call for a variable number of return values passed according @@ -481,7 +471,6 @@ default-value-8 (:vop-var vop) (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) (:generator 20 - (trace-table-entry trace-table-call-site) (let ((label (gen-label)) (cur-nfp (current-nfp-tn vop))) (when cur-nfp @@ -499,8 +488,7 @@ default-value-8 (note-this-location vop :unknown-return) (receive-unknown-values values-start nvals start count label temp) (when cur-nfp - (load-stack-tn cur-nfp nfp-save))) - (trace-table-entry trace-table-normal))) + (load-stack-tn cur-nfp nfp-save))))) ;;;; Local call with known values return: @@ -524,7 +512,6 @@ default-value-8 (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) (:temporary (:scs (non-descriptor-reg)) temp) (:generator 5 - (trace-table-entry trace-table-call-site) (let ((label (gen-label)) (cur-nfp (current-nfp-tn vop))) (when cur-nfp @@ -541,8 +528,7 @@ default-value-8 (emit-return-pc label) (note-this-location vop :known-return) (when cur-nfp - (load-stack-tn cur-nfp nfp-save))) - (trace-table-entry trace-table-normal))) + (load-stack-tn cur-nfp nfp-save))))) ;;; Return from known values call. We receive the return locations as ;;; arguments to terminate their lifetimes in the returning function. We @@ -562,7 +548,6 @@ default-value-8 (:ignore val-locs vals) (:vop-var vop) (:generator 6 - (trace-table-entry trace-table-fun-epilogue) (maybe-load-stack-tn old-fp-temp old-fp) (maybe-load-stack-tn return-pc-temp return-pc) (move csp-tn cfp-tn) @@ -572,8 +557,7 @@ default-value-8 (- (bytes-needed-for-non-descriptor-stack-frame) number-stack-displacement)))) (inst j return-pc-temp (- n-word-bytes other-pointer-lowtag)) - (move cfp-tn old-fp-temp) - (trace-table-entry trace-table-normal))) + (move cfp-tn old-fp-temp))) ;;;; Full call: @@ -701,7 +685,6 @@ default-value-8 (if (eq return :tail) 0 10) 15 (if (eq return :unknown) 25 0)) - (trace-table-entry trace-table-call-site) (let* ((cur-nfp (current-nfp-tn vop)) ,@(unless (eq return :tail) '((lra-label (gen-label)))) @@ -840,8 +823,7 @@ default-value-8 lra-label temp) (when cur-nfp (load-stack-tn cur-nfp nfp-save)))) - (:tail))) - (trace-table-entry trace-table-normal)))) + (:tail)))))) (define-full-call call nil :fixed nil) @@ -904,7 +886,6 @@ default-value-8 (:ignore value) (:vop-var vop) (:generator 6 - (trace-table-entry trace-table-fun-epilogue) ;; Clear the number stack. (let ((cur-nfp (current-nfp-tn vop))) (when cur-nfp @@ -915,8 +896,7 @@ default-value-8 (move csp-tn cfp-tn) (move cfp-tn old-fp) ;; Out of here. - (lisp-return return-pc :offset 2) - (trace-table-entry trace-table-normal))) + (lisp-return return-pc :offset 2))) ;;; Do unknown-values return of a fixed number of values. The Values are ;;; required to be set up in the standard passing locations. Nvals is the @@ -947,7 +927,6 @@ default-value-8 (:temporary (:sc any-reg :offset ocfp-offset) val-ptr) (:vop-var vop) (:generator 6 - (trace-table-entry trace-table-fun-epilogue) ;; Clear the number stack. (let ((cur-nfp (current-nfp-tn vop))) (when cur-nfp @@ -973,8 +952,7 @@ default-value-8 (dolist (reg (subseq (list a0 a1 a2 a3 a4 a5) nvals)) (move reg null-tn))) ;; And away we go. - (lisp-return return-pc))) - (trace-table-entry trace-table-normal))) + (lisp-return return-pc))))) ;;; Do unknown-values return of an arbitrary number of values (passed on the ;;; stack.) We check for the common case of a single return value, and do that @@ -998,7 +976,6 @@ default-value-8 (:vop-var vop) (:generator 13 - (trace-table-entry trace-table-fun-epilogue) (let ((not-single (gen-label))) ;; Clear the number stack. (let ((cur-nfp (current-nfp-tn vop))) @@ -1024,8 +1001,7 @@ default-value-8 (move vals vals-arg) (move nvals nvals-arg) (inst ji temp (make-fixup 'return-multiple :assembly-routine)) - (inst nop)) - (trace-table-entry trace-table-normal))) + (inst nop)))) diff --git a/src/compiler/trace-table.lisp b/src/compiler/trace-table.lisp deleted file mode 100644 index f006add..0000000 --- a/src/compiler/trace-table.lisp +++ /dev/null @@ -1,42 +0,0 @@ -;;;; trace tables (from codegen.lisp in CMU CL sources) - -;;;; This software is part of the SBCL system. See the README file for -;;;; more information. -;;;; -;;;; This software is derived from the CMU CL system, which was -;;;; written at Carnegie Mellon University and released into the -;;;; public domain. The software is in the public domain and is -;;;; provided with absolutely no warranty. See the COPYING and CREDITS -;;;; files for more information. - -(in-package "SB!C") - -(defun trace-table-entry (state) - (declare (special *trace-table-info*)) - (let ((label (gen-label))) - (emit-label label) - (push (cons label state) *trace-table-info*)) - (values)) - -(def!constant tt-bits-per-state 3) -(def!constant tt-bytes-per-entry 2) -(def!constant tt-bits-per-entry (* tt-bytes-per-entry sb!vm:n-byte-bits)) -(def!constant tt-bits-per-offset (- tt-bits-per-entry tt-bits-per-state)) -(def!constant tt-max-offset (1- (a... [truncated message content] |
From: Douglas K. <sn...@us...> - 2014-06-17 16:07:23
|
The branch "master" has been updated in SBCL: via 11471916c5f556f759e6df433d7c569133251b77 (commit) from 4c0c126812cb113c2be522386bd93453c6317918 (commit) - Log ----------------------------------------------------------------- commit 11471916c5f556f759e6df433d7c569133251b77 Author: Douglas Katzman <do...@go...> Date: Tue Jun 17 12:06:41 2014 -0400 Really make BINDING* accept declarations --- src/code/early-extensions.lisp | 88 +++++++++++++++++++++++++++++++++------ tests/macroexpand.impure.lisp | 13 ++++++ 2 files changed, 87 insertions(+), 14 deletions(-) diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 5ccdf04..dd394e0 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -1241,6 +1241,50 @@ (let ((it ,test)) (declare (ignorable it)),@body) (acond ,@rest)))))) +;; Given DECLS as returned by from parse-body, and SYMBOLS to be bound +;; (with LET, MULTIPLE-VALUE-BIND, etc) return two sets of declarations: +;; those which pertain to the variables and those which don't. +(defun extract-var-decls (decls symbols) + (labels ((applies-to-variables (decl) + (let ((id (car decl))) + (remove-if (lambda (x) (not (memq x symbols))) + (cond ((eq id 'type) + (cddr decl)) + ((or (listp id) ; must be a type-specifier + (memq id '(special ignorable ignore + dynamic-extent + truly-dynamic-extent)) + (info :type :kind id)) + (cdr decl)))))) + (partition (spec) + (let ((variables (applies-to-variables spec))) + (cond ((not variables) + (values nil spec)) + ((eq (car spec) 'type) + (let ((more (set-difference (cddr spec) variables))) + (values `(type ,(cadr spec) ,@variables) + (if more `(type ,(cadr spec) ,@more))))) + (t + (let ((more (set-difference (cdr spec) variables))) + (values `(,(car spec) ,@variables) + (if more `(,(car spec) ,@more))))))))) + ;; This loop is less inefficient than theoretically possible, + ;; reconstructing the tree even if no need, + ;; but it's just a macroexpander, so... fine. + (collect ((binding-decls)) + (let ((filtered + (mapcar (lambda (decl-expr) ; a list headed by DECLARE + (mapcan (lambda (spec) + (multiple-value-bind (binding other) + (partition spec) + (when binding + (binding-decls binding)) + (if other (list other)))) + (cdr decl-expr))) + decls))) + (values (awhen (binding-decls) `(declare ,@it)) + (mapcan (lambda (x) (if x (list `(declare ,@x)))) filtered)))))) + ;;; (binding* ({(names initial-value [flag])}*) body) ;;; FLAG may be NIL or :EXIT-IF-NULL ;;; @@ -1254,11 +1298,16 @@ ;;; them into the appropriate places. This qualifies as an extreme KLUDGE, ;;; but has desirable behavior of allowing declarations in the innermost form. ;;; +;;; Caution: don't use declarations of the form (<type-id> <var>) before the +;;; INFO database is set up in building the cross-compiler, or you will lose. +;;; Of course, since some other host Lisps don't seem to think that's +;;; acceptable syntax anyway, you're pretty much prevented from writing it. +;;; (defmacro binding* ((&rest bindings) &body body) - (labels - ((recurse (bindings &aux ignores) + (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil) + (labels + ((recurse (bindings decls &aux ignores) (cond - ((not bindings) body) ((some (lambda (x) (destructuring-bind (names value-form &optional flag) x (declare (ignore value-form)) @@ -1273,14 +1322,24 @@ (setq names (mapcar (lambda (name) (or name (car (push (gensym) ignores)))) names)))) - `((multiple-value-bind ,names ,value-form - ,@(ignore ignores) - ,@(ecase flag - ((nil) (recurse (cdr bindings))) - ((:exit-if-null) - `((when ,(first names) - ,@(recurse (cdr bindings)))))))))) + (multiple-value-bind (binding-decls rest-decls) + ;; If no more bindings, and no (WHEN ...) before the FORMS, + ;; then don't bother parsing decls. + (if (or (cdr bindings) flag) + (extract-var-decls decls names) + (values nil decls)) + (let ((continue (acond ((cdr bindings) (recurse it rest-decls)) + (t (append decls forms))))) + `((multiple-value-bind ,names ,value-form + ,@(decl-expr binding-decls ignores) + ,@(ecase flag + ((nil) continue) + ((:exit-if-null) + `((when ,(first names) ,@continue)))))))))) (t + ;; This case is not strictly necessary now that declarations that + ;; affect variables are correctly inserted into the M-V-BIND, + ;; but it makes the expansion more legible/concise when applicable. `((let* ,(mapcar (lambda (binding) (if (car binding) binding @@ -1288,16 +1347,17 @@ (push var ignores) (cons var (cdr binding))))) bindings) - ,@(ignore ignores) + ,@(decl-expr nil ignores) ,@body))))) - (ignore (list) + (decl-expr (binding-decls ignores) + (nconc (if binding-decls (list binding-decls)) ;; IGNORABLE, not IGNORE, just in case :EXIT-IF-NULL reads a gensym - (if list `((declare (ignorable ,@list)))))) + (if ignores `((declare (ignorable ,@ignores))))))) ;; Zero bindings have to be special-cased. RECURSE returns a list of forms ;; because we musn't wrap BODY in a PROGN if it contains declarations, ;; so we unwrap once here, but if the body was returned as the base case ;; of recursion then (CAR (RECURSE)) would be wrong. - (if bindings (car (recurse bindings)) `(locally ,@body)))) + (if bindings (car (recurse bindings decls)) `(locally ,@body))))) ;;; Delayed evaluation (defmacro delay (form) diff --git a/tests/macroexpand.impure.lisp b/tests/macroexpand.impure.lisp index 5f0afb0..7a3b0ee 100644 --- a/tests/macroexpand.impure.lisp +++ b/tests/macroexpand.impure.lisp @@ -75,3 +75,16 @@ (assert (string= "Symbol FOO-ARGV is already defined as an alien variable." (write-to-string e :escape nil)))) (:no-error () (error "Expected an error"))) + +(assert (equal (macroexpand-1 + '(sb-int:binding* (((foo x bar zz) (f) :exit-if-null) + ((baz y) (g bar))) + (declare (integer x foo) (special foo y)) + (declare (special zz bar l) (real q foo)) + (thing))) + '(MULTIPLE-VALUE-BIND (FOO X BAR ZZ) (F) + (DECLARE + (INTEGER X FOO) (SPECIAL FOO) (SPECIAL ZZ BAR) (REAL FOO)) + (WHEN FOO (MULTIPLE-VALUE-BIND (BAZ Y) (G BAR) + (DECLARE (SPECIAL Y)) + (DECLARE (SPECIAL L) (REAL Q)) (THING)))))) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2014-06-16 22:57:45
|
The branch "master" has been updated in SBCL: via 4c0c126812cb113c2be522386bd93453c6317918 (commit) from 588eb58de039c17256d739bc2ea3543075844ea8 (commit) - Log ----------------------------------------------------------------- commit 4c0c126812cb113c2be522386bd93453c6317918 Author: Douglas Katzman <do...@go...> Date: Mon Jun 16 18:50:20 2014 -0400 Make BINDING* accept declarations, kinda. It's not perfect, but this works now: (BINDING* (((Q R) (FLOOR X Y)) (S (+ R 3))) (DECLARE (TYPE MUMBLE S)) ...) --- src/code/early-extensions.lisp | 82 +++++++++++++++++++++++++-------------- 1 files changed, 52 insertions(+), 30 deletions(-) diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 9e8e870..5ccdf04 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -1245,37 +1245,59 @@ ;;; FLAG may be NIL or :EXIT-IF-NULL ;;; ;;; This form unites LET*, MULTIPLE-VALUE-BIND and AWHEN. +;;; Any name in a list of names may be NIL to ignore the respective value. +;;; If NAMES itself is nil, the initial-value form is evaluated only for effect. +;;; +;;; Clauses with no flags and one binding per clause are equivalent to LET*. +;;; We reduce to LET* when possible so that the body can contain declarations +;;; without having to split out declarations which affect variables and insert +;;; them into the appropriate places. This qualifies as an extreme KLUDGE, +;;; but has desirable behavior of allowing declarations in the innermost form. +;;; (defmacro binding* ((&rest bindings) &body body) - (let ((bindings (reverse bindings))) - (loop with form = `(progn ,@body) - for binding in bindings - do (destructuring-bind (names initial-value &optional flag) - binding - (multiple-value-bind (names declarations) - (etypecase names - (null - (let ((name (gensym))) - (values (list name) `((declare (ignorable ,name)))))) - (symbol - (values (list names) nil)) - (list - (collect ((new-names) (ignorable)) - (dolist (name names) - (when (eq name nil) - (setq name (gensym)) - (ignorable name)) - (new-names name)) - (values (new-names) - (when (ignorable) - `((declare (ignorable ,@(ignorable))))))))) - (setq form `(multiple-value-bind ,names - ,initial-value - ,@declarations - ,(ecase flag - ((nil) form) - ((:exit-if-null) - `(when ,(first names) ,form))))))) - finally (return form)))) + (labels + ((recurse (bindings &aux ignores) + (cond + ((not bindings) body) + ((some (lambda (x) + (destructuring-bind (names value-form &optional flag) x + (declare (ignore value-form)) + (or flag (not (symbolp names))))) + bindings) + (destructuring-bind (names value-form &optional flag) (car bindings) + (etypecase names + ;; () for names is esoteric. Does anyone really need that? + (null (setq names (list (gensym)) ignores names)) + (symbol (setq names (list names))) + (list + (setq names (mapcar (lambda (name) + (or name (car (push (gensym) ignores)))) + names)))) + `((multiple-value-bind ,names ,value-form + ,@(ignore ignores) + ,@(ecase flag + ((nil) (recurse (cdr bindings))) + ((:exit-if-null) + `((when ,(first names) + ,@(recurse (cdr bindings)))))))))) + (t + `((let* ,(mapcar (lambda (binding) + (if (car binding) + binding + (let ((var (gensym))) + (push var ignores) + (cons var (cdr binding))))) + bindings) + ,@(ignore ignores) + ,@body))))) + (ignore (list) + ;; IGNORABLE, not IGNORE, just in case :EXIT-IF-NULL reads a gensym + (if list `((declare (ignorable ,@list)))))) + ;; Zero bindings have to be special-cased. RECURSE returns a list of forms + ;; because we musn't wrap BODY in a PROGN if it contains declarations, + ;; so we unwrap once here, but if the body was returned as the base case + ;; of recursion then (CAR (RECURSE)) would be wrong. + (if bindings (car (recurse bindings)) `(locally ,@body)))) ;;; Delayed evaluation (defmacro delay (form) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Paul K. <pk...@us...> - 2014-06-15 21:28:04
|
The branch "master" has been updated in SBCL: via 588eb58de039c17256d739bc2ea3543075844ea8 (commit) from 398361a636113330df461bb0b5ee4d1250ff8235 (commit) - Log ----------------------------------------------------------------- commit 588eb58de039c17256d739bc2ea3543075844ea8 Author: Paul Khuong <pv...@pv...> Date: Sun Jun 15 17:26:10 2014 -0400 Fix a caching bug in life.lisp We'd sometimes cache too aggressively and mistakenly conclude that a TN had no global conflict in an IR2 block. This would then lead to having multiple conflict structs for the same block/TN pair, and, finally, AVERs in graph colouring regalloc. Reported by Douglas Katzman. Fixes lp#1327008. --- NEWS | 4 +- src/compiler/life.lisp | 7 +++ tests/compiler.pure.lisp | 119 ++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 129 insertions(+), 1 deletions(-) diff --git a/NEWS b/NEWS index 0b301bb..0f72197 100644 --- a/NEWS +++ b/NEWS @@ -6,7 +6,6 @@ changes relative to sbcl-1.2.0: to Christoph Egger) * enhancement: experimental support for threads on NetBSD/x86-64. (thanks to Robert Swindells) - * bug fix: TYPE-OF must not return AND/OR/NOT expressions. (lp#1317308) * bug fix: accessing NIL arrays stopped producing errors. (lp#1311421) @@ -28,6 +27,9 @@ changes relative to sbcl-1.2.0: * bug fix: misplaced and missing declarations in DEFTRANSFORM. (lp#1066451) * bug fix: FBOUNDP returned NIL for a class of incorrect function names instead of signaling an error. (lp#1095483) + * bug fix: fix a compile-time AVER in regalloc: lifetime analysis + used to (rarely) introduce duplicate conflict markers in a single + TN/block pair. (lp#1327008) changes in sbcl-1.2.0 relative to sbcl-1.1.18: * bug fix: read-time-eval backquote context mixup. (lp#1321047) diff --git a/src/compiler/life.lisp b/src/compiler/life.lisp index 1e85318..149d05f 100644 --- a/src/compiler/life.lisp +++ b/src/compiler/life.lisp @@ -547,6 +547,13 @@ (tn-conflicts (tn-current-conflict tn)) (number1 (ir2-block-number block1))) (aver tn-conflicts) + (when (> (ir2-block-number (global-conflicts-block tn-conflicts)) + number1) + ;; The TN-CURRENT-CONFLICT finger overshot. Reset it + ;; conservatively. + (setf tn-conflicts (tn-global-conflicts tn) + (tn-current-conflict tn) tn-conflicts) + (aver tn-conflicts)) (do ((current tn-conflicts (global-conflicts-next-tnwise current)) (prev nil current)) ((or (null current) diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 71e7ee7..20dab69 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -5172,3 +5172,122 @@ (compile nil '(lambda (x) (progn (declare (integer x)) (* x 6)))) (assert warnings-p) (assert failure-p))) + +;; Something in this function used to confuse lifetime analysis into +;; recording multiple conflicts for a single TNs in the dolist block. +(with-test (:name :bug-1327008) + (handler-bind (((or style-warning compiler-note) + (lambda (c) + (muffle-warning c)))) + (compile nil + `(lambda (scheduler-spec + schedule-generation-method + utc-earliest-time utc-latest-time + utc-other-earliest-time utc-other-latest-time + &rest keys + &key queue + maximum-mileage + maximum-extra-legs + maximum-connection-time + slice-number + scheduler-hints + permitted-route-locations prohibited-route-locations + preferred-connection-locations disfavored-connection-locations + origins destinations + permitted-carriers prohibited-carriers + permitted-operating-carriers prohibited-operating-carriers + start-airports end-airports + circuity-limit + specified-circuity-limit-extra-miles + (preferred-carriers :unspecified) + &allow-other-keys) + (declare (optimize speed)) + (let ((table1 (list nil)) + (table2 (list nil)) + (skip-flifo-checks (getf scheduler-spec :skip-flifo-checks)) + (construct-gaps-p (getf scheduler-spec :construct-gaps-p)) + (gap-locations (getf scheduler-spec :gap-locations)) + (result-array (make-array 100)) + (number-dequeued 0) + (n-new 0) + (n-calcs 0) + (exit-reason 0) + (prev-start-airports origins) + (prev-end-airports destinations) + (prev-permitted-carriers permitted-carriers)) + (flet ((run-with-hint (hint random-magic other-randomness + maximum-extra-legs + preferred-origins + preferred-destinations + same-pass-p) + (let* ((hint-permitted-carriers (first hint)) + (preferred-end-airports + (ecase schedule-generation-method + (:DEPARTURE preferred-destinations) + (:ARRIVAL preferred-origins))) + (revised-permitted-carriers + (cond ((and hint-permitted-carriers + (not (eq permitted-carriers :ANY))) + (intersection permitted-carriers + hint-permitted-carriers)) + (hint-permitted-carriers) + (permitted-carriers))) + (revised-maximum-mileage + (min (let ((maximum-mileage 0)) + (dolist (o start-airports) + (dolist (d end-airports) + (setf maximum-mileage + (max maximum-mileage (mileage o d))))) + (round (+ (* circuity-limit maximum-mileage) + (or specified-circuity-limit-extra-miles + (hairy-calculation slice-number))))) + maximum-mileage))) + (when (or (not (equal start-airports prev-start-airports)) + (not (equal end-airports prev-end-airports)) + (and (not (equal revised-permitted-carriers + prev-permitted-carriers)))) + (incf n-calcs) + (calculate-vectors + prohibited-carriers + permitted-operating-carriers + prohibited-operating-carriers + permitted-route-locations + prohibited-route-locations + construct-gaps-p + gap-locations + preferred-carriers) + (setf prev-permitted-carriers revised-permitted-carriers)) + (multiple-value-bind (this-number-dequeued + this-exit-reason + this-n-new) + (apply #'schedule-loop + utc-earliest-time utc-other-earliest-time + utc-latest-time utc-other-latest-time + scheduler-spec schedule-generation-method + queue + :maximum-mileage revised-maximum-mileage + :maximum-extra-legs maximum-extra-legs + :maximum-connection-time maximum-connection-time + :same-pass-p same-pass-p + :preferred-end-airports preferred-end-airports + :maximum-blah random-magic + :skip-flifo-checks skip-flifo-checks + :magic1 table1 + :magic2 table2 + :preferred-connection-locations preferred-connection-locations + :disfavored-connection-locations disfavored-connection-locations + keys) + (when other-randomness + (loop for i fixnum from n-new to (+ n-new (1- this-n-new)) + do (hairy-calculation i result-array))) + (incf number-dequeued this-number-dequeued) + (incf n-new this-n-new) + (setq exit-reason (logior exit-reason this-exit-reason)))))) + (let ((n-hints-processed 0)) + (dolist (hint scheduler-hints) + (run-with-hint hint n-hints-processed t 0 + nil nil nil) + (incf n-hints-processed))) + (run-with-hint nil 42 nil maximum-extra-legs + '(yyy) '(xxx) t)) + exit-reason))))) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: stassats <sta...@us...> - 2014-06-14 17:39:59
|
The branch "master" has been updated in SBCL: via 398361a636113330df461bb0b5ee4d1250ff8235 (commit) from bb284806e6ddf9a7dd23f2e62c10b9c2c2020f12 (commit) - Log ----------------------------------------------------------------- commit 398361a636113330df461bb0b5ee4d1250ff8235 Author: Stas Boukarev <sta...@gm...> Date: Sat Jun 14 21:39:41 2014 +0400 Restore the docstring of sb-bsd-sockets:get-protocol-by-name. --- contrib/sb-bsd-sockets/inet.lisp | 5 ++--- 1 files changed, 2 insertions(+), 3 deletions(-) diff --git a/contrib/sb-bsd-sockets/inet.lisp b/contrib/sb-bsd-sockets/inet.lisp index 58643db..55f62bb 100644 --- a/contrib/sb-bsd-sockets/inet.lisp +++ b/contrib/sb-bsd-sockets/inet.lisp @@ -75,6 +75,8 @@ Examples: ;;; Try to get to a protocol quickly, falling back to calling ;;; getprotobyname if it's available. (defun get-protocol-by-name (name) + "Given a protocol name, return the protocol number, the protocol name, and +a list of protocol aliases" (let ((result (cdr (if (keywordp name) (assoc name *protocols*) (assoc name *protocols* :test #'string-equal))))) @@ -92,9 +94,6 @@ Examples: ;;; is here #-android (defun getprotobyname (name) - "Given a protocol name, return the protocol number, the protocol name, and -a list of protocol aliases" - ;; Brownie Points. Hopefully there's one person out there using ;; RSPF sockets and SBCL who will appreciate the extra info (labels ((protoent-to-values (protoent) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2014-06-13 19:50:39
|
The branch "master" has been updated in SBCL: via bb284806e6ddf9a7dd23f2e62c10b9c2c2020f12 (commit) from 402754884c861778ab7a93831aec52bd25748bae (commit) - Log ----------------------------------------------------------------- commit bb284806e6ddf9a7dd23f2e62c10b9c2c2020f12 Author: Douglas Katzman <do...@go...> Date: Fri Jun 13 15:46:24 2014 -0400 Fix sb-introspect on x86-64: single-float is an immediate object --- contrib/sb-introspect/introspect.lisp | 3 ++- contrib/sb-introspect/test-driver.lisp | 4 ++++ 2 files changed, 6 insertions(+), 1 deletions(-) diff --git a/contrib/sb-introspect/introspect.lisp b/contrib/sb-introspect/introspect.lisp index aa9f767..9973786 100644 --- a/contrib/sb-introspect/introspect.lisp +++ b/contrib/sb-introspect/introspect.lisp @@ -795,7 +795,8 @@ Experimental: interface subject to change." ;; scanning threads for negative answers? Similarly, STACK-ALLOCATED-P for ;; checking if an object has been stack-allocated by a given thread for ;; testing purposes might not come amiss. - (if (typep object '(or fixnum character)) + (if (typep object '(or fixnum character + #.(if (= sb-vm:n-word-bits 64) 'single-float (values)))) (values :immediate nil) (let ((plist (sb-sys:without-gcing diff --git a/contrib/sb-introspect/test-driver.lisp b/contrib/sb-introspect/test-driver.lisp index 1a5f6e7..1d94195 100644 --- a/contrib/sb-introspect/test-driver.lisp +++ b/contrib/sb-introspect/test-driver.lisp @@ -303,6 +303,10 @@ (deftest allocation-information.3 (tai 42 :immediate nil) t) +#+x86-64 +(deftest allocation-information.3b + (tai 42s0 :immediate nil) + t) ;;; Skip the whole damn test on GENCGC PPC -- the combination is just ;;; to flaky for this to make too much sense. GENCGC SPARC almost ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Christophe R. <cr...@us...> - 2014-06-13 15:23:49
|
The branch "master" has been updated in SBCL: via 402754884c861778ab7a93831aec52bd25748bae (commit) from 64d0778fd1ef8bdd8c4181c0774304cf6265b95f (commit) - Log ----------------------------------------------------------------- commit 402754884c861778ab7a93831aec52bd25748bae Author: Robert Swindells <rj...@fd...> Date: Wed Jun 11 14:45:34 2014 +0100 Initial support for threads on NetBSD/amd64. --- NEWS | 3 +++ contrib/sb-bsd-sockets/inet.lisp | 10 +++++----- src/runtime/Config.x86-64-netbsd | 5 +++++ src/runtime/bsd-os.h | 2 ++ 4 files changed, 15 insertions(+), 5 deletions(-) diff --git a/NEWS b/NEWS index 222896b..0b301bb 100644 --- a/NEWS +++ b/NEWS @@ -4,6 +4,9 @@ changes relative to sbcl-1.2.0: * enhancement: better error reporting for invalid calls to local functions. * enhancement: support for GNU/kFreeBSD distributions. (lp#1079954, thanks to Christoph Egger) + * enhancement: experimental support for threads on NetBSD/x86-64. (thanks + to Robert Swindells) + * bug fix: TYPE-OF must not return AND/OR/NOT expressions. (lp#1317308) * bug fix: accessing NIL arrays stopped producing errors. (lp#1311421) diff --git a/contrib/sb-bsd-sockets/inet.lisp b/contrib/sb-bsd-sockets/inet.lisp index 978218e..58643db 100644 --- a/contrib/sb-bsd-sockets/inet.lisp +++ b/contrib/sb-bsd-sockets/inet.lisp @@ -84,7 +84,7 @@ Examples: (getprotobyname (string-downcase name)) #+android (error 'unknown-protocol :name name)))) -#+(and sb-thread (not os-provides-getprotoby-r) (not android)) +#+(and sb-thread (not os-provides-getprotoby-r) (not android) (not netbsd)) ;; Since getprotobyname is not thread-safe, we need a lock. (sb-ext:defglobal **getprotoby-lock** (sb-thread:make-mutex :name "getprotoby lock")) @@ -111,7 +111,7 @@ a list of protocol aliases" (sb-alien:alien-sap alias) (sb-impl::default-external-format) 'character)))))) - #+(and sb-thread os-provides-getprotoby-r) + #+(and sb-thread os-provides-getprotoby-r (not netbsd)) (let ((buffer-length 1024) (max-buffer 10000) (result-buf nil) @@ -154,17 +154,17 @@ a list of protocol aliases" #-solaris (when result (sb-alien:free-alien result))))) - #-(and sb-thread os-provides-getprotoby-r) + #+(or (not sb-thread) (not os-provides-getprotoby-r) netbsd) (tagbody (flet ((get-it () (let ((ent (sockint::getprotobyname name))) (if (sb-alien::null-alien ent) (go :error) (return-from getprotobyname (protoent-to-values ent)))))) - #+sb-thread + #+(and sb-thread (not netbsd)) (sb-thread::with-system-mutex (**getprotoby-lock**) (get-it)) - #-sb-thread + #+(or (not sb-thread) netbsd) (get-it)) :error (error 'unknown-protocol :name name)))) diff --git a/src/runtime/Config.x86-64-netbsd b/src/runtime/Config.x86-64-netbsd index e893ee0..27e7beb 100644 --- a/src/runtime/Config.x86-64-netbsd +++ b/src/runtime/Config.x86-64-netbsd @@ -14,9 +14,14 @@ include Config.x86-64-bsd ASSEM_SRC += ldso-stubs.S OS_LIBS += -lutil +ifdef LISP_FEATURE_SB_THREAD + OS_LIBS += -lpthread -lrt +endif + # XXX why do all the other Configs set LINKFLAGS instead of LDFLAGS? # LINKFLAGS is only used in src/runtime/GNUmakefile, this causes the # dladdr test in tools-for-build/ to fail. LINKFLAGS += -export-dynamic LDFLAGS += -export-dynamic + diff --git a/src/runtime/bsd-os.h b/src/runtime/bsd-os.h index 45744d4..3ea3174 100644 --- a/src/runtime/bsd-os.h +++ b/src/runtime/bsd-os.h @@ -75,6 +75,8 @@ extern int openbsd_use_fxsave; typedef ucontext_t os_context_t; #define SIG_MEMORY_FAULT SIGSEGV +#define SIG_STOP_FOR_GC (SIGUSR2) + #elif defined LISP_FEATURE_DARWIN #include "darwin-os.h" #else ----------------------------------------------------------------------- hooks/post-receive -- SBCL |