Permalink
Browse files

New file: src/trivial-cas.lisp

  • Loading branch information...
adlai committed Oct 10, 2009
1 parent 601569b commit a4de41ffff84839113a0fa8bb596df3552d40570
Showing with 57 additions and 7 deletions.
  1. +2 −3 chanl.asd
  2. +1 −0 src/package.lisp
  3. +54 −0 src/trivial-cas.lisp
  4. +0 −4 src/utils.lisp
View
@@ -15,15 +15,14 @@
:components
((:module "src"
:serial t
- :components ((:file "package")
+ :components ((:file "trivial-cas")
+ (:file "package")
(:file "utils")
(:file "threads")
(:file "queues")
(:file "channels")
(:file "select")))))
-;;; ... And a few more!
-
(asdf:defsystem chanl.examples
:name "chanl examples"
:maintainer "Adlai Chandrasekhar"
View
@@ -9,6 +9,7 @@
(defpackage :chanl
(:use :common-lisp)
(:import-from :bordeaux-threads :*default-special-bindings*)
+ (:import-from :trivial-cas :compare-and-swap)
(:export
;; threads
#:current-thread #:thread-alive-p #:threadp
View
@@ -0,0 +1,54 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; indent-tabs-mode: nil -*-
+;;;;
+;;;; Copyright © 2009 Adlai Chandrasekhar
+;;;;
+;;;; Trivial Compare-and-Swap
+;;;;
+;;;; Sketches of a Concurrency Primitive
+;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defpackage :trivial-compare-and-swap
+ (:use :cl)
+ (:nicknames :trivial-cas)
+ #+ (and sbcl compare-and-swap-vops)
+ (:import-from :sb-ext :compare-and-swap)
+ #+ ccl
+ (:import-from :ccl :defx86lapfunction)
+ (:export #:compare-and-swap))
+
+(in-package :trivial-cas)
+
+#+ (and sbcl (not compare-and-swap-vops))
+(defmacro compare-and-swap (place old new)
+ (warn "COMPARE-AND-SWAP is not implemented atomically on this platform.")
+ `(sb-ext:compare-and-swap ,place ,old ,new))
+
+#+ (and ccl x86-64)
+(progn
+ (defmacro compare-and-swap (place old new)
+ (if (atom place)
+ (error 'type-error :datum place :expected-type 'cons)
+ (ecase (car place)
+ (car `(%compare-and-swap-car ,place ,old ,new))
+ (cdr `(%compare-and-swap-cdr ,place ,old ,new)))))
+
+ (defx86lapfunction %compare-and-swap-cdr ((cons arg_x) (old arg_y) (new arg_z))
+ (movq (% old) (% imm0))
+ (cmpxchgq (% new) (@ -3 (% cons)))
+ (jne @fail)
+ (movq (% old) (% arg_z))
+ (single-value-return)
+ @fail
+ (movq (@ -3 (% cons)) (% arg_z))
+ (single-value-return))
+
+ (defx86lapfunction %compare-and-swap-car ((cons arg_x) (old arg_y) (new arg_z))
+ (movq (% old) (% imm0))
+ (cmpxchgq (% new) (@ 5 (% cons)))
+ (jne @fail)
+ (movq (% old) (% arg_z))
+ (single-value-return)
+ @fail
+ (movq (@ 5 (% cons)) (% arg_z))
+ (single-value-return)))
View
@@ -71,7 +71,3 @@
(let ((,list.gstorevar ,gitem)
(,tail.gstorevar ,gitem))
,list.setter ,tail.setter))))))))
-
-(defmacro compare-and-swap (place old new)
- #+sbcl`(sb-ext:compare-and-swap ,place ,old ,new)
- #-sbcl`(error "CAS only works on SBCL right now, sorries."))

0 comments on commit a4de41f

Please sign in to comment.