X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-extensions.lisp;h=d18939be21377e8f46c8ae003b33eb846fc40d82;hb=8a33054f6541596c61b091e2b77118deda1511e2;hp=c4d59f4e05f6fe4678d07b9a3274d349bca1d931;hpb=988c0c0982e8ebb891da9241c71b5f8350448350;p=sbcl.git diff --git a/src/code/late-extensions.lisp b/src/code/late-extensions.lisp index c4d59f4..d18939b 100644 --- a/src/code/late-extensions.lisp +++ b/src/code/late-extensions.lisp @@ -73,99 +73,7 @@ sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag))))))) -(defmacro compare-and-swap (place old new &environment env) - "Atomically stores NEW in PLACE if OLD matches the current value of PLACE. -Two values are considered to match if they are EQ. Returns the previous value -of PLACE: if the returned value is EQ to OLD, the swap was carried out. - -PLACE must be an accessor form whose CAR is one of the following: - - CAR, CDR, FIRST, REST, SYMBOL-PLIST, SYMBOL-VALUE, SVREF - -or the name of a DEFSTRUCT created accessor for a slot whose declared type is -either FIXNUM or T. Results are unspecified if the slot has a declared type -other then FIXNUM or T. - -EXPERIMENTAL: Interface subject to change." - (flet ((invalid-place () - (error "Invalid first argument to COMPARE-AND-SWAP: ~S" place))) - (unless (consp place) - (invalid-place)) - ;; FIXME: Not the nicest way to do this... - (destructuring-bind (op &rest args) place - (case op - ((car first) - `(%compare-and-swap-car (the cons ,@args) ,old ,new)) - ((cdr rest) - `(%compare-and-swap-cdr (the cons ,@args) ,old ,new)) - (symbol-plist - `(%compare-and-swap-symbol-plist (the symbol ,@args) ,old (the list ,new))) - (symbol-value - (destructuring-bind (name) args - (flet ((slow (symbol) - (with-unique-names (n-symbol n-old n-new) - `(let ((,n-symbol ,symbol) - (,n-old ,old) - (,n-new ,new)) - (declare (symbol ,n-symbol)) - (about-to-modify-symbol-value ,n-symbol 'compare-and-swap ,n-new) - (%compare-and-swap-symbol-value ,n-symbol ,n-old ,n-new))))) - (if (sb!xc:constantp name env) - (let ((cname (constant-form-value name env))) - (if (eq :special (info :variable :kind cname)) - ;; Since we know the symbol is a special, we can just generate - ;; the type check. - `(%compare-and-swap-symbol-value - ',cname ,old (the ,(info :variable :type cname) ,new)) - (slow (list 'quote cname)))) - (slow name))))) - (svref - (let ((vector (car args)) - (index (cadr args))) - (unless (and vector index (not (cddr args))) - (invalid-place)) - (with-unique-names (v) - `(let ((,v ,vector)) - (declare (simple-vector ,v)) - (%compare-and-swap-svref ,v (%check-bound ,v (length ,v) ,index) ,old ,new))))) - (t - (let ((dd (info :function :structure-accessor op))) - (if dd - (let* ((structure (dd-name dd)) - (slotd (find op (dd-slots dd) :key #'dsd-accessor-name)) - (index (dsd-index slotd)) - (type (dsd-type slotd))) - (unless (eq t (dsd-raw-type slotd)) - (error "Cannot use COMPARE-AND-SWAP with structure accessor for a typed slot: ~S" - place)) - (when (dsd-read-only slotd) - (error "Cannot use COMPARE-AND-SWAP with structure accessor for a read-only slot: ~S" - place)) - `(truly-the (values ,type &optional) - (%compare-and-swap-instance-ref (the ,structure ,@args) - ,index - (the ,type ,old) (the ,type ,new)))) - (error "Invalid first argument to COMPARE-AND-SWAP: ~S" place)))))))) - -(macrolet ((def (name lambda-list ref &optional set) - #!+compare-and-swap-vops - (declare (ignore ref set)) - `(defun ,name (,@lambda-list old new) - #!+compare-and-swap-vops - (,name ,@lambda-list old new) - #!-compare-and-swap-vops - (let ((current (,ref ,@lambda-list))) - (when (eq current old) - ,(if set - `(,set ,@lambda-list new) - `(setf (,ref ,@lambda-list) new))) - current)))) - (def %compare-and-swap-car (cons) car) - (def %compare-and-swap-cdr (cons) cdr) - (def %compare-and-swap-instance-ref (instance index) %instance-ref %instance-set) - (def %compare-and-swap-symbol-plist (symbol) symbol-plist) - (def %compare-and-swap-symbol-value (symbol) symbol-value) - (def %compare-and-swap-svref (vector index) svref)) +;;;; ATOMIC-INCF and ATOMIC-DECF (defun expand-atomic-frob (name place diff) (flet ((invalid-place () @@ -173,47 +81,80 @@ EXPERIMENTAL: Interface subject to change." (unless (consp place) (invalid-place)) (destructuring-bind (op &rest args) place - (when (cdr args) - (invalid-place)) - (let ((dd (info :function :structure-accessor op))) - (if dd - (let* ((structure (dd-name dd)) - (slotd (find op (dd-slots dd) :key #'dsd-accessor-name)) - (index (dsd-index slotd)) - (type (dsd-type slotd))) - (declare (ignorable structure index)) - (unless (and (eq 'sb!vm:word (dsd-raw-type slotd)) - (type= (specifier-type type) (specifier-type 'sb!vm:word))) - (error "~S requires a slot of type (UNSIGNED-BYTE ~S), not ~S: ~S" - name sb!vm:n-word-bits type place)) - (when (dsd-read-only slotd) - (error "Cannot use ~S with structure accessor for a read-only slot: ~S" - name place)) - #!+(or x86 x86-64 ppc) - `(truly-the sb!vm:word - (%raw-instance-atomic-incf/word - (the ,structure ,@args) ,index - (logand #.(1- (ash 1 sb!vm:n-word-bits)) - ,(ecase name - (atomic-incf - `(the sb!vm:signed-word ,diff)) - (atomic-decf - `(- (the sb!vm:signed-word ,diff))))))) - ;; No threads outside x86 and x86-64 for now, so this is easy... - #!-(or x86 x86-64 ppc) - (with-unique-names (structure old) - `(sb!sys:without-interrupts - (let* ((,structure ,@args) - (,old (,op ,structure))) - (setf (,op ,structure) - (logand #.(1- (ash 1 sb!vm:n-word-bits)) - ,(ecase name - (atomic-incf - `(+ ,old (the sb!vm:signed-word ,diff))) - (atomic-decf - `(- ,old (the sb!vm:signed-word ,diff)))))) - ,old)))) - (invalid-place)))))) + (case op + (aref + (when (cddr args) + (invalid-place)) + #!+(or x86 x86-64 ppc) + (with-unique-names (array) + `(let ((,array (the (simple-array sb!ext:word (*)) ,(car args)))) + (%array-atomic-incf/word + ,array + (%check-bound ,array (array-dimension ,array 0) ,(cadr args)) + (logand #.(1- (ash 1 sb!vm:n-word-bits)) + ,(ecase name + (atomic-incf + `(the sb!vm:signed-word ,diff)) + (atomic-decf + `(- (the sb!vm:signed-word ,diff)))))))) + #!-(or x86 x86-64 ppc) + (with-unique-names (array index old-value) + (let ((incremented-value + (ecase name + (atomic-incf + `(+ ,old-value (the sb!vm:signed-word ,diff))) + (atomic-decf + `(- ,old-value (the sb!vm:signed-word ,diff)))))) + `(sb!sys:without-interrupts + (let* ((,array ,(car args)) + (,index ,(cadr args)) + (,old-value (aref ,array ,index))) + (setf (aref ,array ,index) + (logand #.(1- (ash 1 sb!vm:n-word-bits)) + ,incremented-value)) + ,old-value))))) + (t + (when (cdr args) + (invalid-place)) + (let ((dd (info :function :structure-accessor op))) + (if dd + (let* ((structure (dd-name dd)) + (slotd (find op (dd-slots dd) :key #'dsd-accessor-name)) + (index (dsd-index slotd)) + (type (dsd-type slotd))) + (declare (ignorable structure index)) + (unless (and (eq 'sb!vm:word (dsd-raw-type slotd)) + (type= (specifier-type type) (specifier-type 'sb!vm:word))) + (error "~S requires a slot of type (UNSIGNED-BYTE ~S), not ~S: ~S" + name sb!vm:n-word-bits type place)) + (when (dsd-read-only slotd) + (error "Cannot use ~S with structure accessor for a read-only slot: ~S" + name place)) + #!+(or x86 x86-64 ppc) + `(truly-the sb!vm:word + (%raw-instance-atomic-incf/word + (the ,structure ,@args) ,index + (logand #.(1- (ash 1 sb!vm:n-word-bits)) + ,(ecase name + (atomic-incf + `(the sb!vm:signed-word ,diff)) + (atomic-decf + `(- (the sb!vm:signed-word ,diff))))))) + ;; No threads outside x86 and x86-64 for now, so this is easy... + #!-(or x86 x86-64 ppc) + (with-unique-names (structure old) + `(sb!sys:without-interrupts + (let* ((,structure ,@args) + (,old (,op ,structure))) + (setf (,op ,structure) + (logand #.(1- (ash 1 sb!vm:n-word-bits)) + ,(ecase name + (atomic-incf + `(+ ,old (the sb!vm:signed-word ,diff))) + (atomic-decf + `(- ,old (the sb!vm:signed-word ,diff)))))) + ,old)))) + (invalid-place)))))))) (defmacro atomic-incf (place &optional (diff 1)) #!+sb-doc @@ -226,7 +167,8 @@ PLACE. PLACE must be an accessor form whose CAR is the name of a DEFSTRUCT accessor whose declared type is (UNSIGNED-BYTE 32) on 32 bit platforms, -and (UNSIGNED-BYTE 64) on 64 bit platforms. +and (UNSIGNED-BYTE 64) on 64 bit platforms or an AREF of a (SIMPLE-ARRAY +SB-EXT:WORD (*) -- the type SB-EXT:WORD can be used for this purpose. DIFF defaults to 1, and must be a (SIGNED-BYTE 32) on 32 bit platforms, and (SIGNED-BYTE 64) on 64 bit platforms. @@ -245,7 +187,8 @@ PLACE. PLACE must be an accessor form whose CAR is the name of a DEFSTRUCT accessor whose declared type is (UNSIGNED-BYTE 32) on 32 bit platforms, -and (UNSIGNED-BYTE 64) on 64 bit platforms. +and (UNSIGNED-BYTE 64) on 64 bit platforms or an AREF of a (SIMPLE-ARRAY +SB-EXT:WORD (*) -- the type SB-EXT:WORD can be used for this purpose. DIFF defaults to 1, and must be a (SIGNED-BYTE 32) on 32 bit platforms, and (SIGNED-BYTE 64) on 64 bit platforms. @@ -253,6 +196,19 @@ and (SIGNED-BYTE 64) on 64 bit platforms. EXPERIMENTAL: Interface subject to change." (expand-atomic-frob 'atomic-decf place diff)) +;; Interpreter stubs for ATOMIC-INCF. +#!+(or x86 x86-64 ppc) +(defun %array-atomic-incf/word (array index diff) + (declare (type (simple-array word (*)) array) + (fixnum index) + (type sb!vm:signed-word diff)) + (%array-atomic-incf/word array index diff)) + +(defun spin-loop-hint () + #!+sb-doc + "Hints the processor that the current thread is spin-looping." + (spin-loop-hint)) + (defun call-hooks (kind hooks &key (on-error :error)) (dolist (hook hooks) (handler-case @@ -301,3 +257,111 @@ See also the declarations SB-EXT:GLOBAL and SB-EXT:ALWAYS-BOUND." (sb!c:with-source-location (source-location) (setf (info :source-location :variable name) source-location)) name) + +;;;; WAIT-FOR -- waiting on arbitrary conditions + +(defun %%wait-for (test stop-sec stop-usec) + (declare (function test)) + (labels ((try () + (declare (optimize (safety 0))) + (awhen (funcall test) + (return-from %%wait-for it))) + (tick (sec usec) + (declare (fixnum sec usec)) + ;; TICK is microseconds + (+ usec (* 1000000 sec))) + (get-tick () + (multiple-value-call #'tick + (decode-internal-time (get-internal-real-time))))) + (let* ((timeout-tick (when stop-sec (tick stop-sec stop-usec))) + (start (get-tick)) + ;; Rough estimate of how long a single attempt takes. + (try-ticks (progn + (try) (try) (try) + (max 1 (truncate (- (get-tick) start) 3))))) + ;; Scale sleeping between attempts: + ;; + ;; Start by sleeping for as many ticks as an average attempt + ;; takes, then doubling for each attempt. + ;; + ;; Max out at 0.1 seconds, or the 2 x time of a single try, + ;; whichever is longer -- with a hard cap of 10 seconds. + ;; + ;; FIXME: Maybe the API should have a :MAX-SLEEP argument? + (loop with max-ticks = (max 100000 (min (* 2 try-ticks) + (expt 10 7))) + for scale of-type fixnum = 1 + then (let ((x (logand most-positive-fixnum (* 2 scale)))) + (if (> scale x) + most-positive-fixnum + x)) + do (try) + (let* ((now (get-tick)) + (sleep-ticks (min (* try-ticks scale) max-ticks)) + (sleep + (if timeout-tick + ;; If sleep would take us past the + ;; timeout, shorten it so it's just + ;; right. + (if (>= (+ now sleep-ticks) timeout-tick) + (- timeout-tick now) + sleep-ticks) + sleep-ticks))) + (declare (fixnum sleep)) + (cond ((plusp sleep) + ;; microseconds to seconds and nanoseconds + (multiple-value-bind (sec nsec) + (truncate (* 1000 sleep) (expt 10 9)) + (with-interrupts + (sb!unix:nanosleep sec nsec)))) + (t + (return-from %%wait-for nil)))))))) + +(defun %wait-for (test timeout) + (declare (function test)) + (tagbody + :restart + (multiple-value-bind (to-sec to-usec stop-sec stop-usec deadlinep) + (decode-timeout timeout) + (declare (ignore to-sec to-usec)) + (return-from %wait-for + (or (%%wait-for test stop-sec stop-usec) + (when deadlinep + (signal-deadline) + (go :restart))))))) + +(defmacro wait-for (test-form &key timeout) + #!+sb-doc + "Wait until TEST-FORM evaluates to true, then return its primary value. +If TIMEOUT is provided, waits at most approximately TIMEOUT seconds before +returning NIL. + +If WITH-DEADLINE has been used to provide a global deadline, signals a +DEADLINE-TIMEOUT if TEST-FORM doesn't evaluate to true before the +deadline. + +Experimental: subject to change without prior notice." + `(dx-flet ((wait-for-test () (progn ,test-form))) + (%wait-for #'wait-for-test ,timeout))) + +(defmacro with-progressive-timeout ((name &key seconds) + &body body) + #!+sb-doc + "Binds NAME as a local function for BODY. Each time #'NAME is called, it +returns SECONDS minus the time that has elapsed since BODY was entered, or +zero if more time than SECONDS has elapsed. If SECONDS is NIL, #'NAME +returns NIL each time." + (with-unique-names (deadline time-left sec) + `(let* ((,sec ,seconds) + (,deadline + (when ,sec + (+ (get-internal-real-time) + (round (* ,seconds internal-time-units-per-second)))))) + (flet ((,name () + (when ,deadline + (let ((,time-left (- ,deadline (get-internal-real-time)))) + (if (plusp ,time-left) + (* (coerce ,time-left 'single-float) + ,(/ 1.0 internal-time-units-per-second)) + 0))))) + ,@body))))