/[cmucl]/src/code/x86-vm.lisp
ViewVC logotype

Diff of /src/code/x86-vm.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.14 by dtc, Sat Mar 21 08:12:06 1998 UTC revision 1.15 by dtc, Fri Mar 26 15:57:00 1999 UTC
# Line 13  Line 13 
13  ;;;  ;;;
14  ;;; This file contains the X86 specific runtime stuff.  ;;; This file contains the X86 specific runtime stuff.
15  ;;;  ;;;
16    ;;; Code movement fixups by Douglas T. Crosher, 1997.
17    ;;; Thread support by Douglas T. Crosher, 1999.
18    ;;;
19    
20  (in-package "X86")  (in-package "X86")
21  (use-package "SYSTEM")  (use-package "SYSTEM")
# Line 453  Line 456 
456  ;;; exits.  ;;; exits.
457  (defvar *alien-stack*)  (defvar *alien-stack*)
458    
 ;;;  
 (defun kernel::%instance-set-conditional (object slot test-value new-value)  
   (declare (type instance object)  
            (type index slot))  
   "Atomically compare object's slot value to test-value and if EQ store  
    new-value in the slot. The original value of the slot is returned."  
   (kernel::%instance-set-conditional object slot test-value new-value))  
   
459  ;;; Support for the MT19937 random number generator. The update  ;;; Support for the MT19937 random number generator. The update
460  ;;; function is implemented as an assembly routine. This definition is  ;;; function is implemented as an assembly routine. This definition is
461  ;;; transformed to a call to this routine allowing its use in byte  ;;; transformed to a call to this routine allowing its use in byte
# Line 469  Line 464 
464  (defun random-mt19937 (state)  (defun random-mt19937 (state)
465    (declare (type (simple-array (unsigned-byte 32) (627)) state))    (declare (type (simple-array (unsigned-byte 32) (627)) state))
466    (random-mt19937 state))    (random-mt19937 state))
467    
468    
469    ;;;; Useful definitions for writing thread safe code.
470    
471    (in-package "KERNEL")
472    
473    (export '(atomic-push-symbol-value atomic-pop-symbol-value
474              atomic-pusha atomic-pushd atomic-push-vector))
475    
476    (defun %instance-set-conditional (object slot test-value new-value)
477      (declare (type instance object)
478               (type index slot))
479      "Atomically compare object's slot value to test-value and if EQ store
480       new-value in the slot. The original value of the slot is returned."
481      (%instance-set-conditional object slot test-value new-value))
482    
483    (defun set-symbol-value-conditional (symbol test-value new-value)
484      (declare (type symbol symbol))
485      "Atomically compare symbol's value to test-value and if EQ store
486      new-value in symbol's value slot and return the original value."
487      (set-symbol-value-conditional symbol test-value new-value))
488    
489    (defun rplaca-conditional (cons test-value new-value)
490      (declare (type cons cons))
491      "Atomically compare the car of CONS to test-value and if EQ store
492      new-value its car and return the original value."
493      (rplaca-conditional cons test-value new-value))
494    
495    (defun rplacd-conditional (cons test-value new-value)
496      (declare (type cons cons))
497      "Atomically compare the cdr of CONS to test-value and if EQ store
498      new-value its cdr and return the original value."
499      (rplacd-conditional cons test-value new-value))
500    
501    (defun data-vector-set-conditional (vector index test-value new-value)
502      (declare (type simple-vector vector))
503      "Atomically compare an element of vector to test-value and if EQ store
504      new-value the element and return the original value."
505      (data-vector-set-conditional vector index test-value new-value))
506    
507    (defmacro atomic-push-symbol-value (val symbol)
508      "Thread safe push of val onto the list in the symbol global value."
509      (ext:once-only ((n-val val))
510        (let ((new-list (gensym))
511              (old-list (gensym)))
512          `(let ((,new-list (cons ,n-val nil)))
513             (loop
514              (let ((,old-list ,symbol))
515                (setf (cdr ,new-list) ,old-list)
516                (when (eq (set-symbol-value-conditional
517                           ',symbol ,old-list ,new-list)
518                          ,old-list)
519                  (return ,new-list))))))))
520    
521    (defmacro atomic-pop-symbol-value (symbol)
522      "Thread safe pop from the list in the symbol global value."
523      (let ((new-list (gensym))
524            (old-list (gensym)))
525        `(loop
526          (let* ((,old-list ,symbol)
527                 (,new-list (cdr ,old-list)))
528            (when (eq (set-symbol-value-conditional
529                       ',symbol ,old-list ,new-list)
530                      ,old-list)
531              (return (car ,old-list)))))))
532    
533    (defmacro atomic-pusha (val cons)
534      "Thread safe push of val onto the list in the car of cons."
535      (once-only ((n-val val)
536                  (n-cons cons))
537        (let ((new-list (gensym))
538              (old-list (gensym)))
539          `(let ((,new-list (cons ,n-val nil)))
540             (loop
541              (let ((,old-list (car ,n-cons)))
542                (setf (cdr ,new-list) ,old-list)
543                (when (eq (rplaca-conditional ,n-cons ,old-list ,new-list)
544                          ,old-list)
545                  (return ,new-list))))))))
546    
547    (defmacro atomic-pushd (val cons)
548      "Thread safe push of val onto the list in the cdr of cons."
549      (once-only ((n-val val)
550                  (n-cons cons))
551        (let ((new-list (gensym))
552              (old-list (gensym)))
553          `(let ((,new-list (cons ,n-val nil)))
554             (loop
555              (let ((,old-list (cdr ,n-cons)))
556                (setf (cdr ,new-list) ,old-list)
557                (when (eq (rplacd-conditional ,n-cons ,old-list ,new-list)
558                          ,old-list)
559                  (return ,new-list))))))))
560    
561    (defmacro atomic-push-vector (val vect index)
562      "Thread safe push of val onto the list in the vector element."
563      (once-only ((n-val val)
564                  (n-vect vect)
565                  (n-index index))
566        (let ((new-list (gensym))
567              (old-list (gensym)))
568          `(let ((,new-list (cons ,n-val nil)))
569             (loop
570              (let ((,old-list (svref ,n-vect ,n-index)))
571                (setf (cdr ,new-list) ,old-list)
572                (when (eq (data-vector-set-conditional
573                           ,n-vect ,n-index ,old-list ,new-list)
574                          ,old-list)
575                  (return ,new-list))))))))

Legend:
Removed from v.1.14  
changed lines
  Added in v.1.15

  ViewVC Help
Powered by ViewVC 1.1.5