number changes have affected all CPUs equally. Similarly,
the byte fasl file version is now equal to the ordinary
fasl file version.
+?? minor incompatible change: SB-EXT:GET-BYTES-CONSED now
+ returns the number of bytes consed since the system started,
+ rather than the number consed since the first time the function
+ was called. (The new definition parallels ANSI functions like
+ CL:GET-INTERNAL-RUN-TIME.)
planned incompatible changes in 0.7.x:
* The debugger prompt sequence now goes "5]", "5[2]", "5[3]", etc.
sh make-target-1.sh || exit 1
sh make-host-2.sh || exit 1
sh make-target-2.sh || exit 1
+date
;; indenting
"MAKE-INDENTING-STREAM"
- "INDENTING-FURTHER"
;; stream commands, used by the debugger
"GET-STREAM-COMMAND" "MAKE-STREAM-COMMAND" "STREAM-COMMAND"
"UNIX-PIPE" "UNIX-READ" "UNIX-READLINK" "UNIX-RECV" "UNIX-RENAME"
"UNIX-RMDIR" "UNIX-SELECT" "UNIX-SEND" "UNIX-SETPGRP"
"UNIX-SOCKET" "UNIX-STAT" "UNIX-SYMLINK" "UNIX-SYNC"
- "UNIX-TIMES" "UNIX-TRUNCATE" "UNIX-TTYNAME"
+ "UNIX-TRUNCATE" "UNIX-TTYNAME"
"UNIX-UID" "UNIX-UNLINK" "UNIX-UTIMES" "UNIX-WRITE" "WINSIZE"
"WRITEGRP" "WRITEOTH" "WRITEOWN" "WS-COL" "WS-ROW" "WS-XPIXEL"
"WS-YPIXEL" "W_OK" "X_OK" "SIGSYS" "TCSETPGRP" "FD-ZERO"
(defvar *cached-readtable* nil)
(declaim (type (or readtable null) *cached-readtable*))
-(pushnew #'(lambda ()
- (setq *cached-debug-source* nil *cached-source-stream* nil
- *cached-readtable* nil))
- sb!int:*before-save-initializations*)
+(pushnew (lambda ()
+ (setq *cached-debug-source* nil *cached-source-stream* nil
+ *cached-readtable* nil))
+ *before-save-initializations*)
;;; We also cache the last top-level form that we printed a source for
;;; so that we don't have to do repeated reads and calls to
(defvar *last-bytes-in-use* nil)
(defvar *total-bytes-consed* 0)
(declaim (type (or index null) *last-bytes-in-use*))
-(declaim (type integer *total-bytes-consed*))
+(declaim (type unsigned-byte *total-bytes-consed*))
(declaim (ftype (function () unsigned-byte) get-bytes-consed))
(defun get-bytes-consed ()
#!+sb-doc
- "Returns the number of bytes consed since the first time this function
+ "Return the number of bytes consed since the first time this function
was called. The first time it is called, it returns zero."
(declare (optimize (speed 3) (safety 0)))
(cond ((null *last-bytes-in-use*)
(incf *total-bytes-consed*
(the index (- bytes *last-bytes-in-use*)))
(setq *last-bytes-in-use* bytes))))
+ ;; FIXME: We should really use something like PCOUNTER to make this
+ ;; hold reliably.
+ (aver (not (minusp *total-bytes-consed*)))
*total-bytes-consed*)
\f
;;;; variables and constants
;;; the default value of *BYTES-CONSED-BETWEEN-GCS* and *GC-TRIGGER*
(defconstant default-bytes-consed-between-gcs 2000000)
-;;; This variable is the user-settable variable that specifies the
-;;; minimum amount of dynamic space which must be consed before a GC
-;;; will be triggered.
+;;; the minimum amount of dynamic space which must be consed before a
+;;; GC will be triggered
;;;
-;;; Unlike CMU CL, we don't export this variable. (There's no need to, since
-;;; the BYTES-CONSED-BETWEEN-GCS function is SETFable.)
-(defvar *bytes-consed-between-gcs* default-bytes-consed-between-gcs
- #!+sb-doc
- "This number specifies the minimum number of bytes of dynamic space
- that must be consed before the next GC will occur.")
+;;; Unlike CMU CL, we don't export this variable. (There's no need to,
+;;; since the BYTES-CONSED-BETWEEN-GCS function is SETFable.)
+(defvar *bytes-consed-between-gcs* default-bytes-consed-between-gcs)
(declaim (type index *bytes-consed-between-gcs*))
;;;; GC hooks
;;; the dynamic usage is not greater than *GC-TRIGGER*.
;;;
;;; For GENCGC all generations < GEN will be GC'ed.
-;;;
(defun sub-gc (&key force-p (gen 0))
(/show0 "entering SUB-GC")
(unless *already-maybe-gcing*
;;; bytes consed in a profiled function are all examples of such
;;; quantities.)
(defstruct (pcounter (:copier nil))
- (integer 0 :type unsigned-byte)
- (fixnum 0 :type (and fixnum unsigned-byte)))
+ (integer 0);; :type unsigned-byte)
+ (fixnum 0));; :type (and fixnum unsigned-byte)))
-(declaim (ftype (function (pcounter integer) pcounter) incf-pcounter))
+;;;(declaim (ftype (function (pcounter unsigned-byte) pcounter) incf-pcounter))
;;;(declaim (inline incf-pcounter)) ; FIXME: maybe inline when more stable
(defun incf-pcounter (pcounter delta)
+ (aver (typep delta 'unsigned-byte))
(let ((sum (+ (pcounter-fixnum pcounter) delta)))
+ (aver (typep sum 'unsigned-byte))
+ ;;(declare (type unsigned-byte sum))
(cond ((typep sum 'fixnum)
(setf (pcounter-fixnum pcounter) sum))
(t
;;; (TYPEP DELTA 'FIXNUM) case inline and only calling generic
;;; arithmetic as a last resort.
(defmacro fastbig-incf-pcounter-or-fixnum (x delta)
- (once-only ((delta delta))
- `(etypecase ,delta
- (fixnum (incf-pcounter-or-fixnum ,x ,delta))
- (integer (incf-pcounter-or-fixnum ,x ,delta)))))
+ (let ((delta-sym (gensym "DELTA")))
+ `(let ((,delta-sym ,delta))
+ (aver (typep ,delta-sym 'unsigned-byte))
+ ;;(declare (type unsigned-byte ,delta-sym))
+ (if (typep ,delta-sym 'fixnum)
+ (incf-pcounter-or-fixnum ,x ,delta)
+ (incf-pcounter-or-fixnum ,x ,delta)))))
(declaim (ftype (function ((or pcounter fixnum)) integer) pcounter-or-fixnum->integer))
(declaim (maybe-inline pcounter-or-fixnum->integer))
(let ((dticks 0)
(dconsing 0)
(inner-enclosed-profiles 0))
- (declare (type unsigned-byte dticks dconsing))
- (declare (type unsigned-byte inner-enclosed-profiles))
+ ;;(declare (type unsigned-byte dticks dconsing))
+ ;;(declare (type unsigned-byte inner-enclosed-profiles))
+ (aver (typep dticks 'unsigned-byte))
+ (aver (typep dconsing 'unsigned-byte))
+ (aver (typep inner-enclosed-profiles 'unsigned-byte))
(multiple-value-prog1
(let ((start-ticks (get-internal-ticks))
;; KLUDGE: We add (THE UNSIGNED-BYTE ..) wrappers
start-consing))
(setf inner-enclosed-profiles
(pcounter-or-fixnum->integer *enclosed-profiles*))
- (fastbig-incf-pcounter-or-fixnum ticks (fastbig-
- dticks
- *enclosed-ticks*))
- (fastbig-incf-pcounter-or-fixnum consing
- (fastbig-
- dconsing
- *enclosed-consing*))
+ (when (minusp dticks) ; REMOVEME
+ (error "huh? (GET-INTERNAL-TICKS)=~S START-TICKS=~S"
+ (get-internal-ticks) start-ticks))
+ (aver (not (minusp dconsing))) ; REMOVEME
+ (aver (not (minusp inner-enclosed-profiles))) ; REMOVEME
+ (let ((net-dticks (fastbig- dticks *enclosed-ticks*)))
+ (when (minusp net-dticks) ; REMOVEME
+ (error "huh? DTICKS=~S, *ENCLOSED-TICKS*=~S"
+ dticks *enclosed-ticks*))
+ (fastbig-incf-pcounter-or-fixnum ticks net-dticks))
+ (let ((net-dconsing (fastbig- dconsing *enclosed-consing*)))
+ (when (minusp net-dconsing) ; REMOVEME
+ (error "huh? DCONSING=~S, *ENCLOSED-CONSING*=~S"
+ dticks *enclosed-ticks*))
+ (fastbig-incf-pcounter-or-fixnum consing net-dconsing))
(fastbig-incf-pcounter-or-fixnum profiles
inner-enclosed-profiles)))
(fastbig-incf-pcounter-or-fixnum *enclosed-ticks* dticks)
inner-enclosed-profiles)))))
;; READ-STATS-FUN
(lambda ()
- (values (pcounter-or-fixnum->integer count)
- (pcounter-or-fixnum->integer ticks)
- (pcounter-or-fixnum->integer consing)
- (pcounter-or-fixnum->integer profiles)))
+ (format t "/entering READ-STATS-FUN ~S ~S ~S ~S~%"
+ count ticks consing profiles) ; REMOVEME (and M-V-PROG1 below)
+ (multiple-value-prog1
+ (values (pcounter-or-fixnum->integer count)
+ (pcounter-or-fixnum->integer ticks)
+ (pcounter-or-fixnum->integer consing)
+ (pcounter-or-fixnum->integer profiles))
+ (print "/returning from READ-STATS-FUN")))
;; CLEAR-STATS-FUN
(lambda ()
(setf count 0
(in-package "SB!IMPL")
\f
-(defvar *before-save-initializations* nil
- #!+sb-doc
- "This is a list of functions which are called before creating a saved core
- image. These functions are executed in the child process which has no ports,
- so they cannot do anything that tries to talk to the outside world.")
-
-(defvar *after-save-initializations* nil
- #!+sb-doc
- "This is a list of functions which are called when a saved core image starts
- up. The system itself should be initialized at this point, but applications
- might not be.")
-\f
;;;; SAVE-LISP-AND-DIE itself
(sb!alien:def-alien-routine "save" (sb!alien:boolean)
(in-package "SB!IMPL")
\f
-;;;; miscellaneous I/O
+;;;; variables related to saving core files
+;;;;
+;;;; (Most of the save-a-core functionality is defined later, in its
+;;;; own file, but we'd like to have these symbols declared special
+;;;; and initialized ASAP.)
+
+(defvar *before-save-initializations* nil
+ #!+sb-doc
+ "This is a list of functions which are called before creating a saved core
+ image. These functions are executed in the child process which has no ports,
+ so they cannot do anything that tries to talk to the outside world.")
-;;; INDENTING-FURTHER is a user-level macro which may be used to locally
-;;; increment the indentation of a stream.
-(defmacro indenting-further (stream more &rest body)
+(defvar *after-save-initializations* nil
#!+sb-doc
- "Causes the output of the indenting Stream to indent More spaces. More is
- evaluated twice."
- `(unwind-protect
- (progn
- (incf (sb!impl::indenting-stream-indentation ,stream) ,more)
- ,@body)
- (decf (sb!impl::indenting-stream-indentation ,stream) ,more)))
+ "This is a list of functions which are called when a saved core image starts
+ up. The system itself should be initialized at this point, but applications
+ might not be.")
+\f
+;;;; miscellaneous I/O
(defun skip-whitespace (&optional (stream *standard-input*))
(loop (let ((char (read-char stream)))
(defun get-internal-real-time ()
#!+sb-doc
"Return the real time in the internal time format. This is useful for
- finding elapsed time. See Internal-Time-Units-Per-Second."
+ finding elapsed time. See INTERNAL-TIME-UNITS-PER-SECOND."
;; FIXME: See comment on OPTIMIZE declaration in GET-INTERNAL-RUN-TIME.
(declare (optimize (speed 3) (safety 3)))
(multiple-value-bind (ignore seconds useconds) (sb!unix:unix-gettimeofday)
(setq *internal-real-time-base-seconds* seconds)
uint)))))
-#!-(and sparc svr4)
+;;; REMOVEME once runtime nonmonotonicity problem is debugged
+(defvar *last-utime-sec*)
+(defvar *last-utime-usec*)
+(defvar *last-stime-sec*)
+(defvar *last-stime-usec*)
+(defvar *last-internal-run-time*)
+(push (lambda ()
+ (makunbound '*last-internal-run-time*))
+ *before-save-initializations*)
+
(defun get-internal-run-time ()
#!+sb-doc
"Return the run time in the internal time format. This is useful for
;; documented anywhere and the observed behavior is to
;; sometimes return 1000000 exactly.)
(type (integer 0 1000000) utime-usec stime-usec))
- (+ (the (unsigned-byte 32)
- (* (the (unsigned-byte 32) (+ utime-sec stime-sec))
- internal-time-units-per-second))
- (truncate (+ utime-usec stime-usec)
- micro-seconds-per-internal-time-unit))))
-#!+(and sparc svr4)
-(defun get-internal-run-time ()
- #!+sb-doc
- "Return the run time in the internal time format. This is useful for
- finding CPU usage."
- (declare (values (unsigned-byte 32)))
- ;; FIXME: See comment on OPTIMIZE declaration in other
- ;; version of GET-INTERNAL-RUN-TIME.
- (declare (optimize (speed 3) (safety 3)))
- (multiple-value-bind (ignore utime stime cutime cstime)
- (sb!unix:unix-times)
- (declare (ignore ignore cutime cstime)
- (type (unsigned-byte 31) utime stime))
- (the (unsigned-byte 32) (+ utime stime))))
+ (let ((result (+ (the (unsigned-byte 32)
+ (* (the (unsigned-byte 32) (+ utime-sec stime-sec))
+ internal-time-units-per-second))
+ (floor (+ utime-usec
+ stime-usec
+ (floor micro-seconds-per-internal-time-unit 2))
+ micro-seconds-per-internal-time-unit))))
+
+ ;; REMOVEME once runtime nonmonotonicity problem is debugged
+ (when (boundp '*last-internal-run-time*)
+ (unless (>= result *last-internal-run-time*)
+ (error "non-monotonic:~@
+ UTIME-SEC ~S ~S~@
+ UTIME-USEC ~S ~S~@
+ STIME-SEC ~S ~S~@
+ STIME-USEC ~S ~S~@
+ RESULT ~S ~S"
+ *last-utime-sec* utime-sec
+ *last-utime-usec* utime-usec
+ *last-stime-sec* stime-sec
+ *last-stime-usec* stime-usec
+ *last-internal-run-time* result)))
+ (setf *last-utime-sec* utime-sec
+ *last-utime-usec* utime-usec
+ *last-stime-sec* stime-sec
+ *last-stime-usec* stime-usec
+ *last-internal-run-time* result)
+
+ result)))
\f
;;;; Encode and decode universal times.
#!-sb-fluid (declaim (inline unix-fast-getrusage))
(defun unix-fast-getrusage (who)
(declare (values (member t)
- (unsigned-byte 31) (mod 1000000)
- (unsigned-byte 31) (mod 1000000)))
+ (unsigned-byte 31) (integer 0 1000000)
+ (unsigned-byte 31) (integer 0 1000000)))
(with-alien ((usage (struct rusage)))
(syscall* ("getrusage" int (* (struct rusage)))
(values t
#include "interrupt.h"
#include "interr.h"
#include "breakpoint.h"
+#include "monitor.h"
extern char call_into_lisp_LRA[], call_into_lisp_end[];
extern size_t os_vm_page_size;
#define BREAKPOINT_INST 0x80
-void arch_init(void)
+void
+arch_init(void)
{
- /* this must be called _after_ os_init, so we know what the page size is */
+ /* This must be called _after_ os_init, so we know what the page
+ * size is. */
if(mmap((os_vm_address_t) call_into_lisp_LRA_page,os_vm_page_size,
OS_VM_PROT_ALL,MAP_PRIVATE|MAP_ANONYMOUS|MAP_FIXED,-1,0)
== (os_vm_address_t) -1)
/* call_into_lisp_LRA is a collection of trampolines written in asm -
* see alpha-assem.S. We copy it to call_into_lisp_LRA_page where
- * VOPs and things can find it (I don't know why they can't find it
- * where it was to start with). */
+ * VOPs and things can find it. (I don't know why they can't find it
+ * where it was to start with.) */
bcopy(call_into_lisp_LRA,(void *)call_into_lisp_LRA_page,os_vm_page_size);
os_flush_icache((os_vm_address_t)call_into_lisp_LRA_page,
os_vm_address_t
arch_get_bad_addr (int sig, siginfo_t *code, os_context_t *context)
{
- unsigned int badinst;
+ unsigned int badinst;
- /* instructions are 32 bit quantities */
- unsigned int *pc ;
- /* fprintf(stderr,"arch_get_bad_addr %d %p %p\n",
- sig, code, context); */
- pc= (unsigned int *)(*os_context_pc_addr(context));
+ /* Instructions are 32 bit quantities. */
+ unsigned int *pc ;
+ /* fprintf(stderr,"arch_get_bad_addr %d %p %p\n",
+ sig, code, context); */
+ pc= (unsigned int *)(*os_context_pc_addr(context));
- if(((unsigned long)pc) & 3)
- return NULL; /* in what case would pc be unaligned? */
+ if(((unsigned long)pc) & 3) {
+ return NULL; /* In what case would pc be unaligned?? */
+ }
- if( (pc < READ_ONLY_SPACE_START ||
- pc >= READ_ONLY_SPACE_START+READ_ONLY_SPACE_SIZE) &&
- (pc < current_dynamic_space ||
- pc >= current_dynamic_space + DYNAMIC_SPACE_SIZE))
- return NULL;
+ if( (pc < READ_ONLY_SPACE_START ||
+ pc >= READ_ONLY_SPACE_START+READ_ONLY_SPACE_SIZE) &&
+ (pc < current_dynamic_space ||
+ pc >= current_dynamic_space + DYNAMIC_SPACE_SIZE))
+ return NULL;
- badinst = *pc;
+ badinst = *pc;
- if(((badinst>>27)!=0x16) /* STL or STQ */
- && ((badinst>>27)!=0x13)) /* STS or STT */
- return NULL; /* Otherwise forget about address */
+ if(((badinst>>27)!=0x16) /* STL or STQ */
+ && ((badinst>>27)!=0x13)) /* STS or STT */
+ return NULL; /* Otherwise forget about address. */
- return (os_vm_address_t)
- (*os_context_register_addr(context,((badinst>>16)&0x1f))
- +(badinst&0xffff));
+ return (os_vm_address_t)
+ (*os_context_register_addr(context,((badinst>>16)&0x1f))
+ +(badinst&0xffff));
}
-void arch_skip_instruction(os_context_t *context)
+void
+arch_skip_instruction(os_context_t *context)
{
- /* this may be complete rubbish, as (at least for traps) pc points
- * _after_ the instruction that caused us to be here anyway
+ /* This may be complete rubbish, as (at least for traps) pc points
+ * _after_ the instruction that caused us to be here anyway.
*/
((char*)*os_context_pc_addr(context)) +=4; }
-unsigned char *arch_internal_error_arguments(os_context_t *context)
+unsigned char *
+arch_internal_error_arguments(os_context_t *context)
{
return (unsigned char *)(*os_context_pc_addr(context)+4);
}
-boolean arch_pseudo_atomic_atomic(os_context_t *context)
+boolean
+arch_pseudo_atomic_atomic(os_context_t *context)
{
- return ((*os_context_register_addr(context,reg_ALLOC)) & 1);
+ return ((*os_context_register_addr(context,reg_ALLOC)) & 1);
}
void arch_set_pseudo_atomic_interrupted(os_context_t *context)
void arch_remove_breakpoint(void *pc, unsigned long orig_inst)
{
/* was (unsigned int) but gcc complains. Changed to mirror
- install_breakpoint above */
+ * install_breakpoint() above */
unsigned long *ptr=(unsigned long *)pc;
*ptr = orig_inst;
os_flush_icache((os_vm_address_t)pc, sizeof(unsigned long));
after_breakpoint;
-/* Returns a PC value. Lisp code is all in the 32-bit-addressable
- space,so we should be ok with an unsigned int */
-
+/* This returns a PC value. Lisp code is all in the 32-bit-addressable
+ * space,so we should be ok with an unsigned int. */
unsigned int
emulate_branch(os_context_t *context,unsigned long orig_inst)
{
orig_sigmask = *os_context_sigmask_addr(context);
sigaddset_blockable(os_context_sigmask_addr(context));
- /* Figure out where the displaced inst is going */
+ /* Figure out where the displaced inst is going. */
if(op == 0x1a || (op&0xf) == 0x30) /* branch...ugh */
- /* the cast to long is just to shut gcc up */
+ /* The cast to long is just to shut gcc up. */
next_pc = (unsigned int *)((long)emulate_branch(context,orig_inst));
else
next_pc = pc+1;
os_flush_icache((os_vm_address_t)pc, sizeof(unsigned long));
skipped_break_addr = pc;
- /* set the after breakpoint */
+ /* Set the after breakpoint. */
displaced_after_inst = *next_pc;
*next_pc = BREAKPOINT_INST;
after_breakpoint=1;
os_flush_icache((os_vm_address_t)next_pc, sizeof(unsigned long));
- ldb_monitor("sigreturn is not implemented and just failed");
+ ldb_monitor();
sigreturn(context);
}
#define AfterBreakpoint 100
-static void sigill_handler(int signal, siginfo_t *siginfo, os_context_t *context) {
+static void
+sigill_handler(int signal, siginfo_t *siginfo, os_context_t *context) {
fake_foreign_function_call(context);
ldb_monitor();
}
-static void sigtrap_handler(int signal, siginfo_t *siginfo, os_context_t *context)
+static void
+sigtrap_handler(int signal, siginfo_t *siginfo, os_context_t *context)
{
/* Don't disallow recursive breakpoint traps. Otherwise, we can't */
/* use debugger breakpoints anywhere in here. */
/* This is apparently called by emulate_branch, but isn't defined. So */
/* just do nothing and hope it works... */
-
void cacheflush(void)
{
/* hoping probably isn't _actually_ enough. we should call_pal imb,
}
interrupt_low_level_handlers[signal] =
- (ARE_SAME_HANDLER(handler,SIG_DFL) ? 0 : handler);
+ (ARE_SAME_HANDLER(handler, SIG_DFL) ? 0 : handler);
}
/* This is called from Lisp. */
goto fdefn;
}
}
- printf("symbol 0x%08lx is undefined.\n", (long unsigned)thing);
+ printf("Symbol 0x%08lx is undefined.\n", (long unsigned)thing);
return;
case type_Fdefn:
fdefn:
function = FDEFN(thing)->function;
if (function == NIL) {
- printf("fdefn 0x%08lx is undefined.\n", (long unsigned)thing);
+ printf("Fdefn 0x%08lx is undefined.\n", (long unsigned)thing);
return;
}
break;
}
}
+static void
+sigill_handler(int signal, siginfo_t *siginfo, void *void_context) {
+ os_context_t *context = (os_context_t*)void_context;
+ fprintf(stderr, "\n/entering sigill_handler()\n"); /*REMOVEME*/
+ fake_foreign_function_call(context);
+ ldb_monitor();
+}
+
void
arch_install_interrupt_handlers()
{
SHOW("entering arch_install_interrupt_handlers()");
- undoably_install_low_level_interrupt_handler(SIGILL , sigtrap_handler);
+
+ /* Note: The old CMU CL code here used sigtrap_handler() to handle
+ * SIGILL as well as SIGTRAP. I couldn't see any reason to do
+ * things that way. So, I changed to separate handlers when
+ * debugging a problem on OpenBSD, where SBCL wasn't catching
+ * SIGILL properly, but was instead letting the process be
+ * terminated with an "Illegal instruction" output. If this change
+ * turns out to break something (maybe breakpoint handling on some
+ * OS I haven't tested on?) and we have to go back to the old CMU
+ * CL way, I hope there will at least be a comment to explain
+ * why.. -- WHN 2001-06-07 */
+ undoably_install_low_level_interrupt_handler(SIGILL , sigill_handler);
undoably_install_low_level_interrupt_handler(SIGTRAP, sigtrap_handler);
+
SHOW("returning from arch_install_interrupt_handlers()");
}
\f
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+(in-package "CL-USER")
+
+;;; Test for monotonicity of GET-INTERNAL-RUN-TIME.
+(funcall (compile nil
+ (lambda (n-seconds)
+ (declare (type fixnum n-seconds))
+ (let* ((n-internal-time-units
+ (* n-seconds
+ internal-time-units-per-second))
+ (time0 (get-internal-run-time))
+ (time1 (+ time0 n-internal-time-units)))
+ (loop
+ (let ((time (get-internal-run-time)))
+ (assert (>= time time0))
+ (when (>= time time1)
+ (return)))))))
+ 3)
+
+(locally
+ (declare (notinline mapcar))
+ (mapcar (lambda (args)
+ (destructuring-bind (obj type-spec result) args
+ (flet ((matches-result? (x)
+ (eq (if x t nil) result)))
+ (assert (matches-result? (typep obj type-spec)))
+ (assert (matches-result? (sb-kernel:ctypep
+ obj
+ (sb-kernel:specifier-type
+ type-spec)))))))
+ '((nil (or null vector) t)
+ (nil (or number vector) nil)
+ (12 (or null vector) nil)
+ (12 (and (or number vector) real) t))))
+
+
\ No newline at end of file
;;; versions, and a string like "0.6.5.12" is used for versions which
;;; aren't released but correspond only to CVS tags or snapshots.
-"0.6.12.25"
+"0.6.12.26"
projects / sbcl.git / commitdiff