diff options
Diffstat (limited to 'module/hnh/util')
-rw-r--r-- | module/hnh/util/atomic-queue.scm | 49 | ||||
-rw-r--r-- | module/hnh/util/atomic-stack.scm | 43 | ||||
-rw-r--r-- | module/hnh/util/atomic.scm | 11 | ||||
-rw-r--r-- | module/hnh/util/coverage.scm | 3 |
4 files changed, 105 insertions, 1 deletions
diff --git a/module/hnh/util/atomic-queue.scm b/module/hnh/util/atomic-queue.scm new file mode 100644 index 00000000..2ab0c2ef --- /dev/null +++ b/module/hnh/util/atomic-queue.scm @@ -0,0 +1,49 @@ +(define-module (hnh util atomic-queue) + :use-module (srfi srfi-18) ; Threading + :use-module (rnrs records syntactic) + :use-module (rnrs exceptions) + ;; :use-module (rnrs mutable-pair) + :use-module (hnh util atomic) + :use-module (hnh util type) + :use-module ((hnh util) :select (begin1)) + :export (atomic-queue + atomic-queue? + queue-peek queue->list + enqueue! dequeue!)) + + + +;;; Items are added at the back, and poped from the front + +(define-record-type (queue %atomic-queue atomic-queue?) + (fields front + (mutable back) + front-mutex back-mutex) + (sealed #t) + (opaque #t)) + +(define (atomic-queue) + (let ((p (list 'FRONT))) + (%atomic-queue p p (make-mutex) (make-mutex)))) + +(define (enqueue! value q) + (typecheck q atomic-queue?) + (with-mutex (queue-back-mutex q) + (set-cdr! (queue-back q) (list value)) + (queue-back-set! q (cdr (queue-back q))))) + +(define (queue-peek q) + (typecheck q atomic-queue?) + (cadr (queue-front q))) + +(define (dequeue! q) + (typecheck q atomic-queue?) + (with-mutex (queue-front-mutex q) + (guard (_ (else #f)) + (begin1 (queue-peek q) + (set-cdr! (queue-front q) + (cddr (queue-front q))))))) + +(define (queue->list q) + (typecheck q atomic-queue?) + (cdr (queue-front q))) diff --git a/module/hnh/util/atomic-stack.scm b/module/hnh/util/atomic-stack.scm new file mode 100644 index 00000000..6b17724d --- /dev/null +++ b/module/hnh/util/atomic-stack.scm @@ -0,0 +1,43 @@ +(define-module (hnh util atomic-stack) + :use-module (srfi srfi-18) ; Threading + :use-module (rnrs records syntactic) + :use-module (rnrs exceptions) + :use-module (hnh util atomic) + :use-module ((hnh util type) :select (typecheck)) + :use-module ((hnh util) :select (begin1)) + :export (atomic-stack + atomic-stack? + stack-peek stack->list + push! pop!)) + +(define-record-type (stack %atomic-stack atomic-stack?) + (fields (mutable contents) + mutex) + (sealed #t) + (opaque #t)) + +(define (atomic-stack) + (%atomic-stack '() (make-mutex))) + +(define (stack->list stack) + (stack-contents stack)) + +(define (push! value stack) + (typecheck stack atomic-stack?) + (with-mutex (stack-mutex stack) + (stack-contents-set! + stack + (cons value (stack-contents stack))))) + +(define (stack-peek stack) + (typecheck stack atomic-stack?) + (car (stack-contents stack))) + +(define (pop! stack) + (typecheck stack atomic-stack?) + (with-mutex (stack-mutex stack) + (guard (_ (else #f)) + (begin1 (stack-peek stack) + (stack-contents-set! + stack (cdr (stack-contents stack))))))) + diff --git a/module/hnh/util/atomic.scm b/module/hnh/util/atomic.scm new file mode 100644 index 00000000..1deba2c1 --- /dev/null +++ b/module/hnh/util/atomic.scm @@ -0,0 +1,11 @@ +(define-module (hnh util atomic) + :use-module (srfi srfi-18) + :export (with-mutex)) + +(define-syntax with-mutex + (syntax-rules () + ((_ mutex body ...) + (dynamic-wind + (lambda () (mutex-lock! mutex)) + (lambda () body ...) + (lambda () (mutex-unlock! mutex)))))) diff --git a/module/hnh/util/coverage.scm b/module/hnh/util/coverage.scm index 2517e81f..9b76411b 100644 --- a/module/hnh/util/coverage.scm +++ b/module/hnh/util/coverage.scm @@ -63,7 +63,7 @@ (fold (lambda (line state) (match (parse-coverage-line line) (('DA line hits) - (modify state (compose-lens car* lines) + (modify state (compose-lenses car* lines) (lambda (lines) (cons (cons line hits) lines)))) (('SF source) (set state car* filename source)) @@ -86,6 +86,7 @@ "Can only merge coverage data for the same file, got ~s and ~s" (list (filename a) (filename b)) #f)) + #; (unless (= (total-lines a) (total-lines b)) (scm-error 'misc-error "merge-coverage" "Mismatch between found lines. Is it really the same file? File: ~s, got ~s and ~s" |