Deadlock-free resource locking.
This commit is contained in:
mainzelm
parent
f456608175
commit
d30130ab03
|
|
@ -53,9 +53,10 @@
|
|||
;;; raising an error here won't work due to S48's
|
||||
;;; broken exception system
|
||||
(else (list err syscall fname)))))
|
||||
(with-cwd-aligned
|
||||
(with-umask-aligned
|
||||
(makeit fname)))
|
||||
(with-resources-aligned
|
||||
(list cwd-resource umask-resource)
|
||||
(lambda ()
|
||||
(makeit fname)))
|
||||
#f))))
|
||||
(if (list? result)
|
||||
(apply errno-error result)
|
||||
|
|
@ -114,5 +115,7 @@
|
|||
(and override?
|
||||
(y-or-n? (string-append "rename-file:" new-fname
|
||||
" already exists. Delete"))))
|
||||
(with-cwd-aligned
|
||||
(%rename-file old-fname new-fname)))))
|
||||
(with-resources-aligned
|
||||
(list cwd-resource)
|
||||
(lambda ()
|
||||
(%rename-file old-fname new-fname))))))
|
||||
|
|
|
|||
|
|
@ -341,12 +341,13 @@
|
|||
|
||||
|
||||
(define-interface scsh-process-state-interface
|
||||
(export umask
|
||||
(export with-resources-aligned
|
||||
|
||||
umask
|
||||
set-umask
|
||||
with-umask*
|
||||
(with-umask :syntax)
|
||||
with-umask-aligned*
|
||||
(with-umask-aligned :syntax)
|
||||
umask-resource
|
||||
|
||||
process-chdir
|
||||
process-cwd
|
||||
|
|
@ -354,8 +355,7 @@
|
|||
cwd
|
||||
with-cwd*
|
||||
(with-cwd :syntax)
|
||||
with-cwd-aligned*
|
||||
(with-cwd-aligned :syntax)
|
||||
cwd-resource
|
||||
|
||||
pid
|
||||
parent-pid
|
||||
|
|
@ -429,7 +429,8 @@
|
|||
(with-env :syntax)
|
||||
(with-total-env :syntax)
|
||||
add-before
|
||||
add-after))
|
||||
add-after
|
||||
environ-resource))
|
||||
|
||||
|
||||
(define-interface scsh-home-interface
|
||||
|
|
@ -590,9 +591,9 @@
|
|||
|
||||
|
||||
(define-interface scsh-utilities-interface
|
||||
(export del delete filter first first? nth
|
||||
fold fold-right
|
||||
any every
|
||||
(export del first? filter fold-right
|
||||
fold
|
||||
any every nth
|
||||
mapv mapv! vector-every? copy-vector initialize-vector vector-append
|
||||
vfold vfold-right
|
||||
check-arg conjoin disjoin negate compose reverse! call/cc
|
||||
|
|
@ -600,7 +601,8 @@
|
|||
deposit-bit-field
|
||||
real->exact-integer
|
||||
make-reinitializer
|
||||
run-as-long-as))
|
||||
run-as-long-as
|
||||
obtain-all-or-none))
|
||||
|
||||
(define-interface weak-tables-interface
|
||||
(export make-weak-table weak-table-set! weak-table-ref weak-table-walk
|
||||
|
|
|
|||
|
|
@ -35,7 +35,7 @@
|
|||
(define-structure scsh-utilities scsh-utilities-interface
|
||||
(open bitwise error-package loopholes let-opt scheme define-record-types
|
||||
records
|
||||
threads threads-internal placeholders)
|
||||
threads threads-internal placeholders locks srfi-1)
|
||||
(files utilities)
|
||||
; (optimize auto-integrate)
|
||||
)
|
||||
|
|
@ -333,7 +333,7 @@
|
|||
|
||||
(define-structure field-reader-package scsh-field-reader-interface
|
||||
(open receiving ; receive
|
||||
scsh-utilities ; nth
|
||||
scsh-utilities ; deprecated-proc
|
||||
error-package ; error
|
||||
string-lib ; string-join for obsolete join-strings
|
||||
scsh-level-0 ; delimited readers
|
||||
|
|
|
|||
374
scsh/scsh.scm
374
scsh/scsh.scm
|
|
@ -129,132 +129,228 @@
|
|||
(release-lock lock))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
||||
;;; A resource is a part of the process state for which every thread
|
||||
;;; has its own value
|
||||
;;; uses the procedures:
|
||||
;;; (process-read-resource (-> 'X))
|
||||
;;; (process-set-resource ('X -> unspec))
|
||||
;;; (resource-eq? ('X 'X -> bool))
|
||||
|
||||
;;; defines the procedures:
|
||||
;;; (initialize-resource (-> unspec)) ; call on startup
|
||||
;;; (with-resource* ((-> 'X) -> 'X))
|
||||
;;; (with-resource-aligned* ((-> 'X) -> 'X))
|
||||
;;; (thread-read-resource (-> 'X))
|
||||
;;; (thread-set-resource ('X -> unspec))
|
||||
|
||||
(define-syntax make-process-resource
|
||||
(syntax-rules
|
||||
()
|
||||
((make-process-resource
|
||||
initialize-resource
|
||||
thread-read-resource thread-set-resource! thread-change-resource
|
||||
with-resource* with-resource-aligned*
|
||||
process-read-resource process-set-resource resource-eq?)
|
||||
(begin
|
||||
(define *resource-cache* 'uninitialized)
|
||||
(define resource-lock 'uninitialized)
|
||||
|
||||
(define (initialize-resource)
|
||||
(set! *resource-cache* (process-read-resource))
|
||||
(set! $resource ;;; TODO The old thread-fluid will remain
|
||||
(make-preserved-thread-fluid
|
||||
(process-read-resource)))
|
||||
(set! resource-lock (make-lock)))
|
||||
|
||||
(define (cache-value)
|
||||
*resource-cache*)
|
||||
|
||||
;; Actually do the syscall and update the cache
|
||||
;; assumes the resource lock obtained
|
||||
(define (change-and-cache res)
|
||||
(process-set-resource res)
|
||||
(set! *resource-cache* (process-read-resource)))
|
||||
|
||||
;; The thread-specific resource: A thread fluid
|
||||
|
||||
(define $resource 'empty-resource-value)
|
||||
|
||||
(define (thread-read-resource) (thread-fluid $resource))
|
||||
(define (thread-set-resource! res) (set-thread-fluid! $resource res))
|
||||
(define (let-resource res thunk)
|
||||
(let-thread-fluid $resource res thunk))
|
||||
|
||||
(define (with-resource* res thunk)
|
||||
(let ((changed-res #f))
|
||||
(with-lock resource-lock
|
||||
(lambda ()
|
||||
(align-resource!)
|
||||
(change-and-cache res)
|
||||
(set! changed-res (cache-value))))
|
||||
(let-resource changed-res thunk)))
|
||||
|
||||
;; Align the value of the Unix resource with scsh's value.
|
||||
;; Since another thread could disalign, this call and
|
||||
;; any ensuring syscall that relies upon it should
|
||||
;; be "glued together" with the resource lock.
|
||||
|
||||
(define (align-resource!)
|
||||
(let ((res (thread-read-resource)))
|
||||
(if (not (resource-eq? res (cache-value)))
|
||||
(change-and-cache res))))
|
||||
|
||||
(define (thread-change-resource res)
|
||||
(with-lock resource-lock
|
||||
(lambda ()
|
||||
(align-resource!)
|
||||
(change-and-cache res)
|
||||
(thread-set-resource! (cache-value)))))
|
||||
|
||||
(define (with-resource-aligned* thunk)
|
||||
(obtain-lock resource-lock)
|
||||
(align-resource!)
|
||||
(with-handler
|
||||
(lambda (cond more)
|
||||
(release-lock resource-lock)
|
||||
(more))
|
||||
(lambda ()
|
||||
(let ((ret (thunk)))
|
||||
(release-lock resource-lock)
|
||||
ret))))
|
||||
|
||||
;; example syscall
|
||||
;; (define (exported-delete-file fname)
|
||||
;; (with-cwd-aligned (really-delete-file fname)))
|
||||
|
||||
(define resource-reinitializer
|
||||
(make-reinitializer (lambda () (warn "calling resumer") (initialize-resource))))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; working directory per thread
|
||||
(make-process-resource
|
||||
initialize-cwd cwd thread-set-cwd! chdir with-cwd* with-cwd-aligned*
|
||||
process-cwd process-chdir string=?)
|
||||
|
||||
(define *cwd-cache* 'uninitialized)
|
||||
(define cwd-lock (make-lock))
|
||||
|
||||
(define (initialize-cwd)
|
||||
(set! *cwd-cache* (process-cwd))
|
||||
(set! $cwd ;;; TODO The old thread-fluid will remain
|
||||
(make-preserved-thread-fluid
|
||||
(cwd-cache))))
|
||||
; (set! cwd-lock (make-lock)))
|
||||
|
||||
(define (cwd-cache)
|
||||
*cwd-cache*)
|
||||
|
||||
;; Actually do the syscall and update the cache
|
||||
;; assumes the cwd lock obtained
|
||||
(define (change-and-cache-cwd new-cwd)
|
||||
(if (not (file-name-absolute? new-cwd))
|
||||
(process-chdir (string-append (cwd) "/" new-cwd))
|
||||
(process-chdir new-cwd))
|
||||
(set! *cwd-cache* (process-cwd)))
|
||||
|
||||
;; The thread-specific cwd: A thread fluid
|
||||
|
||||
(define $cwd 'empty-cwd-value)
|
||||
|
||||
(define (cwd) (thread-fluid $cwd))
|
||||
(define (thread-set-cwd! cwd) (set-thread-fluid! $cwd cwd))
|
||||
(define (let-cwd cwd thunk)
|
||||
(let-thread-fluid $cwd cwd thunk))
|
||||
|
||||
(define (with-cwd* new-cwd thunk)
|
||||
(let ((changed-cwd
|
||||
(with-lock cwd-lock
|
||||
(lambda ()
|
||||
(change-and-cache-cwd new-cwd)
|
||||
(cwd-cache)))))
|
||||
(let-cwd changed-cwd thunk)))
|
||||
|
||||
;; Align the value of the Unix cwd with scsh's value.
|
||||
;; Since another thread could disalign, this call and
|
||||
;; any ensuring syscall that relies upon it should
|
||||
;; be "glued together" with the cwd lock.
|
||||
|
||||
(define (align-cwd!)
|
||||
(let ((thread-cwd (cwd)))
|
||||
(if (not (string=? thread-cwd (cwd-cache)))
|
||||
(change-and-cache-cwd thread-cwd))))
|
||||
|
||||
(define (chdir cwd)
|
||||
(with-lock cwd-lock
|
||||
(lambda ()
|
||||
(change-and-cache-cwd cwd)
|
||||
(thread-set-cwd! (cwd-cache)))))
|
||||
|
||||
(define-record-type resource :resource
|
||||
(make-resource align! lock)
|
||||
resource?
|
||||
(align! resource-align!)
|
||||
(lock resource-lock))
|
||||
|
||||
(define (with-resources-aligned resources thunk)
|
||||
(let ((locks (map resource-lock resources)))
|
||||
(apply obtain-all-or-none locks)
|
||||
(for-each
|
||||
(lambda (align!) (align!))
|
||||
(map resource-align! resources))
|
||||
(let ((val (with-handler
|
||||
(lambda (cond more)
|
||||
(for-each release-lock locks)
|
||||
(more))
|
||||
thunk)))
|
||||
(for-each release-lock locks)
|
||||
val)))
|
||||
|
||||
(define cwd-resource (make-resource align-cwd! cwd-lock))
|
||||
|
||||
;; example syscall
|
||||
;; (define (exported-delete-file fname)
|
||||
;; (with-cwd-aligned (really-delete-file fname)))
|
||||
|
||||
(define cwd-reinitializer
|
||||
(make-reinitializer (lambda () (warn "calling resumer") (initialize-cwd))))
|
||||
|
||||
|
||||
(initialize-cwd)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; umask per thread
|
||||
(define *umask-cache* 'uninitialized)
|
||||
(define umask-lock (make-lock))
|
||||
|
||||
(define (initialize-umask)
|
||||
(set! *umask-cache* (process-umask))
|
||||
(set! $umask ;;; TODO The old thread-fluid will remain
|
||||
(make-preserved-thread-fluid
|
||||
(umask-cache))))
|
||||
; (set! umask-lock (make-lock)))
|
||||
|
||||
(define (umask-cache)
|
||||
*umask-cache*)
|
||||
|
||||
;; Actually do the syscall and update the cache
|
||||
;; assumes the resource lock obtained
|
||||
(define (change-and-cache-umask new-umask)
|
||||
(set-process-umask new-umask)
|
||||
(set! *umask-cache* (process-umask)))
|
||||
|
||||
;; The thread-specific umask: A thread fluid
|
||||
|
||||
(define $umask 'empty-umask-value)
|
||||
|
||||
(define (umask) (thread-fluid $umask))
|
||||
(define (thread-set-umask! new-umask) (set-thread-fluid! $umask new-umask))
|
||||
(define (let-umask new-umask thunk)
|
||||
(let-thread-fluid $umask new-umask thunk))
|
||||
|
||||
(define (with-umask* new-umask thunk)
|
||||
(let ((changed-umask
|
||||
(with-lock umask-lock
|
||||
(lambda ()
|
||||
(change-and-cache-umask new-umask)
|
||||
(umask-cache)))))
|
||||
(let-umask changed-umask thunk)))
|
||||
|
||||
;; Align the value of the Unix umask with scsh's value.
|
||||
;; Since another thread could disalign, this call and
|
||||
;; any ensuring syscall that relies upon it should
|
||||
;; be "glued together" with the umask lock.
|
||||
|
||||
(define (align-umask!)
|
||||
(let ((thread-umask (umask)))
|
||||
(if (not (= thread-umask (umask-cache)))
|
||||
(change-and-cache-umask thread-umask))))
|
||||
|
||||
(define (set-umask new-umask)
|
||||
(with-lock umask-lock
|
||||
(lambda ()
|
||||
(change-and-cache-umask new-umask)
|
||||
(thread-set-umask! (umask-cache)))))
|
||||
|
||||
(define umask-resource (make-resource align-umask! umask-lock))
|
||||
|
||||
;; example syscall
|
||||
;; (define (exported-delete-file fname)
|
||||
;; (with-cwd-aligned (really-delete-file fname)))
|
||||
|
||||
(define umask-reinitializer
|
||||
(make-reinitializer (lambda () (warn "calling resumer") (initialize-umask))))
|
||||
|
||||
(make-process-resource
|
||||
initialize-umask umask thread-set-umask set-umask
|
||||
with-umask* with-umask-aligned*
|
||||
process-umask set-process-umask =)
|
||||
|
||||
(initialize-umask)
|
||||
|
||||
(set-with-fs-context-aligned*! ; ensure S48 is aligned too
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; ensure S48 is aligned too
|
||||
|
||||
(set-with-fs-context-aligned*!
|
||||
(lambda (thunk)
|
||||
(with-cwd-aligned*
|
||||
(lambda ()
|
||||
(with-umask-aligned*
|
||||
thunk)))))
|
||||
(with-resources-aligned (list cwd-resource umask-resource) thunk)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Environment per thread
|
||||
(define *env-cache* 'uninitialized)
|
||||
(define env-lock (make-lock))
|
||||
|
||||
(define (install-env)
|
||||
(set! *env-cache* (environ**-read))
|
||||
(set! $env ;;; TODO The old thread-fluid will remain
|
||||
(make-preserved-thread-fluid
|
||||
(env-cache))))
|
||||
; (set! env-lock (make-lock)))
|
||||
|
||||
(define (env-cache)
|
||||
*env-cache*)
|
||||
|
||||
;; Actually do the syscall and update the cache
|
||||
;; assumes the env lock obtained
|
||||
(define (change-and-cache-env env)
|
||||
(environ**-set env)
|
||||
(set! *env-cache* env))
|
||||
|
||||
;; The thread-specific env: A thread fluid
|
||||
|
||||
(define $env 'empty-env-value)
|
||||
|
||||
(define (thread-read-env) (thread-fluid $env))
|
||||
(define (thread-set-env! res) (set-thread-fluid! $env res))
|
||||
(define (let-env res thunk)
|
||||
(let-thread-fluid $env res thunk))
|
||||
|
||||
(define (really-with-env* env thunk)
|
||||
(with-lock env-lock
|
||||
(lambda ()
|
||||
(change-and-cache-env env)))
|
||||
(let-env env thunk))
|
||||
|
||||
;; Align the value of the Unix env with scsh's value.
|
||||
;; Since another thread could disalign, this call and
|
||||
;; any ensuring syscall that relies upon it should
|
||||
;; be "glued together" with the env lock.
|
||||
|
||||
(define (align-env!)
|
||||
(let ((res (thread-read-env)))
|
||||
(if (not (env=? res (env-cache)))
|
||||
(change-and-cache-env res))))
|
||||
|
||||
(define (thread-change-env res)
|
||||
(with-lock env-lock
|
||||
(lambda ()
|
||||
(change-and-cache-env res)
|
||||
(thread-set-env! (env-cache)))))
|
||||
|
||||
(define environ-resource (make-resource align-env! env-lock))
|
||||
|
||||
;; example syscall
|
||||
;; (define (exported-delete-file fname)
|
||||
;; (with-cwd-aligned (really-delete-file fname)))
|
||||
|
||||
(define env-reinitializer
|
||||
(make-reinitializer (lambda () (warn "calling resumer") (install-env))))
|
||||
|
||||
|
||||
(define-record env
|
||||
envvec
|
||||
|
|
@ -328,12 +424,8 @@
|
|||
(with-total-env* new-env thunk)))
|
||||
|
||||
(define (with-total-env* alist thunk)
|
||||
(with-env-internal* (make-env #f alist) thunk))
|
||||
(really-with-env* (make-env #f alist) thunk))
|
||||
|
||||
(make-process-resource install-env thread-read-env thread-set-env!
|
||||
useless-set-env
|
||||
with-env-internal* with-env-aligned*
|
||||
environ**-read environ**-set env=?)
|
||||
|
||||
;;; These two functions are obsoleted by the more general INFIX-SPLITTER and
|
||||
;;; JOIN-STRINGS functions. However, we keep SPLIT-COLON-LIST defined
|
||||
|
|
@ -418,12 +510,6 @@
|
|||
(define-simple-syntax (with-cwd dir . body)
|
||||
(with-cwd* dir (lambda () . body)))
|
||||
|
||||
(define-simple-syntax (with-cwd-aligned body ...)
|
||||
(with-cwd-aligned* (lambda () body ...)))
|
||||
|
||||
(define-simple-syntax (with-umask-aligned body ...)
|
||||
(with-umask-aligned* (lambda () body ...)))
|
||||
|
||||
(define-simple-syntax (with-umask mask . body)
|
||||
(with-umask* mask (lambda () . body)))
|
||||
|
||||
|
|
@ -487,7 +573,7 @@
|
|||
(let ((fname (format #f template (number->string i))))
|
||||
(receive retvals (with-errno-handler
|
||||
((errno data)
|
||||
((errno/exist) #f))
|
||||
((errno/exist errno/acces) #f))
|
||||
(maker fname))
|
||||
(if (car retvals) (apply values retvals)
|
||||
(loop (+ i 1)))))))))
|
||||
|
|
@ -855,13 +941,9 @@
|
|||
|
||||
(define (exec/env prog env . arglist)
|
||||
(flush-all-ports)
|
||||
(with-env-aligned*
|
||||
(with-resources-aligned (list environ-resource cwd-resource umask-resource)
|
||||
(lambda ()
|
||||
(with-cwd-aligned*
|
||||
(lambda ()
|
||||
(with-umask-aligned*
|
||||
(lambda ()
|
||||
(%exec prog (cons prog arglist) env))))))))
|
||||
(%exec prog (cons prog arglist) env))))
|
||||
|
||||
;(define (exec-path/env prog env . arglist)
|
||||
; (cond ((exec-path-search (stringify prog) (fluid exec-path-list)) =>
|
||||
|
|
@ -875,26 +957,23 @@
|
|||
|
||||
(define (exec-path/env prog env . arglist)
|
||||
(flush-all-ports)
|
||||
(with-env-aligned*
|
||||
(with-resources-aligned
|
||||
(list environ-resource cwd-resource umask-resource)
|
||||
(lambda ()
|
||||
(with-cwd-aligned*
|
||||
(lambda ()
|
||||
(with-umask-aligned*
|
||||
(lambda ()
|
||||
(let ((prog (stringify prog)))
|
||||
(if (string-index prog #\/)
|
||||
(let ((prog (stringify prog)))
|
||||
(if (string-index prog #\/)
|
||||
|
||||
;; Contains a slash -- no path search.
|
||||
(%exec prog (cons prog arglist) env)
|
||||
;; Contains a slash -- no path search.
|
||||
(%exec prog (cons prog arglist) env)
|
||||
|
||||
;; Try each directory in PATH-LIST.
|
||||
(let ((argv (list->vector (cons prog (map stringify arglist)))))
|
||||
(for-each (lambda (dir)
|
||||
(let ((binary (string-append dir "/" prog)))
|
||||
(%%exec binary argv env)))
|
||||
(thread-fluid exec-path-list)))))
|
||||
;; Try each directory in PATH-LIST.
|
||||
(let ((argv (list->vector (cons prog (map stringify arglist)))))
|
||||
(for-each (lambda (dir)
|
||||
(let ((binary (string-append dir "/" prog)))
|
||||
(%%exec binary argv env)))
|
||||
(thread-fluid exec-path-list)))))
|
||||
|
||||
(error "No executable found." prog arglist))))))))
|
||||
(error "No executable found." prog arglist))))
|
||||
|
||||
(define (exec-path prog . arglist)
|
||||
(apply exec-path/env prog #t arglist))
|
||||
|
|
@ -958,7 +1037,8 @@
|
|||
;; with-env-aligned is not neccessary here but it will
|
||||
;; create the environ object in the parent process which
|
||||
;; could reuse it on further forks
|
||||
(let ((pid (with-env-aligned*
|
||||
(let ((pid (with-resources-aligned
|
||||
(list environ-resource)
|
||||
%%fork)))
|
||||
(if (zero? pid)
|
||||
;; Child
|
||||
|
|
|
|||
|
|
@ -183,7 +183,8 @@
|
|||
;;; ports.
|
||||
|
||||
(define (generic-file-op thing fd-op fname-op)
|
||||
(if (string? thing) (with-cwd-aligned (fname-op thing))
|
||||
(if (string? thing)
|
||||
(with-resources-aligned (list cwd-resource) (lambda () (fname-op thing)))
|
||||
(call/fdes thing fd-op)))
|
||||
|
||||
|
||||
|
|
@ -340,7 +341,7 @@
|
|||
(import-os-error-syscall %delete-file (path) "scsh_unlink")
|
||||
|
||||
(define (delete-file path)
|
||||
(with-cwd-aligned (%delete-file path)))
|
||||
(with-resources-aligned (list cwd-resource) (lambda () (%delete-file path))))
|
||||
|
||||
(import-os-error-syscall %sync-file (fd) "scsh_fsync")
|
||||
|
||||
|
|
@ -382,8 +383,9 @@
|
|||
(import-os-error-syscall %open (path flags mode) "scsh_open")
|
||||
|
||||
(define (open-fdes path flags . maybe-mode) ; mode defaults to 0666
|
||||
(with-cwd-aligned
|
||||
(with-umask-aligned
|
||||
(with-resources-aligned
|
||||
(list cwd-resource umask-resource)
|
||||
(lambda ()
|
||||
(%open path flags (:optional maybe-mode #o666)))))
|
||||
|
||||
|
||||
|
|
@ -532,15 +534,17 @@
|
|||
(import-os-error-syscall %open-dir (dir-name) "open_dir")
|
||||
|
||||
(define (directory-files . args)
|
||||
(with-cwd-aligned
|
||||
(let-optionals args ((dir ".")
|
||||
(dotfiles? #f))
|
||||
(check-arg string? dir directory-files)
|
||||
(let* ((files (%open-dir (ensure-file-name-is-nondirectory dir)))
|
||||
(files-sorted ((structure-ref sort sort-list!) files filename<=)))
|
||||
(if dotfiles? files-sorted
|
||||
(filter (lambda (f) (not (dotfile? f)))
|
||||
files-sorted))))))
|
||||
(with-resources-aligned
|
||||
(list cwd-resource)
|
||||
(lambda ()
|
||||
(let-optionals args ((dir ".")
|
||||
(dotfiles? #f))
|
||||
(check-arg string? dir directory-files)
|
||||
(let* ((files (%open-dir (ensure-file-name-is-nondirectory dir)))
|
||||
(files-sorted ((structure-ref sort sort-list!) files filename<=)))
|
||||
(if dotfiles? files-sorted
|
||||
(filter (lambda (f) (not (dotfile? f)))
|
||||
files-sorted)))))))
|
||||
|
||||
(define (dotfile? f)
|
||||
(char=? (string-ref f 0) #\.))
|
||||
|
|
|
|||
|
|
@ -13,9 +13,6 @@
|
|||
'()))))
|
||||
(del lis)))
|
||||
|
||||
(define (delete pred lis)
|
||||
(filter (lambda (x) (not (pred x))) lis))
|
||||
|
||||
(define (index str c . maybe-start)
|
||||
(let ((start (max 0 (:optional maybe-start 0)))
|
||||
(len (string-length str)))
|
||||
|
|
@ -33,50 +30,6 @@
|
|||
(char=? c (string-ref str i)))
|
||||
(and (>= i 0) i)))))
|
||||
|
||||
;;; (f (f (f zero x1) x2) x3)
|
||||
;;; [Richard's does (f x3 (f x2 (f x1 zero)))
|
||||
(define (reduce f zero l)
|
||||
(letrec ((lp (lambda (val rest)
|
||||
(if (pair? rest) (lp (f val (car rest)) (cdr rest))
|
||||
val))))
|
||||
(lp zero l)))
|
||||
|
||||
(define (fold kons knil lis)
|
||||
(let lp ((lis lis) (ans knil))
|
||||
(if (pair? lis)
|
||||
(lp (cdr lis) (kons (car lis) ans))
|
||||
ans)))
|
||||
|
||||
(define (fold-right kons knil lis)
|
||||
(let recur ((lis lis))
|
||||
(if (pair? lis)
|
||||
(let ((head (car lis))) ; Won't need LIS after RECUR call.
|
||||
(kons head (recur (cdr lis))))
|
||||
knil)))
|
||||
|
||||
(define (filter pred list)
|
||||
(letrec ((filter (lambda (list)
|
||||
(if (pair? list)
|
||||
(let* ((head (car list))
|
||||
(tail (cdr list))
|
||||
(new-tail (filter tail)))
|
||||
(if (pred head)
|
||||
(if (eq? tail new-tail) list
|
||||
(cons head new-tail))
|
||||
new-tail))
|
||||
'()))))
|
||||
(filter list)))
|
||||
|
||||
(define (first pred list)
|
||||
(letrec ((lp (lambda (list)
|
||||
(and (pair? list)
|
||||
(let ((head (car list)))
|
||||
(if (pred head) head
|
||||
(lp (cdr list))))))))
|
||||
(lp list)))
|
||||
|
||||
(define any first)
|
||||
|
||||
;;; Returns the first true value produced by PRED, not the list element
|
||||
;;; that satisfied PRED.
|
||||
|
||||
|
|
@ -89,15 +42,6 @@
|
|||
|
||||
(define any? first?)
|
||||
|
||||
|
||||
(define (every pred list)
|
||||
(or (not (pair? list))
|
||||
(let lp ((head (car list)) (tail (cdr list)))
|
||||
(if (pair? tail)
|
||||
(and (pred head) (lp (car tail) (cdr tail)))
|
||||
(pred head))))) ; Tail-call the last PRED call.
|
||||
|
||||
|
||||
(define (every? pred list)
|
||||
(letrec ((lp (lambda (list)
|
||||
(or (not (pair? list))
|
||||
|
|
@ -291,6 +235,16 @@
|
|||
(kill-thread! thread)
|
||||
(make-ready thread))
|
||||
|
||||
|
||||
(define (obtain-all-or-none . locks)
|
||||
(let lp ((obtained '()) (needed locks))
|
||||
(if (not (null? needed))
|
||||
(let ((next (car needed)))
|
||||
(if (maybe-obtain-lock next)
|
||||
(lp (cons next obtained)
|
||||
(cdr needed))
|
||||
(begin
|
||||
(for-each release-lock obtained)
|
||||
(obtain-lock next)
|
||||
(lp (list next) (delete next locks eq?))))))))
|
||||
|
||||
|
||||
Loading…
Reference in New Issue