summaryrefslogtreecommitdiff
path: root/drmaa/v1/low.scm
diff options
context:
space:
mode:
Diffstat (limited to 'drmaa/v1/low.scm')
-rw-r--r--drmaa/v1/low.scm655
1 files changed, 655 insertions, 0 deletions
diff --git a/drmaa/v1/low.scm b/drmaa/v1/low.scm
new file mode 100644
index 0000000..76f0e73
--- /dev/null
+++ b/drmaa/v1/low.scm
@@ -0,0 +1,655 @@
+;;; Guile DRMAA --- Guile bindings for DRMAA
+;;; Copyright © 2020, 2021 Ricardo Wurmus <rekado@elephly.net>
+;;;
+;;; This file is part of Guile DRMAA.
+;;;
+;;; Guile DRMAA is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; Guile DRMAA is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Guile DRMAA. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (drmaa v1 low)
+ #:use-module (drmaa v1 ffi)
+ #:use-module (bytestructures guile)
+ #:use-module (system foreign)
+ #:use-module (system ffi-help-rt)
+ #:use-module (ice-9 match)
+ #:use-module (rnrs bytevectors)
+ #:use-module (rnrs enums)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
+ #:export (DRMAA
+
+ get-next-attr-name!
+ get-next-attr-value!
+ get-next-job-id!
+ get-num-attr-names
+ get-num-attr-values
+ get-num-job-ids
+ release-attr-names!
+ release-attr-values!
+ release-job-ids!
+
+ init-session!
+ exit-session!
+
+ allocate-job-template!
+ delete-job-template!
+ set-attribute!
+ get-attribute
+ set-vector-attribute!
+ get-vector-attribute
+ get-attribute-names
+ get-vector-attribute-names
+
+ run-job
+ run-bulk-jobs
+
+ control
+ job-ps
+ synchronize
+ wait
+
+ w-if-exited?
+ w-exit-status
+ w-if-signaled?
+ w-termsig
+ w-coredump?
+ w-if-aborted?
+
+ get-contact
+ drmaa-version
+ get-drm-system
+ get-drmaa-implementation))
+
+;; XXX: patch (drmaa v1 ffi) because it uses an undefined
+;; procedure. The generated code for drmaa_set_vector_attribute uses
+;; unwrap~array, which is not implemented in ffi-help-rt.
+;; (This may not be necessary for nyacc 1.03.1+.)
+(module-define! (resolve-module '(drmaa v1 ffi))
+ 'unwrap~array
+ (@@ (drmaa v1 ffi) unwrap~pointer))
+
+(define (make-cstr-array string-list)
+ "Return a bytevector containing pointers to each of the strings in
+STRING-LIST."
+ (let* ((n (length string-list))
+ (pointers (map string->pointer string-list))
+ (addresses (map pointer-address pointers))
+ (bv (make-bytevector (* (1+ n) (sizeof '*))))
+ (bv-set! (case (sizeof '*)
+ ((4) bytevector-u32-native-set!)
+ ((8) bytevector-u64-native-set!))))
+ (for-each (lambda (address index)
+ (bv-set! bv (* (sizeof '*) index) address))
+ addresses (iota n))
+ ;; The vector must be NULL-terminated
+ (bv-set! bv (1+ n) 0)
+ bv))
+
+(define-syntax-rule (return ret success error-message)
+ (cond
+ ((eq? ret (DRMAA 'ERRNO_SUCCESS)) success)
+ (else
+ (raise (condition
+ (&message
+ (message
+ (format #false "~a (~a)"
+ (char*->string error-message)
+ ret))))))))
+
+(define (DRMAA sym)
+ (or (drmaa-v1-ffi-symbol-val (symbol-append 'DRMAA_ sym))
+ (raise (condition
+ (&message
+ (message
+ (format #false "Unknown DRMAA symbol: ~a" sym)))))))
+
+
+;;; String vector helpers
+
+(define (get-next-attr-name! names)
+ (let* ((name
+ (make-char* (bytevector->pointer
+ (make-bytevector (DRMAA 'ATTR_BUFFER)))))
+ (ret (drmaa_get_next_attr_name
+ names name
+ (DRMAA 'ATTR_BUFFER))))
+ (and (eq? ret (DRMAA 'ERRNO_SUCCESS))
+ (char*->string name))))
+
+(define (get-next-attr-value! values)
+ (let* ((value
+ (make-char* (bytevector->pointer
+ (make-bytevector (DRMAA 'ATTR_BUFFER)))))
+ (ret (drmaa_get_next_attr_value
+ values value
+ (DRMAA 'ATTR_BUFFER))))
+ (and (eq? ret (DRMAA 'ERRNO_SUCCESS))
+ (char*->string value))))
+
+(define (get-next-job-id! values)
+ (let* ((value
+ (make-char* (bytevector->pointer
+ ;; TODO: Perhaps not correct to use JOBNAME_BUFFER here
+ (make-bytevector (DRMAA 'JOBNAME_BUFFER)))))
+ (ret (drmaa_get_next_job_id
+ values value
+ ;; TODO: Perhaps not correct to use JOBNAME_BUFFER here
+ (DRMAA 'JOBNAME_BUFFER))))
+ (and (eq? ret (DRMAA 'ERRNO_SUCCESS))
+ (char*->string value))))
+
+(define (get-num-attr-names values)
+ (let* ((size (make-size_t))
+ (ret (drmaa_get_num_attr_names
+ values (pointer-to size))))
+ (and (eq? ret (DRMAA 'ERRNO_SUCCESS))
+ (fh-object-ref size))))
+
+(define (get-num-attr-values values)
+ (let* ((size (make-size_t))
+ (ret (drmaa_get_num_attr_values
+ values (pointer-to size))))
+ (and (eq? ret (DRMAA 'ERRNO_SUCCESS))
+ (fh-object-ref size))))
+
+(define (get-num-job-ids values)
+ (let* ((size (make-size_t))
+ (ret (drmaa_get_num_job_ids
+ values (pointer-to size))))
+ (and (eq? ret (DRMAA 'ERRNO_SUCCESS))
+ (fh-object-ref size))))
+
+(define (release-attr-names! values)
+ (drmaa_release_attr_names values)
+ #true)
+
+(define (release-attr-values! values)
+ (drmaa_release_attr_values values)
+ #true)
+
+(define (release-job-ids! values)
+ (drmaa_release_job_ids values)
+ #true)
+
+(define (extract type)
+ (define next
+ (match type
+ ('job-id get-next-job-id!)
+ ('name get-next-attr-name!)
+ ('value get-next-attr-value!)))
+ (define release
+ (match type
+ ('job-id release-job-ids!)
+ ('name release-attr-names!)
+ ('value release-attr-values!)))
+ (lambda (values)
+ (let loop ((res '()))
+ (let ((item (next values)))
+ (if item
+ (loop (cons item res))
+ (begin
+ (release values)
+ (reverse res)))))))
+
+(define extract-job-ids
+ (extract 'job-id))
+(define extract-names
+ (extract 'name))
+(define extract-values
+ (extract 'value))
+
+
+;;; Session management
+
+(define* (init-session! #:optional contact)
+ "Initialize the DRMAA library and create a new DRMAA session. If
+the binary module provides only one DRMAA implementation, the string
+CONTACT need not be provided; in that case the default implementation
+will be used."
+ (let ((error-message
+ (make-char* (bytevector->pointer
+ (make-bytevector (DRMAA 'ERROR_STRING_BUFFER))))))
+ (return (drmaa_init (or contact %null-pointer)
+ error-message
+ (DRMAA 'ERROR_STRING_BUFFER))
+ #true
+ error-message)))
+
+(define (exit-session!)
+ "Terminate an existing DRMAA session. Queued and running jobs will
+not be affected by this."
+ (let ((error-message
+ (make-char* (bytevector->pointer
+ (make-bytevector (DRMAA 'ERROR_STRING_BUFFER))))))
+ (return (drmaa_exit error-message
+ (DRMAA 'ERROR_STRING_BUFFER))
+ #true
+ error-message)))
+
+
+;;; Job templates
+
+(define (allocate-job-template!)
+ (let ((template (make-drmaa_job_template_t*))
+ (error-message
+ (make-char* (bytevector->pointer
+ (make-bytevector (DRMAA 'ERROR_STRING_BUFFER))))))
+ (return (drmaa_allocate_job_template (pointer-to template)
+ error-message
+ (DRMAA 'ERROR_STRING_BUFFER))
+ template
+ error-message)))
+
+(define (delete-job-template! template)
+ ;; TODO: Call this in a finalizer.
+ (let ((error-message
+ (make-char* (bytevector->pointer
+ (make-bytevector (DRMAA 'ERROR_STRING_BUFFER))))))
+ (return (drmaa_delete_job_template template
+ error-message
+ (DRMAA 'ERROR_STRING_BUFFER))
+ #true
+ error-message)))
+
+(define (set-attribute! template name value)
+ (let ((error-message
+ (make-char* (bytevector->pointer
+ (make-bytevector (DRMAA 'ERROR_STRING_BUFFER))))))
+ (return (drmaa_set_attribute template
+ (string->pointer name) value
+ error-message
+ (DRMAA 'ERROR_STRING_BUFFER))
+ #true
+ error-message)))
+
+(define (get-attribute template name)
+ (let ((error-message
+ (make-char* (bytevector->pointer
+ (make-bytevector (DRMAA 'ERROR_STRING_BUFFER)))))
+ (value
+ (make-char* (bytevector->pointer
+ (make-bytevector (DRMAA 'ATTR_BUFFER))))))
+ (return (drmaa_get_attribute template
+ (string->pointer name)
+ value
+ (DRMAA 'ATTR_BUFFER)
+ error-message
+ (DRMAA 'ERROR_STRING_BUFFER))
+ (char*->string value)
+ error-message)))
+
+(define (set-vector-attribute! template name . values)
+ (let ((error-message
+ (make-char* (bytevector->pointer
+ (make-bytevector (DRMAA 'ERROR_STRING_BUFFER)))))
+ (array (make-cstr-array values)))
+ (return (drmaa_set_vector_attribute template
+ name
+ (bytevector->pointer array)
+ error-message
+ (DRMAA 'ERROR_STRING_BUFFER))
+ #true
+ error-message)))
+
+(define (get-vector-attribute template name)
+ (let ((error-message
+ (make-char* (bytevector->pointer
+ (make-bytevector (DRMAA 'ERROR_STRING_BUFFER)))))
+ (values (make-drmaa_attr_values_t*)))
+ (return (drmaa_get_vector_attribute template
+ name
+ (pointer-to values)
+ error-message
+ (DRMAA 'ERROR_STRING_BUFFER))
+ (extract-values values)
+ error-message)))
+
+(define (get-attribute-names)
+ (let ((error-message
+ (make-char* (bytevector->pointer
+ (make-bytevector (DRMAA 'ERROR_STRING_BUFFER)))))
+ (names (make-drmaa_attr_names_t*)))
+ (return (drmaa_get_attribute_names (pointer-to names)
+ error-message
+ (DRMAA 'ERROR_STRING_BUFFER))
+ (extract-names names)
+ error-message)))
+
+(define (get-vector-attribute-names)
+ (let ((error-message
+ (make-char* (bytevector->pointer
+ (make-bytevector (DRMAA 'ERROR_STRING_BUFFER)))))
+ (names (make-drmaa_attr_names_t*)))
+ (return (drmaa_get_vector_attribute_names (pointer-to names)
+ error-message
+ (DRMAA 'ERROR_STRING_BUFFER))
+ (extract-names names)
+ error-message)))
+
+
+;;; Job submission
+
+(define (run-job template)
+ (let ((error-message
+ (make-char* (bytevector->pointer
+ (make-bytevector (DRMAA 'ERROR_STRING_BUFFER)))))
+ (job-id
+ (make-char* (bytevector->pointer
+ ;; TODO: Perhaps not correct to use JOBNAME_BUFFER here
+ (make-bytevector (DRMAA 'JOBNAME_BUFFER))))))
+ (return (drmaa_run_job job-id
+ ;; TODO: Perhaps not correct to use JOBNAME_BUFFER here
+ (DRMAA 'JOBNAME_BUFFER)
+ template
+ error-message
+ (DRMAA 'ERROR_STRING_BUFFER))
+ (char*->string job-id)
+ error-message)))
+
+(define* (run-bulk-jobs template end
+ #:key
+ (start 1) (increment 1))
+ "Submit a set of parametric jobs, which can be run concurrently.
+The attributes defined in TEMPLATE are used for every job in the set.
+Each job is identical except for its index. The first job has an
+index equal to START; the next has an index equal to the sum of START
+and INCREMENT. END is the maximum value of the index, but the value
+of the last job's index may not be equal to END if the difference
+between START and END is not evenly divisible by INCREMENT.
+
+Return a list of job identifiers."
+ (unless (positive? start)
+ (raise (condition
+ (&message
+ (message "`start' must be greater than or equal to 1")))))
+ (unless (<= start end)
+ (raise (condition
+ (&message
+ (message "`start' must be less than or equal to `end'")))))
+ (let ((error-message
+ (make-char* (bytevector->pointer
+ (make-bytevector (DRMAA 'ERROR_STRING_BUFFER)))))
+ (job-ids (make-drmaa_job_ids_t*)))
+ (return (drmaa_run_bulk_jobs
+ (pointer-to job-ids)
+ template
+ start end increment
+ error-message
+ (DRMAA 'ERROR_STRING_BUFFER))
+ (extract-job-ids job-ids)
+ error-message)))
+
+
+;;; Job status and control
+
+(define (control job-id action)
+ "Enact the ACTION on the job identified by JOB-ID. The following
+symbols are considered valid actions: suspend, resume, hold, release,
+and terminate. If JOB-ID is the symbol *, all jobs submitted during
+the current session will be affected."
+ (unless (member action '(suspend resume hold release terminate))
+ (raise (condition
+ (&message
+ (message
+ (format #false "Invalid action: ~a" action))))))
+ (let ((error-message
+ (make-char* (bytevector->pointer
+ (make-bytevector (DRMAA 'ERROR_STRING_BUFFER)))))
+ (action
+ (DRMAA (symbol-append 'CONTROL_
+ (string->symbol
+ (string-upcase
+ (symbol->string action)))))))
+ (return (drmaa_control (match job-id
+ ('* (DRMAA 'JOB_IDS_SESSION_ALL))
+ (_ job-id))
+ action
+ error-message
+ (DRMAA 'ERROR_STRING_BUFFER))
+ #true
+ error-message)))
+
+(define (job-status->symbol status-code)
+ (cond
+ ((eq? status-code (DRMAA 'PS_FAILED))
+ 'failed)
+ ((eq? status-code (DRMAA 'PS_DONE))
+ 'done)
+ ((eq? status-code (DRMAA 'PS_USER_SYSTEM_SUSPENDED))
+ 'user-system-suspended)
+ ((eq? status-code (DRMAA 'PS_USER_SUSPENDED))
+ 'user-suspended)
+ ((eq? status-code (DRMAA 'PS_RUNNING))
+ 'running)
+ ((eq? status-code (DRMAA 'PS_USER_SYSTEM_ON_HOLD))
+ 'user-system-on-hold)
+ ((eq? status-code (DRMAA 'PS_USER_ON_HOLD))
+ 'user-on-hold)
+ ((eq? status-code (DRMAA 'PS_SYSTEM_ON_HOLD))
+ 'system-on-hold)
+ ((eq? status-code (DRMAA 'PS_QUEUED_ACTIVE))
+ 'queued-active)
+ ((eq? status-code (DRMAA 'PS_UNDETERMINED))
+ 'undetermined)
+ (else
+ (raise (condition
+ (&message
+ (message
+ (format #false "Unexpected status: ~a" status-code))))))))
+
+(define (job-ps job-id)
+ (let ((error-message
+ (make-char* (bytevector->pointer
+ (make-bytevector (DRMAA 'ERROR_STRING_BUFFER)))))
+ (status-code (make-uint8)))
+ (return (drmaa_job_ps job-id
+ (pointer-to status-code)
+ error-message
+ (DRMAA 'ERROR_STRING_BUFFER))
+ (job-status->symbol status-code)
+ error-message)))
+
+(define (synchronize job-ids timeout dispose?)
+ (let ((timeout
+ (or timeout (DRMAA 'TIMEOUT_WAIT_FOREVER)))
+ (job-ids (make-cstr-array job-ids))
+ (error-message
+ (make-char* (bytevector->pointer
+ (make-bytevector (DRMAA 'ERROR_STRING_BUFFER))))))
+ (return (drmaa_synchronize (bytevector->pointer job-ids)
+ timeout
+ (if dispose? 1 0)
+ error-message
+ (DRMAA 'ERROR_STRING_BUFFER))
+ #true error-message)))
+
+(define (wait job-id timeout)
+ (let ((timeout
+ (or timeout (DRMAA 'TIMEOUT_WAIT_FOREVER)))
+ (job-id-out
+ (make-char* (bytevector->pointer
+ ;; TODO: Perhaps not correct to use JOBNAME_BUFFER here
+ (make-bytevector (DRMAA 'JOBNAME_BUFFER)))))
+ (status-code (make-uint8))
+ (rusage (make-drmaa_attr_values_t*))
+ (error-message
+ (make-char* (bytevector->pointer
+ (make-bytevector (DRMAA 'ERROR_STRING_BUFFER))))))
+ (return (drmaa_wait (match job-id
+ ('* (DRMAA 'JOB_IDS_SESSION_ANY))
+ (_ job-id))
+ job-id-out
+ ;; TODO: Perhaps not correct to use JOBNAME_BUFFER here
+ (DRMAA 'JOBNAME_BUFFER)
+ (pointer-to status-code)
+ timeout
+ (pointer-to rusage)
+ error-message
+ (DRMAA 'ERROR_STRING_BUFFER))
+ (values job-id-out status-code (extract-values rusage))
+ error-message)))
+
+(define (w-if-exited? status-code)
+ (let ((exited (make-uint8))
+ (error-message
+ (make-char* (bytevector->pointer
+ (make-bytevector (DRMAA 'ERROR_STRING_BUFFER))))))
+ (return (drmaa_wifexited (pointer-to exited)
+ status-code
+ error-message
+ (DRMAA 'ERROR_STRING_BUFFER))
+ (positive? exited)
+ error-message)))
+
+(define (w-exit-status status-code)
+ (let ((exit-status (make-uint8))
+ (error-message
+ (make-char* (bytevector->pointer
+ (make-bytevector (DRMAA 'ERROR_STRING_BUFFER))))))
+ (return (drmaa_wexitstatus (pointer-to exit-status)
+ status-code
+ error-message
+ (DRMAA 'ERROR_STRING_BUFFER))
+ exit-status
+ error-message)))
+
+(define (w-if-signaled? status-code)
+ "Return #TRUE if the job was terminated because it received a signal."
+ (let ((signaled (make-uint8))
+ (error-message
+ (make-char* (bytevector->pointer
+ (make-bytevector (DRMAA 'ERROR_STRING_BUFFER))))))
+ (return (drmaa_wifsignaled (pointer-to signaled)
+ status-code
+ error-message
+ (DRMAA 'ERROR_STRING_BUFFER))
+ (positive? signaled)
+ error-message)))
+
+(define (w-termsig status-code)
+ "Return the name of the signal that terminated the job."
+ (let ((signal
+ (make-char* (bytevector->pointer
+ (make-bytevector (DRMAA 'SIGNAL_BUFFER)))))
+ (error-message
+ (make-char* (bytevector->pointer
+ (make-bytevector (DRMAA 'ERROR_STRING_BUFFER))))))
+ (return (drmaa_wtermsig signal
+ (DRMAA 'SIGNAL_BUFFER)
+ status-code
+ error-message
+ (DRMAA 'ERROR_STRING_BUFFER))
+ (char*->string signal)
+ error-message)))
+
+(define (w-coredump? status-code)
+ "Return #TRUE if the STATUS-CODE indicates that a core image of the
+terminated job was created."
+ (let ((core-dumped (make-uint8))
+ (error-message
+ (make-char* (bytevector->pointer
+ (make-bytevector (DRMAA 'ERROR_STRING_BUFFER))))))
+ (return (drmaa_wcoredump (pointer-to core-dumped)
+ status-code
+ error-message
+ (DRMAA 'ERROR_STRING_BUFFER))
+ (positive? core-dumped)
+ error-message)))
+
+(define (w-if-aborted? status-code)
+ "Return #TRUE if the STATUS-CODE indicates that the job ended before
+entering the running state."
+ (let ((aborted (make-uint8))
+ (error-message
+ (make-char* (bytevector->pointer
+ (make-bytevector (DRMAA 'ERROR_STRING_BUFFER))))))
+ (return (drmaa_wifaborted (pointer-to aborted)
+ status-code
+ error-message
+ (DRMAA 'ERROR_STRING_BUFFER))
+ (positive? aborted)
+ error-message)))
+
+
+;;; Auxilliary functions
+
+(define (get-contact)
+ "When called before INIT-SESSION! return a string containing a
+comma-delimited list of default DRMAA implementation contact strings,
+one per DRM implementation provided. If called after INIT-SESSION!
+return the contact string for the DRM system for which the library has
+been initialized."
+ (let ((contact
+ (make-char* (bytevector->pointer
+ (make-bytevector (DRMAA 'CONTACT_BUFFER)))))
+ (error-message
+ (make-char* (bytevector->pointer
+ (make-bytevector (DRMAA 'ERROR_STRING_BUFFER))))))
+ (return (drmaa_get_DRM_system contact
+ (DRMAA 'CONTACT_BUFFER)
+ error-message
+ (DRMAA 'ERROR_STRING_BUFFER))
+ (char*->string contact)
+ error-message)))
+
+(define (drmaa-version)
+ "Return as a pair the major and minor version of the DRMAA C binding
+specification implemented by the selected DRMAA implementation."
+ (let ((major (make-uint8))
+ (minor (make-uint8))
+ (error-message
+ (make-char* (bytevector->pointer
+ (make-bytevector (DRMAA 'ERROR_STRING_BUFFER))))))
+ (return (drmaa_version (pointer-to major)
+ (pointer-to minor)
+ error-message
+ (DRMAA 'ERROR_STRING_BUFFER))
+ (cons (fh-object-ref major)
+ (fh-object-ref minor))
+ error-message)))
+
+(define (get-drm-system)
+ "When called before INIT-SESSION! return a string containing a
+comma-delimited list of DRM system identifiers, one per DRM system
+implementation provided. If called after INIT-SESSION! return the
+selected DRM system."
+ (let ((drm-system
+ (make-char* (bytevector->pointer
+ (make-bytevector (DRMAA 'DRM_SYSTEM_BUFFER)))))
+ (error-message
+ (make-char* (bytevector->pointer
+ (make-bytevector (DRMAA 'ERROR_STRING_BUFFER))))))
+ (return (drmaa_get_DRM_system drm-system
+ (DRMAA 'DRM_SYSTEM_BUFFER)
+ error-message
+ (DRMAA 'ERROR_STRING_BUFFER))
+ (char*->string drm-system)
+ error-message)))
+
+(define (get-drmaa-implementation)
+ "When called before INIT-SESSION! return a string containing a
+comma-delimited list of DRMAA implementations, one per DRMAA
+implementation provided. If called after INIT-SESSION! return the
+selected DRMAA implementation."
+ (let ((drmaa-implementation
+ (make-char* (bytevector->pointer
+ (make-bytevector (DRMAA 'DRMAA_IMPL_BUFFER)))))
+ (error-message
+ (make-char* (bytevector->pointer
+ (make-bytevector (DRMAA 'ERROR_STRING_BUFFER))))))
+ (return (drmaa_get_DRMAA_implementation drmaa-implementation
+ (DRMAA 'DRMAA_IMPL_BUFFER)
+ error-message
+ (DRMAA 'ERROR_STRING_BUFFER))
+ (char*->string drmaa-implementation)
+ error-message)))
generated by cgit v1.2.3 (git 2.46.2) at 2024-11-23 08:18:56 +0000