/[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.32 by rtoy, Sat Jan 23 15:24:16 2010 UTC revision 1.33 by rtoy, Fri Mar 19 15:19:00 2010 UTC
# Line 24  Line 24 
24  (use-package "UNIX")  (use-package "UNIX")
25  (use-package "KERNEL")  (use-package "KERNEL")
26    
27    (intl:textdomain "cmucl-x86-vm")
28    
29  (export '(fixup-code-object internal-error-arguments  (export '(fixup-code-object internal-error-arguments
30            sigcontext-program-counter sigcontext-register            sigcontext-program-counter sigcontext-register
31            sigcontext-float-register sigcontext-floating-point-modes            sigcontext-float-register sigcontext-floating-point-modes
# Line 53  Line 55 
55    
56  #-cross-compiler  #-cross-compiler
57  (defun machine-type ()  (defun machine-type ()
58    "Returns a string describing the type of the local machine."    _N"Returns a string describing the type of the local machine."
59    "X86")    "X86")
60    
61    
62  #-cross-compiler  #-cross-compiler
63  (defun machine-version ()  (defun machine-version ()
64    "Returns a string describing the version of the local machine."    _N"Returns a string describing the version of the local machine."
65    "X86")    "X86")
66    
67    
# Line 109  Line 111 
111              (ncode-words (kernel:code-header-ref code 1))              (ncode-words (kernel:code-header-ref code 1))
112              (code-end-addr (+ code-start-addr (* ncode-words 4))))              (code-end-addr (+ code-start-addr (* ncode-words 4))))
113         (unless (member kind '(:absolute :relative))         (unless (member kind '(:absolute :relative))
114           (error "Unknown code-object-fixup kind ~s." kind))           (error _"Unknown code-object-fixup kind ~s." kind))
115         (ecase kind         (ecase kind
116           (:absolute           (:absolute
117            ;; Word at sap + offset contains a value to be replaced by            ;; Word at sap + offset contains a value to be replaced by
# Line 316  Line 318 
318                value                value
319                (let ((value (system:alternate-get-global-address name)))                (let ((value (system:alternate-get-global-address name)))
320                  (when (zerop value)                  (when (zerop value)
321                    (error "Unknown foreign symbol: ~S" name))                    (error _"Unknown foreign symbol: ~S" name))
322                  value))))))                  value))))))
323    
324    
# Line 385  Line 387 
387  (defun %instance-set-conditional (object slot test-value new-value)  (defun %instance-set-conditional (object slot test-value new-value)
388    (declare (type instance object)    (declare (type instance object)
389             (type index slot))             (type index slot))
390    "Atomically compare object's slot value to test-value and if EQ store    _N"Atomically compare object's slot value to test-value and if EQ store
391     new-value in the slot. The original value of the slot is returned."     new-value in the slot. The original value of the slot is returned."
392    (%instance-set-conditional object slot test-value new-value))    (%instance-set-conditional object slot test-value new-value))
393    
394  (defun set-symbol-value-conditional (symbol test-value new-value)  (defun set-symbol-value-conditional (symbol test-value new-value)
395    (declare (type symbol symbol))    (declare (type symbol symbol))
396    "Atomically compare symbol's value to test-value and if EQ store    _N"Atomically compare symbol's value to test-value and if EQ store
397    new-value in symbol's value slot and return the original value."    new-value in symbol's value slot and return the original value."
398    (set-symbol-value-conditional symbol test-value new-value))    (set-symbol-value-conditional symbol test-value new-value))
399    
400  (defun rplaca-conditional (cons test-value new-value)  (defun rplaca-conditional (cons test-value new-value)
401    (declare (type cons cons))    (declare (type cons cons))
402    "Atomically compare the car of CONS to test-value and if EQ store    _N"Atomically compare the car of CONS to test-value and if EQ store
403    new-value its car and return the original value."    new-value its car and return the original value."
404    (rplaca-conditional cons test-value new-value))    (rplaca-conditional cons test-value new-value))
405    
406  (defun rplacd-conditional (cons test-value new-value)  (defun rplacd-conditional (cons test-value new-value)
407    (declare (type cons cons))    (declare (type cons cons))
408    "Atomically compare the cdr of CONS to test-value and if EQ store    _N"Atomically compare the cdr of CONS to test-value and if EQ store
409    new-value its cdr and return the original value."    new-value its cdr and return the original value."
410    (rplacd-conditional cons test-value new-value))    (rplacd-conditional cons test-value new-value))
411    
412  (defun data-vector-set-conditional (vector index test-value new-value)  (defun data-vector-set-conditional (vector index test-value new-value)
413    (declare (type simple-vector vector))    (declare (type simple-vector vector))
414    "Atomically compare an element of vector to test-value and if EQ store    _N"Atomically compare an element of vector to test-value and if EQ store
415    new-value the element and return the original value."    new-value the element and return the original value."
416    (data-vector-set-conditional vector index test-value new-value))    (data-vector-set-conditional vector index test-value new-value))
417    
418  (defmacro atomic-push-symbol-value (val symbol)  (defmacro atomic-push-symbol-value (val symbol)
419    "Thread safe push of val onto the list in the symbol global value."    _N"Thread safe push of val onto the list in the symbol global value."
420    (ext:once-only ((n-val val))    (ext:once-only ((n-val val))
421      (let ((new-list (gensym))      (let ((new-list (gensym))
422            (old-list (gensym)))            (old-list (gensym)))
# Line 428  Line 430 
430                (return ,new-list))))))))                (return ,new-list))))))))
431    
432  (defmacro atomic-pop-symbol-value (symbol)  (defmacro atomic-pop-symbol-value (symbol)
433    "Thread safe pop from the list in the symbol global value."    _N"Thread safe pop from the list in the symbol global value."
434    (let ((new-list (gensym))    (let ((new-list (gensym))
435          (old-list (gensym)))          (old-list (gensym)))
436      `(loop      `(loop
# Line 440  Line 442 
442            (return (car ,old-list)))))))            (return (car ,old-list)))))))
443    
444  (defmacro atomic-pusha (val cons)  (defmacro atomic-pusha (val cons)
445    "Thread safe push of val onto the list in the car of cons."    _N"Thread safe push of val onto the list in the car of cons."
446    (once-only ((n-val val)    (once-only ((n-val val)
447                (n-cons cons))                (n-cons cons))
448      (let ((new-list (gensym))      (let ((new-list (gensym))
# Line 454  Line 456 
456                (return ,new-list))))))))                (return ,new-list))))))))
457    
458  (defmacro atomic-pushd (val cons)  (defmacro atomic-pushd (val cons)
459    "Thread safe push of val onto the list in the cdr of cons."    _N"Thread safe push of val onto the list in the cdr of cons."
460    (once-only ((n-val val)    (once-only ((n-val val)
461                (n-cons cons))                (n-cons cons))
462      (let ((new-list (gensym))      (let ((new-list (gensym))
# Line 468  Line 470 
470                (return ,new-list))))))))                (return ,new-list))))))))
471    
472  (defmacro atomic-push-vector (val vect index)  (defmacro atomic-push-vector (val vect index)
473    "Thread safe push of val onto the list in the vector element."    _N"Thread safe push of val onto the list in the vector element."
474    (once-only ((n-val val)    (once-only ((n-val val)
475                (n-vect vect)                (n-vect vect)
476                (n-index index))                (n-index index))

Legend:
Removed from v.1.32  
changed lines
  Added in v.1.33

  ViewVC Help
Powered by ViewVC 1.1.5