path: root/drmaa/v1/low.scm

;;; 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)))