src/code/late-extensions.lisp

   1 ;;;; various extensions (including SB-INT "internal extensions")
   2 ;;;; available both in the cross-compilation host Lisp and in the
   3 ;;;; target SBCL, but which can't be defined on the target until until
   4 ;;;; some significant amount of machinery (e.g. error-handling) is
   5 ;;;; defined
   6
   7 ;;;; This software is part of the SBCL system. See the README file for
   8 ;;;; more information.
   9 ;;;;
  10 ;;;; This software is derived from the CMU CL system, which was
  11 ;;;; written at Carnegie Mellon University and released into the
  12 ;;;; public domain. The software is in the public domain and is
  13 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  14 ;;;; files for more information.
  15
  16 (in-package "SB!IMPL")
  17
  18 ;;; Is X a list for which LENGTH is meaningful, i.e. a list which is
  19 ;;; not improper and which is not circular?
  20 (defun list-with-length-p (x)
  21   (values (ignore-errors (list-length x))))
  22
  23 ;;; not used in 0.7.8, but possibly useful for defensive programming
  24 ;;; in e.g. (COERCE ... 'VECTOR)
  25 ;;;(defun list-length-or-die (x)
  26 ;;;  (or (list-length x)
  27 ;;;      ;; not clear how to do this best:
  28 ;;;      ;;   * Should this be a TYPE-ERROR? Colloquially that'd make
  29 ;;;      ;;     lots of sense, but since I'm not sure how to express
  30 ;;;      ;;     "noncircular list" as a Lisp type expression, coding
  31 ;;;      ;;     it seems awkward.
  32 ;;;      ;;   * Should the ERROR object include the offending value?
  33 ;;;      ;;     Ordinarily that's helpful, but if the user doesn't have
  34 ;;;      ;;     his printer set up to deal with cyclicity, we might not
  35 ;;;      ;;     be doing him a favor by printing the object here.
  36 ;;;      ;; -- WHN 2002-10-19
  37 ;;;      (error "can't calculate length of cyclic list")))
  38
  39 ;;; This is used in constructing arg lists for debugger printing,
  40 ;;; and when needing to print unbound slots in PCL.
  41 (defstruct (unprintable-object
  42             (:constructor make-unprintable-object (string))
  43             (:print-object (lambda (x s)
  44                              (print-unreadable-object (x s)
  45                                (write-string (unprintable-object-string x) s))))
  46             (:copier nil))
  47   string)
  48
  49 ;;; Used internally, but it would be nice to provide something
  50 ;;; like this for users as well.
  51
  52 #!+sb-thread
  53 (defmacro define-structure-slot-addressor (name &key structure slot)
  54   (let* ((dd (find-defstruct-description structure t))
  55          (slotd (when dd (find slot (dd-slots dd) :key #'dsd-name)))
  56          (index (when slotd (dsd-index slotd))))
  57     (unless index
  58       (error "Slot ~S not found in ~S." slot structure))
  59     `(progn
  60        (declaim (inline ,name))
  61        (defun ,name (instance)
  62          (declare (type ,structure instance) (optimize speed))
  63          (sb!ext:truly-the
  64           sb!vm:word
  65           (+ (sb!kernel:get-lisp-obj-address instance)
  66              (- (* ,(+ sb!vm:instance-slots-offset index) sb!vm:n-word-bytes)
  67                 sb!vm:instance-pointer-lowtag)))))))
  68
  69 (defmacro compare-and-swap (place old new &environment env)
  70   "Atomically stores NEW in PLACE if OLD matches the current value of PLACE.
  71 Two values are considered to match if they are EQ. Returns the previous value
  72 of PLACE: if the returned value if EQ to OLD, the swap was carried out.
  73
  74 PLACE must be an accessor form whose CAR is one of the following:
  75
  76  CAR, CDR, FIRST, REST, SYMBOL-PLIST, SYMBOL-VALUE, SVREF
  77
  78 or the name of a DEFSTRUCT created accessor for a slot whose declared type is
  79 either FIXNUM or T. Results are unspecified if the slot has a declared type
  80 other then FIXNUM or T.
  81
  82 EXPERIMENTAL: Interface subject to change."
  83   (flet ((invalid-place ()
  84            (error "Invalid first argument to COMPARE-AND-SWAP: ~S" place)))
  85     (unless (consp place)
  86       (invalid-place))
  87   ;; FIXME: Not the nicest way to do this...
  88   (destructuring-bind (op &rest args) place
  89     (case op
  90       ((car first)
  91        `(%compare-and-swap-car (the cons ,@args) ,old ,new))
  92       ((cdr rest)
  93        `(%compare-and-swap-cdr (the cons ,@args) ,old ,new))
  94       (symbol-plist
  95        `(%compare-and-swap-symbol-plist (the symbol ,@args) ,old (the list ,new)))
  96       (symbol-value
  97        (destructuring-bind (name) args
  98          (flet ((slow (symbol)
  99                   (with-unique-names (n-symbol n-old n-new)
 100                     `(let ((,n-symbol ,symbol)
 101                            (,n-old ,old)
 102                            (,n-new ,new))
 103                        (declare (symbol ,n-symbol))
 104                        (about-to-modify-symbol-value ,n-symbol "compare-and-swap SYMBOL-VALUE of ~S" ,n-new)
 105                        (%compare-and-swap-symbol-value ,n-symbol ,n-old ,n-new)))))
 106            (if (sb!xc:constantp name env)
 107                (let ((cname (constant-form-value name env)))
 108                  (if (eq :special (info :variable :kind cname))
 109                      ;; Since we know the symbol is a special, we can just generate
 110                      ;; the type check.
 111                      `(%compare-and-swap-symbol-value
 112                        ',cname ,old (the ,(info :variable :type cname) ,new))
 113                      (slow (list 'quote cname))))
 114                (slow name)))))
 115       (svref
 116        (let ((vector (car args))
 117              (index (cadr args)))
 118          (unless (and vector index (not (cddr args)))
 119            (invalid-place))
 120          (with-unique-names (v)
 121            `(let ((,v ,vector))
 122               (declare (simple-vector ,v))
 123               (%compare-and-swap-svref ,v (%check-bound ,v (length ,v) ,index) ,old ,new)))))
 124       (t
 125        (let ((dd (info :function :structure-accessor op)))
 126          (if dd
 127              (let* ((structure (dd-name dd))
 128                     (slotd (find op (dd-slots dd) :key #'dsd-accessor-name))
 129                     (index (dsd-index slotd))
 130                     (type (dsd-type slotd)))
 131                (unless (eq t (dsd-raw-type slotd))
 132                  (error "Cannot use COMPARE-AND-SWAP with structure accessor for a typed slot: ~S"
 133                         place))
 134                (when (dsd-read-only slotd)
 135                  (error "Cannot use COMPARE-AND-SWAP with structure accessor for a read-only slot: ~S"
 136                         place))
 137                `(truly-the (values ,type &optional)
 138                            (%compare-and-swap-instance-ref (the ,structure ,@args)
 139                                                            ,index
 140                                                            (the ,type ,old) (the ,type ,new))))
 141              (error "Invalid first argument to COMPARE-AND-SWAP: ~S" place))))))))
 142
 143 (macrolet ((def (name lambda-list ref &optional set)
 144              #!+compare-and-swap-vops
 145              (declare (ignore ref set))
 146              `(defun ,name (,@lambda-list old new)
 147                 #!+compare-and-swap-vops
 148                 (,name ,@lambda-list old new)
 149                 #!-compare-and-swap-vops
 150                 (let ((current (,ref ,@lambda-list)))
 151                   (when (eq current old)
 152                     ,(if set
 153                          `(,set ,@lambda-list new)
 154                          `(setf (,ref ,@lambda-list) new)))
 155                   current))))
 156   (def %compare-and-swap-car (cons) car)
 157   (def %compare-and-swap-cdr (cons) cdr)
 158   (def %compare-and-swap-instance-ref (instance index) %instance-ref %instance-set)
 159   (def %compare-and-swap-symbol-plist (symbol) symbol-plist)
 160   (def %compare-and-swap-symbol-value (symbol) symbol-value)
 161   (def %compare-and-swap-svref (vector index) svref))
 162
 163 (defmacro atomic-incf (place &optional (diff 1) &environment env)
 164   #!+sb-doc
 165   "Atomically increments PLACE by DIFF, and returns the value of PLACE before
 166 the increment.
 167
 168 The incrementation is done using word-size modular arithmetic: on 32 bit
 169 platforms ATOMIC-INCF of #xFFFFFFFF by one results in #x0 being stored in
 170 PLACE.
 171
 172 PLACE must be an accessor form whose CAR is the name of a DEFSTRUCT accessor
 173 whose declared type is (UNSIGNED-BYTE 32) on 32 bit platforms,
 174 and (UNSIGNED-BYTE 64) on 64 bit platforms.
 175
 176 DIFF defaults to 1, and must be a (SIGNED-BYTE 32) on 32 bit platforms,
 177 and (SIGNED-BYTE 64) on 64 bit platforms.
 178
 179 EXPERIMENTAL: Interface subject to change."
 180   (flet ((invalid-place ()
 181            (error "Invalid first argument to ATOMIC-INCF: ~S" place)))
 182     (let ((place (macroexpand place env)))
 183       (unless (consp place)
 184         (invalid-place))
 185       (destructuring-bind (op &rest args) place
 186         (when (cdr args)
 187           (invalid-place))
 188         (let ((dd (info :function :structure-accessor op)))
 189           (if dd
 190               (let* ((structure (dd-name dd))
 191                      (slotd (find op (dd-slots dd) :key #'dsd-accessor-name))
 192                      (index (dsd-index slotd))
 193                      (type (dsd-type slotd)))
 194                 (declare (ignorable index))
 195                 (unless (and (eq 'sb!vm:word (dsd-raw-type slotd))
 196                              (type= (specifier-type type) (specifier-type 'sb!vm:word)))
 197                   (error "ATOMIC-INCF requires a slot of type (UNSIGNED-BYTE ~S), not ~S: ~S"
 198                          sb!vm:n-word-bits type place))
 199                 (when (dsd-read-only slotd)
 200                   (error "Cannot use ATOMIC-INCF with structure accessor for a read-only slot: ~S"
 201                          place))
 202                 #!+(or x86 x86-64)
 203                 `(truly-the sb!vm:word
 204                             (%raw-instance-atomic-incf/word (the ,structure ,@args)
 205                                                             ,index
 206                                                             (the sb!vm:signed-word ,diff)))
 207                 ;; No threads outside x86 and x86-64 for now, so this is easy...
 208                 #!-(or x86 x86-64)
 209                 (with-unique-names (structure old)
 210                   `(sb!sys:without-interrupts
 211                      (let* ((,structure ,@args)
 212                             (,old (,op ,structure)))
 213                        (setf (,op ,structure) (logand #.(1- (ash 1 sb!vm:n-word-bits))
 214                                                       (+ ,old (the sb!vm:signed-word ,diff))))
 215                        ,old))))
 216               (invalid-place)))))))
 217
 218 (defun call-hooks (kind hooks &key (on-error :error))
 219   (dolist (hook hooks)
 220     (handler-case
 221         (funcall hook)
 222       (serious-condition (c)
 223         (if (eq :warn on-error)
 224             (warn "Problem running ~A hook ~S:~%  ~A" kind hook c)
 225             (with-simple-restart (continue "Skip this ~A hook." kind)
 226               (error "Problem running ~A hook ~S:~%  ~A" kind hook c)))))))