#lang racket
;;; Racket Simulation Collection
;;; resource.rkt
;;; Copyright (c) 2004-2010 M. Douglas Williams
;;;
;;; This file is part of the Racket Simulation Collection.
;;;
;;; The Racket Simulation Collection is free software: you can redistribute it
;;; and/or modify it under the terms of the GNU Lesser General Public License as
;;; published by the Free Software Foundation, either version 3 of the License,
;;; or (at your option) any later version.
;;;
;;; The Racket Simulation Collection 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 Lesser
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public License
;;; along with the Racket Simulation Collection.  If not, see
;;; <http://www.gnu.org/licenses/>.
;;;
;;; -----------------------------------------------------------------------------
;;;
;;; This module implements resources.
;;;
;;; Version  Date      Description
;;; 0.1.0    10/16/04  Initial implementation of resources. (MDW)
;;; 0.1.1    06/06/05  Renamed resource slots to simplify references for data
;;;                    collection. (MDW)
;;; 1.0.0    02/22/06  Added reneging and priority. (MDW)
;;; 1.0.1    03/24/06  Changed with to when in request macro. (MDW)
;;; 3.0.0    06/24/08  Updated for V4.0. (MDW)
;;; 3.0.1    11/27/08  Converted to a module. (MDW)
;;; 4.0.0    08/15/10  Converted to Racket. (MDW)

(require (for-syntax syntax/parse)
         "environment.rkt"
         "control.rkt"
         "queue.rkt")

;;; (struct allocation (process
;;;                     units)
;;;   #:mutable)
;;;   process : process?
;;;   units : exact-positive-integer?
(struct allocation (process
                    units)
  #:mutable)

;;; (struct resource (units
;;;                   units-available
;;;                   units-allocated
;;;                   satisfied
;;;                   queue)
;;;   #:mutable)
;;;   units : exact-positive-integer?
;;;   units-available : exact-nonnegative-integer?
;;;   units-allocated : exact-nonnegative-integer?
;;;   satisfied : queue?
;;;   queue : queue?
(struct resource (units
                  units-available
                  units-allocated
                  satisfied
                  queue)
  #:mutable)

;;; (make-resource units) -> resource?
;;;   units : exact-positive-integer?
;;; (make-resource) -> resource?
;;; Create and return a resource with the specified number of units,
;;; or 1, if not specified.
(define (make-resource (units 1))
  (resource
   units                           ; units
   units                           ; units-available
   0                               ; units-allocated
   (make-queue)                    ; satisfied
   (make-queue)))                  ; queue

;;; (resource-process-allocation resource process) -> (or/c false/c allocation?)
;;;   resource : resource?
;;;   process : process?
;;; Returns the resource allocation for a process or #f if none.
(define (resource-process-allocation resource process)
  (let/ec exit
    (queue-for-each (resource-satisfied resource)
      (lambda (allocation)
        (when (eq? (allocation-process allocation) process)
          (exit allocation))))
    #f))

;;; (resource-process-queue resource process) -> (or/c false/c resource?)
;;;   resource : resource?
;;;   process : process?
;;; Returns the resource waiting for a process or #f if none.
(define (resource-process-queue resource process)
  (let/ec exit
    (queue-for-each (resource-queue resource)
      (lambda (allocation)
        (when (eq? (allocation-process allocation) process)
          (exit allocation))))
    #f))

;;; (resource-allocate resource units process) -> void?
;;;   resource : resource?
;;;   units : exact-positive-integer?
;;;   process : process?
;;; Allocate the specified number of units of the resource to the
;;; process.  If there is an existing allocation, the units are added
;;; to it; otherwise, a new allocation is created.
(define (resource-allocate resource units process)
  (let ((process-allocation (resource-process-allocation resource process)))
    (if process-allocation
        (set-allocation-units!
         process-allocation 
         (+ (allocation-units process-allocation) units))
        (queue-insert-last!
         (resource-satisfied resource)
         (allocation process units)))
    (set-resource-units-available!
     resource
     (- (resource-units-available resource) units))
    (set-resource-units-allocated!
     resource
     (+ (resource-units-allocated resource) units))))

;;; (resource-deallocate resource units process) -> void?
;;;   resource : resource?
;;;   units : exact-positive-integer?
;;;   process : process?
;;; Deallocate the specified number of units of the resource from the
;;; process.  If there is an existing allocation and not all of the
;;; units are deallocated, the units are subtracted from it; otherwise
;;; the allocation is removed.
(define (resource-deallocate resource units process)
  (let ((process-allocation (resource-process-allocation resource process)))
    (if (< units (allocation-units process-allocation))
        (set-allocation-units!
         process-allocation
         (- (allocation-units process-allocation) units))
        (queue-remove! (resource-satisfied resource)
                     process-allocation))
    (set-resource-units-available!
     resource
     (+ (resource-units-available resource) units))
    (set-resource-units-allocated!
     resource
     (- (resource-units-allocated resource) units))))

;;; (resource-request resource [units priority reneg]) -> void?
;;;   resource : resource?
;;;   units : exact-positive-integer? = 1
;;;   priority : real? = 0
;;;   reneg : any/c = #f
;;; Request, by a process, for the specified number of units of a
;;; resource.  If the request cannot be satisfied, the process is
;;; places on a waiting queue.
(define (resource-request resource (units 1) (priority -inf.0) (reneg #f))
  (let ((process (current-simulation-process)))
    ;; The request must be for a process
    (when (not process)
      (error 'resource-request
             "no current process"))
    (let ((process-allocation (resource-process-allocation resource process)))
      (when (and process-allocation
                 (> (+ (allocation-units process-allocation) units)
                    (resource-units resource)))
        (error 'resource-request
               "units requested for process exceeds units available")))
    ;; Process the request
    (if (> units (resource-units-available resource))
        ;; If insufficient units to satisfy the request,
        ;; then queue the request
        (begin
          (let/cc continuation
            (let ((new-allocation (allocation process units))
                  (event (process-event process)))
              ;; Update process event
              (set-event-function! event continuation)
              (set-event-arguments! event '())
              (when reneg
                (schedule-event event reneg))
              ;; Add to allocations-waiting
              (if (= priority -inf.0)
                  (queue-insert-last!
                   (resource-queue resource) new-allocation)
                  (queue-insert-priority!
                   (resource-queue resource) new-allocation priority))
              ((current-simulation-loop-next))))
          ;; Did we reneg or was the allocation fullfilled?
          (let ((process-queue (resource-process-queue resource process)))
            (if process-queue
                ;; This is a reneg
                (begin
                  (queue-remove! (resource-queue resource) process-queue)
                  #f)
                ;; Otherwise, the allocation has been fullfillef
                ;; The (potential) reneg has been removed (in
                ;; resource-relinquish).
                #t)))
        ;; Otherwise, satisfy the request
        (begin
          (resource-allocate resource units process)
          #t))))

;;; (resource-relinquish resource units) -> void?
;;;   resource : resource?
;;;   units : exact-positive-integer?
;;; (resource-relinquish resource) -> void?
;;;   resource : resource?
;;; Release the specified number of units of the resource.  If the
;;; number of units is not specified, then all of the units held by
;;; the process are released.
(define resource-relinquish
  (case-lambda
    ((resource units)
     (let ((process (current-simulation-process)))
       (when (not process)
         (error 'resource-relinquish
                "no current process"))
       (let ((process-allocation (resource-process-allocation resource process)))
         (when (not process-allocation)
           (error 'resource-relinquish
                  "attempt to release units when none are allocated"))
         (when (> units (allocation-units process-allocation))
           (error 'resource-relinquish
                  "attempt to relase more units than allocated"))
         ;; Deallocate the resource units
         (resource-deallocate resource units process)
         ;; Check for waiting allocations that might now be satisfied
         (when (not (queue-empty? (resource-queue resource)))
           (let ((highest (queue-cell-priority
                           (queue-first-cell
                            (resource-queue resource)))))
             (let/ec exit
               (queue-for-each-cell (resource-queue resource)
                                  (lambda (cell)
                                    (when (or (= (resource-units-available resource) 0)
                                              (and (queue-cell-priority cell)
                                                   (< (queue-cell-priority cell) highest)))
                                      (exit))
                                    (let ((allocation (queue-cell-item cell)))
                                      (when (<= (allocation-units allocation)
                                                (resource-units-available resource))
                                        (let ((process (allocation-process allocation)))
                                          ;; Remove the allocation from the waiting list
                                          (queue-remove-cell!
                                           (resource-queue resource)
                                           cell)
                                          ;; Allocate the resource units
                                          (resource-allocate
                                           resource (allocation-units allocation) process)
                                          ;; Remove the reneg event, if any
                                          (event-list-remove! (process-event process))
                                          ;; Schedule the process for execution now
                                          (schedule-event (process-event process) '#:now))))))))))
       (void)))
    ((resource)
     (let ((process (current-simulation-process)))
       (when (not process)
         (error 'resource-request
                "no current process"))
       (let ((process-allocation (resource-process-allocation resource process)))
         (when (not process-allocation)
           (error 'resource-request
                  "attempt to release units when none are allocated"))
         (resource-relinquish resource (allocation-units process-allocation)))))))

;;; Macro: request
(define-syntax (request stx)
  (define-splicing-syntax-class timing
    #:attributes (time)
    (pattern (~seq #:now) #:with time #''#:now)
    (pattern (~seq (~datum now)) #:with time #''#:now)
    (pattern (~seq #:at time:expr))
    (pattern (~seq ((~datum at) time:expr)))
    (pattern (~seq #:in delta:expr) #:with time #'(+ delta (current-simulation-time)))
    (pattern (~seq ((~datum in) delta:expr)) #:with time #'(+ delta (current-simulation-time)))
    (pattern (~seq #:when event:expr) #:with time #'event)
    (pattern (~seq ((~datum when) event:expr)) #:with time #'event)
    (pattern (~seq time:expr))
    (pattern (~seq) #:with time #'#f))
  (syntax-parse stx
    ((request resource:expr
              (~optional (~or (~seq #:units units:expr)
                              ((~seq #:units units:expr)))
                         #:defaults ((units #'1)))
              (~optional (~or (~seq #:priority priority:expr)
                              ((~seq (#:priority priority:expr))))
                         #:defaults ((priority #'-inf.0)))
              reneg:timing)
     #'(resource-request resource units priority reneg.time))))

;;; Macro: relinquish
(define-syntax (relinquish stx)
  (syntax-parse stx
   ((relinquish resource:expr
                (~or (~seq #:units units:expr)
                     (~seq (#:units units:expr))))
    #'(resource-relinquish resource units))
   ((relinquish resource:expr)
    #'(resource-relinquish resource))))

;;; Macro: with-resource
(define-syntax-rule (with-resource (resource . rest)
                      body ...)
  (begin
    (request resource . rest)
    body ...
    (relinquish resource)))

;;; Shortcuts to queue variables
(define (resource-queue-variable-n resource)
  (queue-variable-n (resource-queue resource)))

(define (resource-satisfied-variable-n resource)
  (queue-variable-n (resource-satisfied resource)))

;;; Module Contracts

(provide (all-defined-out))