zilch/planner/src/step.sld

(define-library (zilch planner step)
 (import
  (scheme base) (scheme write) (scheme process-context) (scheme lazy) (scheme case-lambda)
  (chicken format)
  (srfi 128) (srfi 146))

 (export
  register-build-step

  empty-build-plan build-plan-print build-plan-tick
  build-plan-next-id

  build-plan-current-plan

  build-plan-append build-plan-tail-call build-plan-return-append)

 (begin
  (define-record-type <build-plan>
    (make-build-plan steps ready-to-run finalized last-id)
    build-plan?
    (steps build-plan-steps set-build-plan-steps!)
    (ready-to-run build-plan-ready-to-run set-build-plan-ready-to-run!)
    (finalized build-plan-finalized set-build-plan-finalized!)
    (last-id build-plan-last-id set-build-plan-last-id!))

  ;; Represents a single step in the build.
  ;; id is a monotonically increasing identifier.
  ;; dependencies is an alist of identifiers for other build steps to when they were added.
  (define-record-type <build-step>
    (make-build-step id dependencies type arguments called-from)
    build-step?
    (id build-step-id)
    (dependencies build-step-dependencies set-build-step-dependencies!)
    (type build-step-type)
    (arguments build-step-arguments set-build-step-arguments!)
    (called-from build-step-called-from))

  (define-record-type <build-step-type>
    (make-build-step-type proc name batch)
    build-step-type?
    (proc build-step-type-proc)
    (name build-step-type-name)
    (batch build-step-type-batch))
  
  ;; Returns a new empty build plan.
  (define (empty-build-plan)
    (make-build-plan (mapping (make-default-comparator)) '() (mapping (make-default-comparator)) 0))
  
  ;; Returns a monotonically-increasing identifier for this build plan.
  (define (build-plan-next-id plan)
    (define id (+ (build-plan-last-id plan) 1))
    (set-build-plan-last-id! plan id)
    id)

  ;; Appends a new step to the build plan, returning its ID.
  (define (build-plan-append plan type args dependencies)
    (define id (build-plan-next-id plan))
    (define new-step (make-build-step id dependencies type args #f))
    (set-build-plan-steps! plan (mapping-set! (build-plan-steps plan) id new-step))
    id)

  (define known-build-types (mapping (make-default-comparator)))
  
  ;; Register a build step type.
  ;; A build step type's procedure is called (proc args . dependency-outputs),
  ;;  and returns a single value, which is the result.
  ;; A batch build step is called as (proc (id args . dependency-outputs) (id args . dependency-outputs) ....)
  ;;  and returns an alist of (id . result).
  (define (register-build-step name is-batch proc)
    (set! known-build-types
     (mapping-set! known-build-types name
      (make-build-step-type proc name is-batch))))
  
  (define (build-plan-print plan)
    (printf "build plan! ~S steps to go, of which ~S ready to run (~S finalized)\n"
        (mapping-size (build-plan-steps plan))
        (length (build-plan-ready-to-run plan))
        (mapping-size (build-plan-finalized plan)))
  
    (mapping-for-each
     (lambda (step-id step)
      (define ready-to-run (member step (build-plan-ready-to-run plan)))
      (printf "- step ~S: ~S (ready to run? ~S)\n" step-id (build-step-type step) (not (eq? ready-to-run #f)))
      (printf "   arguments: \n")
      (for-each (lambda (arg) (printf "   - ~S\n" arg)) (build-step-arguments step))
      (printf "   dependencies: ~S\n\n" (build-step-dependencies step)))
     (build-plan-steps plan))
    (mapping-for-each
     (lambda (step-id res)
      (printf "- result ~S: ~S\n" step-id res))
     (build-plan-finalized plan))
    (printf "\n"))
  
  (define build-plan-current-plan-inner (make-parameter #f))
  (define build-plan-early-exit (make-parameter #f))
  
  ;; Returns a handle to the current build plan, if inside a build step.
  (define (build-plan-current-plan)
    (define plan (build-plan-current-plan-inner))
    (unless plan (error "cannot fetch current plan outside build plan context"))
    plan)
  
  ;; Tail call into a different build plan step. Arguments are similar to (build-plan-append).
  (define (build-plan-tail-call type args dependencies)
    (unless (build-plan-early-exit)
      (error "cannot build-plan-tail-call outside build plan context"))
    ((build-plan-early-exit) (list 'tail-call type args dependencies)))
  
  ;; Stops executing this build plan step, and appends dependencies.
  ;; If a second argument is given, the arguments to the current build step
  ;; are replaced wholesale.
  (define build-plan-return-append
   (case-lambda
    ((extra-dependencies new-args)
     (unless (build-plan-early-exit)
       (error "cannot build-plan-return-append outside build plan context"))
     ((build-plan-early-exit) (list 'append extra-dependencies new-args)))
    ((extra-dependencies) (build-plan-return-append extra-dependencies #f))))
  
  ;; Run all ready-to-run build steps, and mark any build steps newly runnable as such.
  (define (build-plan-tick plan)
    (define (collect-build-step-args step)
      (append (build-step-arguments step) (map (lambda (v) (mapping-ref (build-plan-finalized plan) v)) (build-step-dependencies step))))

    ;; Register the result of the build step and remove it from the list of pending steps.
    (define (handle-build-step-result step-id result)
      (set-build-plan-finalized! plan (mapping-set! (build-plan-finalized plan) step-id result))
      (set-build-plan-steps! plan (mapping-delete! (build-plan-steps plan) step-id)))

    ;; Collect all steps we can run now.
    ;; These are grouped by build step type, for batching reasons.
    (define ready-to-run (build-plan-ready-to-run plan))
    (set-build-plan-ready-to-run! plan '())
    (define run-groupings (mapping (make-default-comparator)))

    ;; Collect the type of steps we can run right now.
    (for-each
      (lambda (step)
        (set! run-groupings
          (mapping-update!/default
            run-groupings
            (build-step-type step)
            (lambda (prev) (cons step prev))
            '())))
      ready-to-run)
      
    (define (run-build-step step-type step)
      (define result
       (call-with-current-continuation
         (lambda (cc)
           (list 'result (parameterize ((build-plan-early-exit cc) (build-plan-current-plan-inner plan)) (apply (build-step-type-proc step-type) (collect-build-step-args step)))))))
      (case (car result)
       ((result) (handle-build-step-result (build-step-id step) (list-ref result 1)))
       ((tail-call)
        (set-build-plan-steps! plan
         (mapping-set! (build-plan-steps plan)
          (build-step-id step)
          (make-build-step (build-step-id step)
           (list-ref result 3)
           (list-ref result 1)
           (list-ref result 2)
           (cons (build-plan-next-id plan) step)))))
       ((append)
        (set-build-plan-steps! plan
         (mapping-set! (build-plan-steps plan)
          (build-step-id step)
          (make-build-step (build-step-id step)
           (append (build-step-dependencies step) (list-ref result 1))
           (build-step-type step)
           (or (list-ref result 2) (build-step-arguments step))
           (cons (build-plan-next-id plan) step)))))))

    ;; Run all build steps that are ready to run.
    (mapping-for-each
     (lambda (step-type-name steps)
      (define step-type (mapping-ref known-build-types step-type-name))
      (cond
        ((build-step-type-batch step-type)
         (parameterize
           ((build-plan-early-exit (lambda args (error "cannot early-exit from batch build step")))
            (build-plan-current-plan-inner plan))
           (for-each
             (lambda (result) (apply handle-build-step-result result))
             (apply (build-step-type-proc step-type) (map (lambda (a) (cons (build-step-id a) (collect-build-step-args a))) steps)))))
        (else
         (for-each
           (lambda (step) (run-build-step step-type step))
           steps))))
     run-groupings)

    ;; Mark any build step that is ready to run as such.
    (mapping-for-each
      (lambda (step-id step)
        (define finalized (do ((args (build-step-dependencies step) (cdr args))) ((or (null? args) (not (mapping-contains? (build-plan-finalized plan) (car args)))) (null? args))))
        (when finalized
          (set-build-plan-ready-to-run! plan (cons step (build-plan-ready-to-run plan)))))
      (build-plan-steps plan))

    (cond
      ((mapping-empty? (build-plan-steps plan))
       #t)
      ((and (null? ready-to-run) (null? (build-plan-ready-to-run plan)))
       (error "deadlock"))
      (else #f)))))