From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Mark H Weaver Newsgroups: gmane.lisp.guile.devel Subject: Re: Concurrent MVars for Guile Date: Tue, 03 Sep 2013 07:55:03 -0400 Message-ID: <87r4d6yvag.fsf@tines.lan> References: <87fvtn1wv8.fsf@tines.lan> NNTP-Posting-Host: plane.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: ger.gmane.org 1378209352 2700 80.91.229.3 (3 Sep 2013 11:55:52 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Tue, 3 Sep 2013 11:55:52 +0000 (UTC) To: guile-devel@gnu.org Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Tue Sep 03 13:55:54 2013 Return-path: Envelope-to: guile-devel@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by plane.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1VGpD8-00077B-0D for guile-devel@m.gmane.org; Tue, 03 Sep 2013 13:55:54 +0200 Original-Received: from localhost ([::1]:44867 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1VGpD7-0003YV-KS for guile-devel@m.gmane.org; Tue, 03 Sep 2013 07:55:53 -0400 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:43770) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1VGpCw-0003YA-1B for guile-devel@gnu.org; Tue, 03 Sep 2013 07:55:49 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1VGpCl-0003IQ-ED for guile-devel@gnu.org; Tue, 03 Sep 2013 07:55:41 -0400 Original-Received: from world.peace.net ([96.39.62.75]:51324) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1VGpCl-0003H2-0m for guile-devel@gnu.org; Tue, 03 Sep 2013 07:55:31 -0400 Original-Received: from c-98-217-64-74.hsd1.ma.comcast.net ([98.217.64.74] helo=tines.lan) by world.peace.net with esmtpsa (TLS1.0:DHE_RSA_AES_128_CBC_SHA1:16) (Exim 4.72) (envelope-from ) id 1VGpCR-0001w1-Ny; Tue, 03 Sep 2013 07:55:12 -0400 In-Reply-To: <87fvtn1wv8.fsf@tines.lan> (Mark H. Weaver's message of "Mon, 02 Sep 2013 03:55:07 -0400") User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/24.3 (gnu/linux) X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.6.x X-Received-From: 96.39.62.75 X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.14 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Original-Sender: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.devel:16610 Archived-At: --=-=-= Content-Type: text/plain Hello all, I've attached an improved (but still preliminary) implementation of MVars for Guile. Apart from fixing some bugs, this version follows the Haskell API and semantics more closely. In particular, I now refrain from adding atomicity guarantees beyond those promised by the Haskell API. I also added locking to 'mvar-empty?', to ensure that we meet the "ordering" requirement of the Haskell API. Comments and suggestions welcome. Mark --=-=-= Content-Type: text/plain Content-Disposition: inline; filename=mvars.scm Content-Description: mvars for guile (preliminary) (define-module (ice-9 mvars) #:use-module (ice-9 threads) #:use-module (srfi srfi-8) ; receive #:use-module (srfi srfi-9) ; records #:use-module (srfi srfi-9 gnu) #:export (mvar? mvar-empty? new-empty-mvar new-mvar take-mvar put-mvar read-mvar swap-mvar try-take-mvar try-put-mvar with-mvar modify-mvar modify-mvar*)) (define-record-type (make-mvar contents empty? mutex full-condition empty-condition) mvar? (contents %mvar-contents %set-mvar-contents!) (empty? %mvar-empty? %set-mvar-empty?!) (mutex mvar-mutex) (full-condition mvar-full-condition) (empty-condition mvar-empty-condition)) (define (mvar-empty? mvar) (with-mutex (mvar-mutex mvar) (%mvar-empty? mvar))) (define (new-empty-mvar) "Return a freshly allocated mvar that is initially empty." (make-mvar #f ; contents #t ; empty? (make-mutex) (make-condition-variable) (make-condition-variable))) (define (new-mvar x) "Return a freshly allocated mvar with initial contents X." (make-mvar x ; contents #f ; empty? (make-mutex) (make-condition-variable) (make-condition-variable))) (define (take-mvar mvar) "Block until MVAR is full, then atomically remove and return its contents." (with-mutex (mvar-mutex mvar) (when (%mvar-empty? mvar) (wait-condition-variable (mvar-full-condition mvar) (mvar-mutex mvar))) (let ((x (%mvar-contents mvar))) (%set-mvar-contents! mvar #f) (%set-mvar-empty?! mvar #t) (signal-condition-variable (mvar-empty-condition mvar)) x))) (define (put-mvar mvar x) "Block until MVAR is empty, then put X into it." (with-mutex (mvar-mutex mvar) (unless (%mvar-empty? mvar) (wait-condition-variable (mvar-empty-condition mvar) (mvar-mutex mvar))) (%set-mvar-contents! mvar x) (%set-mvar-empty?! mvar #f) (signal-condition-variable (mvar-full-condition mvar)) *unspecified*)) (define (read-mvar mvar) "Take a value x from MVAR, then put it back and return x. This procedure is atomic only if there are no other producers for MVAR." (let ((x (take-mvar mvar))) (put-mvar mvar x) x)) (define (swap-mvar mvar y) "Take a value x from MVAR, then put Y into MVAR and return x. This procedure is atomic only if there are no other producers for MVAR." (let ((x (take-mvar mvar))) (put-mvar mvar y) x)) (define (try-take-mvar mvar) "If MVAR is full, return its contents and #t, else return #f and #f." (with-mutex (mvar-mutex mvar) (if (%mvar-empty? mvar) (values #f #f) (let ((x (%mvar-contents mvar))) (%set-mvar-contents! mvar #f) (%set-mvar-empty?! mvar #t) (signal-condition-variable (mvar-empty-condition mvar)) (values x #t))))) (define (try-put-mvar mvar x) "If MVAR is empty, put X into it and return #t, else return #f." (with-mutex (mvar-mutex mvar) (and (%mvar-empty? mvar) (begin (%set-mvar-contents! mvar x) (%set-mvar-empty?! mvar #f) (signal-condition-variable (mvar-full-condition mvar)) #t)))) (define (with-mvar mvar proc) "Take a value from MVAR and apply PROC to it. If an exception is raised, the original value is put back into MVAR. This procedure is atomic only if there are no other producers for MVAR." (let ((x (take-mvar mvar))) (catch #t (lambda () (proc x)) (lambda (key . args) (put-mvar mvar x) (apply throw key args))))) (define (modify-mvar mvar f) "Take a value x from MVAR, and then put back (F x). If an exception is raised, the original value is put back into MVAR. This procedure is atomic only if there are no other producers for MVAR." (let ((old (take-mvar mvar))) (catch #t (lambda () (put-mvar mvar (f old))) (lambda (key . args) (put-mvar mvar old) (apply throw key args))))) (define (modify-mvar* mvar f) "Take a value x from MVAR, and apply F to it. (F x) should return one or more values: the new value to be put back into MVAR, and zero or more additional values to be returned from MODIFY-MVAR*. If an exception is raised, the original value is put back into MVAR. This procedure is atomic only if there are no other producers for MVAR." (let ((old (take-mvar mvar))) (catch #t (lambda () (receive (new . results) (f old) (put-mvar mvar new) (apply values results))) (lambda (key . args) (put-mvar mvar old) (apply throw key args))))) (set-record-type-printer! (lambda (mvar port) (display "#string (object-address mvar) 16) port) (display " " port) (write (with-mutex (mvar-mutex mvar) (if (%mvar-empty? mvar) '() (list (%mvar-contents mvar)))) port) (display ">" port))) --=-=-=--