lite-backend.lisp

(defpackage #:petalisp.lite-backend
  (:use #:common-lisp
        #:petalisp.core)
  (:import-from #:petalisp.native-backend
                #:denv
                #:make-denv
                #:cenv
                #:make-cenv
                #:allocations
                #:schedule
                #:pointers
                #:constant-arrays
                #:constant-storage-vectors
                #:action-copy-invocations
                #:action-work-invocations
                #:invocation
                #:invocation-iteration-space
                #:invocation-kfn
                #:invocation-kernel
                #:invocation-targets
                #:invocation-sources
                #:+worker-allocation-category-offset+
                #:+constant-allocation-category+
                #:allocation-color
                #:array-storage-vector
                #:array-storage-pointer
                #:allocate-memory
                #:free-memory
                #:bind-result
                #:bind-argument
                #:get-result)
  (:export #:evaluate #:call-with-fast-evaluate))

(in-package #:petalisp.lite-backend)

(defvar *dummy-backend* (petalisp:make-native-backend :threads 1))

(defun evaluate (denv)
  (declare (denv denv))
  (labels ((invoke (invocations)
             (loop for invocation of-type invocation in invocations do
               ;; TODO
               (unless (shape-emptyp (invocation-iteration-space invocation))
                 (funcall (invocation-kfn invocation)
                          (invocation-kernel invocation)
                          (invocation-iteration-space invocation)
                          (invocation-targets invocation)
                          (invocation-sources invocation)
                          denv)))))
    (with-slots (cenv) denv
      (with-slots (schedule) cenv
        (loop for action-vector of-type simple-vector in schedule do
          (let ((action (aref action-vector 0)))
            (invoke (action-copy-invocations action))
            (invoke (action-work-invocations action))))))))

(defmacro with-timing ((label) &body body)
  (alexandria:with-gensyms (time)
    `(let ((,time (get-internal-real-time)))
       (write-string ,label)
       (multiple-value-prog1 (locally ,@body)
         (format t " done, ~fs~%"
                 (/ (float (- (get-internal-real-time) ,time) 1.0d0)
                    internal-time-units-per-second))))))

(defun call-with-evaluate (thunk denv)
  "Call THUNK with a DENV, which can be passed to `evaluate' during the dynamic
extent of this call to perform the computation represented by DENV."
  (declare (denv denv))
  (with-slots (cenv pointers) denv
    (with-slots (allocations schedule constant-arrays constant-storage-vectors) cenv
      ;; Pin and bind all constants.
      (petalisp.utilities:with-pinned-objects* constant-storage-vectors
        (loop for array across constant-arrays
              for allocation across (aref allocations +constant-allocation-category+)
              do (setf (aref (aref pointers +constant-allocation-category+)
                             (allocation-color allocation))
                       (array-storage-pointer array))))
      ;; Allocate memory.
      (let ((local-allocations (aref allocations +worker-allocation-category-offset+))
            (local-pointers (aref pointers +worker-allocation-category-offset+)))
        #+(or) ;; TODO
        (message "Allocating ~,2E bytes of memory."
                 (loop for allocation across local-allocations
                       sum (allocation-size-in-bytes allocation)))
        (loop for index below (length local-allocations) do
          (setf (aref local-pointers index)
                (allocate-memory (aref local-allocations index)))))
      (unwind-protect (with-timing ("computing...") (funcall thunk denv))
       ;; Free memory.
       (let ((local-allocations (aref allocations +worker-allocation-category-offset+))
             (local-pointers (aref pointers +worker-allocation-category-offset+)))
         (loop for index below (length local-allocations) do
           (setf (aref local-pointers index)
                 (free-memory
                  (aref local-allocations index)
                  (aref local-pointers index)))))))))

(defun call-with-fast-evaluate (thunk unknowns lazy-arrays arguments results)
  "Call THUNK with a denv, which represents the computation that bind ARGUMENTS to
UNKNOWNS, then compute LAZY-ARRAYS and store into RESULTS."
  (let* ((cenv (with-timing ("compiling...") (make-cenv *dummy-backend* unknowns lazy-arrays)))
         (denv (make-denv cenv)))
    (declare (cenv cenv) (denv denv))
    (petalisp.utilities:with-pinned-objects*
        (mapcar #'array-storage-vector (append results arguments))
      (loop for result in results for index from 0 do
        (bind-result denv result index))
      (loop for argument in arguments for index from 0 do
        (bind-argument denv argument index))
      (call-with-evaluate thunk denv))))

;;; Example:

#+nil (let* ((x (make-array nil :element-type 'double-float :initial-element 1.0d0))
             (y (make-array nil :element-type 'double-float :initial-element 2.0d0))
             (z (make-array nil :element-type 'double-float))
             (x1 (petalisp:make-unknown :element-type 'double-float))
             (y1 (petalisp:make-unknown :element-type 'double-float))
             (z1 (petalisp:lazy #'+ x1 y1)))
        (call-with-fast-evaluate
         (lambda (denv) (dotimes (_ 1000000) (evaluate denv)))
         (list x1 y1) (list z1) (list x y) (list z))
        z)
;; compiling... done, 0.319997s
;; computing... done, 0.174998s