;;; -*- mode:lisp; package:user; base:10.; fonts: cptfontb -*- ;;; $Header: /ct/interp/queue.l,v 1.18 84/08/16 10:24:42 penny Exp $ ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; QUEUE ;;; ;;; James R. Miller May 13, 1983 ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; This file is part of a proprietary software project. Source ;;; ;;; code and documentation describing implementation details are ;;; ;;; available on a confidential, non-disclosure basis only. These ;;; ;;; materials, including this file in particular, are trade secrets ;;; ;;; of Computer * Thought Corporation. ;;; ;;; ;;; ;;; Edit: Add NUMBER_OF_RUNNABLE_TASKS variables and methods: ;;; ;;; JRM, 5-16-83 ;;; ;;; ;;; ;;; (c) Copyright 1982 and 1983, Computer * Thought Corporation. ;;; ;;; All Rights Reserved. ;;; ;;; ;;; ;;; Reference materials: ;;; ;;; Foderaro and Sklower, The FRANZ LISP Manual, September 1981. ;;; ;;; Weinreb and Moon, LISP MACHINE MANUAL, Symbolics, July 1981. ;;; ;;; Charniak et al., 1980. Artificial Intelligence Programming. ;;; ;;; Miller, 1982. The C*T Ada Tutor: Guide to the Implementation. ;;; ;;; The following code assumes familiarity with these materials. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Ensure presence of needed files. (comment Assumes ct_load and some suitable file_map are present) (eval-when (compile load eval) (ct_load 'charmac)) ;CT char set extensions. (eval-when (compile load eval) (ct_load 'aip)) ;AIP macros pkg. (eval-when (compile load eval) (ct_load 'compat)) ;Franz/LM compat pkg. (eval-when (compile load eval) (ct_load 'ctflav)) ;flavor pkg #+franz (eval-when (compile load eval) (ct_load 'loop)) ;Loop macro ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Compiler Declarations and Global Variables -- #+franz (declare (macros t) (localf delete_inferior_link find_runnable_task set_superior_and_inferior_links)) (declare (special *total_number_of_runnable_tasks*)) ;;;Queues: ;;;QUEUE: ********************************************************************** ;;;A queue of elements of flavor QUEUE_ELEMENTS_TYPE. QUEUE contains a ;;;pointer to its FIRST_ELEMENT. (ct_defflavor queue ((first_element nil) (queue_element_type 'basic_queue_element)) () :gettable-instance-variables :settable-instance-variables :initable-instance-variables) ;;;TASK_PRIORITY_QUEUE_MIXIN: *************************************************** ;;;Converts an ordinary QUEUE to a TASK PRIORITY QUEUE: adds an instance variable ;;;to hold the priority of the tasks in this queue and a pointer to the most ;;;recent task in this queue to be executed. The instantiable flavor ;;;TASK PRIORITY QUEUE is also defined. ;;;JRM fix note -- the multiple inheritance of a task priority queue as a ;;;queue with queue element properties has been done away with. ;;;the last four instance variables are those to be ;;;quasi-inherited from BASIC_QUEUE_ELEMENT, and are specified with TPQ ;;;prefixes. (ct_defflavor task_priority_queue_mixin ((priority nil) (number_of_runnable_tasks 0) (number_of_delayed_tasks 0) (most_recently_executed_task nil) (queue_element_type 'task_queue_element) (tpq_myqueue) ;The QUEUE to which this element belongs (tpq_previous_element) ;The element before this one (tpq_next_element) ;The element after this one (tpq_value) ;This element's value (tpq_name)) () (:included-flavors queue) :gettable-instance-variables :settable-instance-variables :initable-instance-variables) (ct_defflavor task_priority_queue () (task_priority_queue_mixin) :gettable-instance-variables :settable-instance-variables :initable-instance-variables) ;;;SET_MOST_RECENTLY_EXECUTED_TASK method for Penny -- these can probably go ;;;away once everyone is using GET-IV and SET-IV (ct_defmethod (task_priority_queue set_most_recently_executed_task) (val) (setq most_recently_executed_task val)) ;;;QUEUE_OF_PRIORITY_QUEUES: ***************************************************** ;;;A queue of TASK PRIORITY QUEUES; methods will be responsible for adding new ;;;tasks to and finding executable tasks in these priority queues. (ct_defflavor queue_of_priority_queues_mixin ((queue_element_type 'task_priority_queue) (most_recently_executed_task)) () (:included-flavors queue) :gettable-instance-variables :settable-instance-variables :initable-instance-variables) (ct_defflavor queue_of_priority_queues () (queue_of_priority_queues_mixin queue) :gettable-instance-variables :settable-instance-variables :initable-instance-variables) ;;;SET_MOST_RECENTLY_EXECUTED_TASK method for Penny -- these can probably go ;;;away once everyone is using GET-IV and SET-IV (ct_defmethod (queue_of_priority_queues set_most_recently_executed_task) (val) (setq most_recently_executed_task val)) ;;;Queue elements: ;;;BASIC_QUEUE_ELEMENT: ******************************************************** ;;;A doubly-linked entry in a QUEUE with an externally accessible NAME and VALUE. (ct_defflavor basic_queue_element ((myqueue) ;The QUEUE to which this element belongs (previous_element) ;The element before this one (next_element) ;The element after this one (value) ;This element's value (task_object) (name)) ;This element's (gensymed) name: this () ; element has been setq-ed to this :gettable-instance-variables ; symbol. :settable-instance-variables :initable-instance-variables) ;;;TASK_QUEUE_ELEMENT_MIXIN: *************************************************** ;;;Converts a QUEUE_ELEMENT to a task_queue element: adds instance variables for ;;;RUNNABLE_P, SUPERIOR_TASK and INFERIOR_TASK, and methods for setting and ;;;clearing the RUNNABLE_P flag. The values of these flavors are destined to ;;;be activation records. TASK_QUEUE_ELEMENT is the instantiable flavor of the ;;;mixture of QUEUE_ELEMENT and TASK_QUEUE_ELEMENT_MIXIN. (ct_defflavor task_queue_element_mixin ((runnable_p nil) (superior_task) (terminated t) (restart_time) (waiting_for_delay_to_timeout) (waiting_for_inferiors_to_finish) (inferior_tasks nil) (following_self nil));remembers if we are following a node to itself () (:included-flavors basic_queue_element) :gettable-instance-variables :settable-instance-variables :initable-instance-variables) ;;;Add this new mixin for tasks so that the debugger may associate instance variables ;;;with a task. -- wab (ct_defflavor task_queue_element_debugger_mixin ((diana_used_stack nil);Stack of diana nodes in execution (diana_free_stack nil));Free stack elements () (:included-flavors basic_queue_element) :gettable-instance-variables :settable-instance-variables :initable-instance-variables) (ct_defflavor task_queue_element () (task_queue_element_mixin task_queue_element_debugger_mixin) ;;jrm fix;;wab fix :gettable-instance-variables :settable-instance-variables :initable-instance-variables) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Externally Call-able Functions/Macros -- ;;;QUEUE: ********************************************************************* ;;;(QUEUE ADD_TO_QUEUE): ******************************************************* ;;;Add an element to a queue. A new queue element of type QUEUE_ELEMENT_TYPE ;;;(see the definition of QUEUE) is instantiated, given the specified value, and ;;;inserted into the queue after POSITION (which defaults to the queue's ;;;FIRST_POSITION). If POSITION is unspecified, insert the element at the end ;;;of the queue (i.e., before the first element). Returns the inserted element. ;;;4/2/84: A third, optional, argument has been added: QUEUE_ELEMENT_NAME. ;;;If this is non-nil, it is used as the element's NAME instead of the ;;;GENSYM'ed name based on QUEUE_ELEMENT_TYPE. (ct_defmethod (queue add_to_queue) (val position &optional (queue_element_name nil)) ;;Franz problems: didn't like direct reference to FIRST_ELEMENT when ;;embedded in an optional POSITION argument. Check these out some more!? (cond ((null position) (cond (first_element (setq position (get-iv task_queue_element first_element previous_element)))))) (let ((new_element nil) (add_after nil) (next_elem nil) (get_previous_element_method) (get_next_element_method) (set_previous_element_method) (set_next_element_method)) ;;If QUEUE_ELEMENT_NAME was not provided in the call, cons up a name ;;from QUEUE_ELEMENT_TYPE and GENSYM. Otherwise, use what was given. (cond ((null queue_element_name) (setq queue_element_name (concat queue_element_type '_ (gensym 'q))))) ;;NEW_ELEMENT is a partially defined element of flavor ;;QUEUE_ELEMENT_TYPE. ;; ;;***********UGLY CONDITIONALIZING!!! -- JRM, 12/5/83************* ;; ;;What is ugly is that the absence of multiple inheritence in franz ;;compiled flavors requires that we check the type of element before ;;generating the instance, so we know what names to use for MYQUEUE, ;;NAME, and VALUE. This is TOTALLY ad hoc to the TASK_PRIORITY_QUEUE ;;stuff needed for the interpreter's queue package; if this code will ;;never run in Franz, it should probably be repaired. (setq new_element (cond ((eq queue_element_type 'task_priority_queue) (ct_make_instance queue_element_type 'tpq_myqueue self 'tpq_name queue_element_name 'tpq_value val)) (t (ct_make_instance queue_element_type 'myqueue self 'name queue_element_name 'value val)))) ;;Figure out the right methods for prev_element and next_element, based ;;on the type of SELF. (cond ((eq queue_element_type 'task_priority_queue) (setq get_previous_element_method #+lispm ':tpq_previous_element #+franz 'tpq_previous_element get_next_element_method #+lispm ':tpq_next_element #+franz 'tpq_next_element set_previous_element_method #+lispm ':set-tpq_previous_element #+franz 'set-tpq_previous_element set_next_element_method #+lispm ':set-tpq_next_element #+franz 'set-tpq_next_element)) (t (setq get_previous_element_method #+lispm ':previous_element #+franz 'previous_element get_next_element_method #+lispm ':next_element #+franz 'next_element set_previous_element_method #+lispm ':set-previous_element #+franz 'set-previous_element set_next_element_method #+lispm ':set-next_element #+franz 'set-next_element))) ;;ADD_AFTER is the element after which NEW_ELEMENT will be added. If ;;POSITION is defined, use that. If not (i.e., if the queue is empty), ;;define FIRST_ELEMENT to be NEW_ELEMENT: NEW_ELEMENT will point to ;;itself, and the base for the rest of the queue will be defined. (setq add_after (cond (position) (t (setq first_element new_element)))) ;;NEXT_ELEM is the element that will now follow NEW_ELEMENT. If POSITION ;;is defined, use its NEXT_ELEMENT. If not (i.e., if the queue is ;;empty), use NEW_ELEMENT itself, so that NEW_ELEMENT will point to ;;itself. (setq next_elem (cond (position (cond ((eq queue_element_type 'task_priority_queue) (ct_send position 'tpq_next_element)) (t (ct_send position 'next_element)))) (t new_element))) ;;Set up the links: ;;NEW_ELEMENT's previous element is ADD_AFTER (ct_send new_element (cond ((eq queue_element_type 'task_priority_queue) 'set-tpq_previous_element) (t 'set-previous_element)) add_after) ;;NEW_ELEMENT's next element is NEXT_ELEM (i.e., POSITION's old next element) (ct_send new_element (cond ((eq queue_element_type 'task_priority_queue) 'set-tpq_next_element) (t 'set-next_element)) next_elem) ;;NEXT_ELEM's previous element is NEW_ELEMENT (ct_send next_elem (cond ((eq queue_element_type 'task_priority_queue) 'set-tpq_previous_element) (t 'set-previous_element)) new_element) ;;ADD_AFTER's next element is NEW_ELEMENT. (ct_send add_after (cond ((eq queue_element_type 'task_priority_queue) 'set-tpq_next_element) (t 'set-next_element)) new_element) ;;Point QUEUE_ELEMENT_NAME at the NEW_ELEMENT, and return the element. (set queue_element_name new_element))) ;;;the following was altered to work on rel5 ;;;it most probably will no longer work on franz++ #|(ct_defmethod (queue add_to_queue) (val position &optional (queue_element_name nil)) ;;Franz problems: didn't like direct reference to FIRST_ELEMENT when ;;embedded in an optional POSITION argument. Check these out some more!? (cond ((null position) (cond (first_element (setq position (get-iv task_queue_element first_element previous_element)))))) (let ((new_element nil) (add_after nil) (next_elem nil) (get_previous_element_method) (get_next_element_method) (set_previous_element_method) (set_next_element_method)) ;;If QUEUE_ELEMENT_NAME was not provided in the call, cons up a name ;;from QUEUE_ELEMENT_TYPE and GENSYM. Otherwise, use what was given. (cond ((null queue_element_name) (setq queue_element_name (concat queue_element_type '_ (gensym 'q))))) ;;NEW_ELEMENT is a partially defined element of flavor ;;QUEUE_ELEMENT_TYPE. ;; ;;***********UGLY CONDITIONALIZING!!! -- JRM, 12/5/83************* ;; ;;What is ugly is that the absence of multiple inheritence in franz ;;compiled flavors requires that we check the type of element before ;;generating the instance, so we know what names to use for MYQUEUE, ;;NAME, and VALUE. This is TOTALLY ad hoc to the TASK_PRIORITY_QUEUE ;;stuff needed for the interpreter's queue package; if this code will ;;never run in Franz, it should probably be repaired. (setq new_element (cond ((eq queue_element_type 'task_priority_queue) (ct_make_instance queue_element_type 'tpq_myqueue self 'tpq_name queue_element_name 'tpq_value val)) (t (ct_make_instance queue_element_type 'myqueue self 'name queue_element_name 'value val)))) ;;Figure out the right methods for prev_element and next_element, based ;;on the type of SELF. (cond ((eq queue_element_type 'task_priority_queue) (setq get_previous_element_method #+lispm ':tpq_previous_element #+franz 'tpq_previous_element get_next_element_method #+lispm ':tpq_next_element #+franz 'tpq_next_element set_previous_element_method #+lispm ':set-tpq_previous_element #+franz 'set-tpq_previous_element set_next_element_method #+lispm ':set-tpq_next_element #+franz 'set-tpq_next_element)) (t (setq get_previous_element_method #+lispm ':previous_element #+franz 'previous_element get_next_element_method #+lispm ':next_element #+franz 'next_element set_previous_element_method #+lispm ':set-previous_element #+franz 'set-previous_element set_next_element_method #+lispm ':set-next_element #+franz 'set-next_element))) ;;ADD_AFTER is the element after which NEW_ELEMENT will be added. If ;;POSITION is defined, use that. If not (i.e., if the queue is empty), ;;define FIRST_ELEMENT to be NEW_ELEMENT: NEW_ELEMENT will point to ;;itself, and the base for the rest of the queue will be defined. (setq add_after (cond (position) (t (setq first_element new_element)))) ;;NEXT_ELEM is the element that will now follow NEW_ELEMENT. If POSITION ;;is defined, use its NEXT_ELEMENT. If not (i.e., if the queue is ;;empty), use NEW_ELEMENT itself, so that NEW_ELEMENT will point to ;;itself. (setq next_elem (cond (position (ct_send position get_next_element_method)) (t new_element))) ;;Set up the links: ;;NEW_ELEMENT's previous element is ADD_AFTER (ct_send new_element set_previous_element_method add_after) ;;NEW_ELEMENT's next element is NEXT_ELEM (i.e., POSITION's old next element) (ct_send new_element set_next_element_method next_elem) ;;NEXT_ELEM's previous element is NEW_ELEMENT (ct_send next_elem set_previous_element_method new_element) ;;ADD_AFTER's next element is NEW_ELEMENT. (ct_send add_after set_next_element_method new_element) ;;Point QUEUE_ELEMENT_NAME at the NEW_ELEMENT, and return the element. (set queue_element_name new_element)))|# ;;;TASK_PRIORITY_QUEUE: ********************************************************* ;;;(TASK_PRIORITY_QUEUE DELETE_YOURSELF_FROM_QOPQ): ***************************** ;;;This deletes a task priority queue from the QUEUE_OF_PRIORITY_QUEUES. If ;;;it's the first (i.e., the only) element on the queue, the QOPQ's ;;;FIRST_ELEMENT pointer is set to NIL. ;;;Note -- this is the same code as (BASIC_QUEUE_ELEMENT ;;;DELETE_YOURSELF_FROM_QUEUE). It is repeated here in slightly modified form ;;;because of the failure of Franz to properly compile flavors with multiple ;;;inheritance. (ct_defmethod (task_priority_queue delete_yourself_from_qopq) () (cond ((eq self tpq_next_element) ;;The first item is being deleted from the queue: set the queue's ;;FIRST_ELEMENT pointer to NIL. (set-iv task_priority_queue tpq_myqueue 'first_element nil)) (t ;;Delete the item: reset the pointers of PREVIOUS_ELEMENT and ;;NEXT_ELEMENT to point to each other, and undo the element's name ;;so the queue element can be garbage collected. (set-iv task_priority_queue tpq_previous_element 'tpq_next_element tpq_next_element) (set-iv task_priority_queue tpq_next_element 'tpq_previous_element tpq_previous_element) ;;If this was the first item, reset the queue's FIRST_ELEMENT ;;pointer to point to the new first element: SELF's NEXT_ELEMENT. (cond ((eq self (get-iv task_priority_queue tpq_myqueue 'first_element)) (set-iv task_priority_queue tpq_myqueue 'first_element tpq_next_element))) ;;Finally, undo the element's name so the queue element can be ;;garbage collected. (makunbound tpq_name)))) ;;;QUEUE_OF_PRIORITY_QUEUES: ************************************************* ;;;(QUEUE_OF_PRIORITY_QUEUES ADD_TASK_TO_PRIORITY_QUEUE): *********************** ;;;Add a task to the priority queue with priority = PRI. If such a queue ;;;doesn't exist, make one and insert it in the right place: after the queue ;;;with a just-highest priority. Putting queues in the right places means ;;;that the queues will be ordered from highest to lowest when the ;;;NEXT_ELEMENT links are followed. Returns the list ;;;( ) (ct_defmethod (queue_of_priority_queues_mixin add_task_to_priority_queue) (pri val superior &optional (queue_element_name nil)) (let ((nq nil) (q nil) (new_queue nil)) (setq q (cond ((null first_element) ;;The queue_of_queues is empty: add one and return it ;;(the queue, not the name). (setq new_queue (ct_send self 'add_to_queue nil nil queue_element_name)) (set-iv task_priority_queue new_queue priority pri) (set_superior_and_inferior_links superior new_queue) new_queue) ;;There are some priority queues: Look through them in search ;;of a queue with priority PRI. Use NIL for the value for ;;now. (t (loop with last = (get-iv task_priority_queue first_element tpq_previous_element) and elem = first_element and elem_priority = nil and new_queue = nil do (setq elem_priority (get-iv task_priority_queue elem priority)) ;;How about ELEM? (cond ((equal pri elem_priority) ;;ELEM's priority matches PRI: return it ;;for binding to Q. (return elem)) ((greaterp pri elem_priority) ;;Since these queues are ordered and we ;;found a queue -- ELEM -- whose priority ;;is less than PRI without first finding ;;one equal to PRI, a new queue should be ;;put right before ELEM. Note that if ELEM = ;;FIRST_ELEMENT, that queue should become the ;;new FIRST_ELEMENT. Create that ;;queue and return it. (setq new_queue (ct_send self 'add_to_queue nil (get-iv task_priority_queue elem tpq_previous_element) queue_element_name)) (set-iv task_priority_queue new_queue priority pri) (set_superior_and_inferior_links superior new_queue) (cond ((eq elem first_element) (setq first_element new_queue))) (return new_queue))) ;;Try the next element, quitting if ELEM = FIRST ;;(i.e., if we've come all the way around). (setq elem (get-iv task_priority_queue elem tpq_next_element)) until (eq elem first_element) ;;If we exit the loop normally, no queue was found ;;with a priority smaller than PRI: add a new ;;folder at the end of the queue-of-queues and ;;return it. finally (setq new_queue (ct_send self 'add_to_queue nil last queue_element_name)) (set-iv task_priority_queue new_queue priority pri) (set_superior_and_inferior_links superior new_queue) (return new_queue))))) ;;Now create the queue_element (this will be of flavor TASK_QUEUE_ELEMENT) ;;within Q (wherever it ended up). Return the list of the queue and ;;this new element. (setq nq (ct_send q 'add_to_queue val nil queue_element_name)) (set_superior_and_inferior_links superior nq) (list q nq))) ;;;(QUEUE_OF_PRIORITY_QUEUES NUMBER_OF_DELAYED_TASKS)************************** ;;;Add up the numbers of runnable tasks on all task priority queues belonging ;;;to this QOPQ. First, though, make sure that there really are some ;;;task_priority_queues to query.... (ct_defmethod (queue_of_priority_queues number_of_delayed_tasks) () (cond (first_element (loop with queue = first_element sum (get-iv task_priority_queue queue number_of_delayed_tasks) do (setq queue (get-iv task_priority_queue queue tpq_next_element)) until (eq queue first_element))) (t 0))) ;;;(QUEUE_OF_PRIORITY_QUEUES NUMBER_OF_RUNNABLE_TASKS)************************** ;;;Add up the numbers of runnable tasks on all task priority queues belonging ;;;to this QOPQ. First, though, make sure that there really are some ;;;task_priority_queues to query.... (ct_defmethod (queue_of_priority_queues number_of_runnable_tasks) () (cond (first_element (loop with queue = first_element sum (get-iv task_priority_queue queue number_of_runnable_tasks) do (setq queue (get-iv task_priority_queue queue tpq_next_element)) until (eq queue first_element))) (t 0))) ;;;(QUEUE_OF_PRIORITY_QUEUES ROUND_ROBIN): ************************************** ;;;Select the "next" task for execution. Returns NIL if no task can be selected. (ct_defmethod (queue_of_priority_queues round_robin) () ;;Starting with the highest priority task queue, select for execution a task ;;with the properties: (a) runnable, (b) highest priority, (c) after ;;previously executed task at that priority. Return the selected ;;TASK_QUEUE_ELEMENT, and update the TASK_PRIORITY_QUEUE's and the ;;QUEUE_OF_PRIORITY_QUEUE's MOST_RECENTLY_EXECUTED_TASK to point to the ;;selected task. Returns NIL if no executable task could be found. ;;If there is no FIRST_ELEMENT on QOPQ, we're all done -- return nil. ;;Otherwise, carry on... (cond (first_element (loop with pri_queue = first_element and task = nil do ;;Look on PRI_QUEUE for a runnable task, starting after ;;MOST_RECENTLY_EXECUTED_TASK (if nil, start with the first ;;task.) If no tasks on PRI_QUEUE are runnable, the loop will ;;continue onto the next lower priority queue, ultimately ;;returning NIL if no task can be found. (cond ((setq task ;;FIND_RUNNABLE_TASK expects a task_queue_element as ;;its argument. If it is given NIL, such as at the ;;end of the program when there are no more runnable ;;tasks, it will return NIL. (find_runnable_task (cond ((get-iv task_priority_queue pri_queue 'most_recently_executed_task) (ct_send (get-iv task_priority_queue pri_queue 'most_recently_executed_task) 'next_element)) (t (get-iv task_priority_queue pri_queue 'first_element))))) (setq most_recently_executed_task task) (set-iv task_priority_queue pri_queue 'most_recently_executed_task task) (return task))) (setq pri_queue (get-iv task_priority_queue pri_queue tpq_next_element)) until (eq pri_queue first_element) finally (return nil))))) ;;;BASIC_QUEUE_ELEMENT: ****************************************************** ;;;(BASIC_QUEUE_ELEMENT DELETE_YOURSELF_FROM_QUEUE): ************************* ;;;This deletes an element from its queue. If it's the first (i.e., the only) ;;;element on the queue, the queue's FIRST_ELEMENT pointer is set to NIL. (ct_defmethod (basic_queue_element delete_yourself_from_queue) () (cond ((eq self next_element) ;;The first item is being deleted from the queue: set the queue's ;;FIRST_ELEMENT pointer to NIL. (set-iv queue myqueue 'first_element nil)) (t ;;Delete the item: reset the pointers of PREVIOUS_ELEMENT and ;;NEXT_ELEMENT to point to each other, and undo the element's name ;;so the queue element can be garbage collected. (set-iv basic_queue_element previous_element 'next_element next_element) (set-iv basic_queue_element next_element 'previous_element previous_element) ;;If this was the first item, reset the queue's FIRST_ELEMENT ;;pointer to point to the new first element: SELF's NEXT_ELEMENT. (cond ((eq self (get-iv queue myqueue 'first_element)) (set-iv queue myqueue 'first_element next_element))) ;;Finally, undo the element's name so the queue element can be ;;garbage collected. (makunbound name)))) ;;;TASK_QUEUE_ELEMENT: ********************************************************** ;;(TASK_QUEUE_ELEMENT KILL_YOURSELF_AND_INFERIORS): ************************* ;;;This deletes an element from its task queue, adjust the SUPERIOR/INFERIOR ;;;links among the elements, and fix the MOST_RECENTLY_EXECECUTED_TASK ;;;property on the possessing task queue. If this is the first (i.e., the only) ;;;element on the queue, the queue's FIRST_ELEMENT pointer is set to NIL, but the ;;;queue itself is not done away with. This should perhaps change. (ct_defmethod (task_queue_element kill_yourself_and_inferiors) () ;;First, kill all of SELF's inferior tasks. Save their names in ;;DELETED_TASKS. (let ((deleted_tasks (loop for inferior in inferior_tasks append (ct_send inferior 'kill_yourself_and_inferiors)))) ;;Make SELF unrunnable and terminated. (ct_send self 'make_unrunnable) (setq terminated t) ;;If this task is waiting for a delay to time out, decrement its ;;task_priority_queue's NUMBER_OF_DELAYED_TASKS. (cond (waiting_for_delay_to_timeout (set-iv task_priority_queue myqueue number_of_delayed_tasks (sub1 (get-iv task_priority_queue myqueue number_of_delayed_tasks))))) ;;Undo the INFERIOR_TASK pointer from this element's SUPERIOR_TASK ;;to itself. Since this element is being killed, there's no need to ;;do anything to this element's SUPERIOR_TASK link. This will also ;;check the value of the WAITING_FOR_INFERIORS_TO_FINISH instance ;;variable, and make the superior task runnable if possible. (delete_inferior_link superior_task self) ;;If SELF was this queue's MOST_RECENTLY_EXECUTED_TASK, set that pointer ;;to NIL. Further, if QUEUE has a queue, that queue will also have a ;;MOST_RECENTLY_EXECUTED_TASK pointer; clear that one if it's pointing ;;to SELF, too. (cond ((eq self (get-iv task_priority_queue myqueue 'most_recently_executed_task)) (set-iv task_priority_queue myqueue 'most_recently_executed_task nil) (cond ((let ((qopq (get-iv task_priority_queue myqueue tpq_myqueue))) (and qopq (eq self (get-iv queue_of_priority_queues qopq 'most_recently_executed_task))) (set-iv queue_of_priority_queues qopq 'most_recently_executed_task nil)))))) ;;Which element is being deleted? (cond ((eq self next_element) ;;The first and only item is being deleted from the queue: set ;;the queue's FIRST_ELEMENT pointer to NIL. Note that it might be ;;reasonable to remove this entire queue from any queue it might ;;be in (if it's in one); decide this later. (set-iv task_priority_queue myqueue 'first_element nil)) (t ;;Delete the item: reset the pointers of PREVIOUS_ELEMENT and ;;NEXT_ELEMENT to point to each other. (set-iv task_queue_element previous_element 'next_element next_element) (set-iv task_queue_element next_element 'previous_element previous_element) ;;If this was the first item, reset the queue's FIRST_ELEMENT ;;pointer to point to the new first element: SELF's NEXT_ELEMENT. (cond ((eq self (get-iv task_priority_queue myqueue 'first_element)) (set-iv task_priority_queue myqueue 'first_element next_element))) ;;Finally, undo the element's name so the queue element can be ;;garbage collected. (makunbound name))) ;;If this task's priority queue is now completely empty, delete it. (cond ((null (get-iv task_priority_queue myqueue 'first_element)) (ct_send myqueue 'delete_yourself_from_qopq))) ;;Return the list of the names of all deleted tasks. (cons name deleted_tasks))) ;;;(TASK_QUEUE_ELEMENT MAKE_RUNNABLE): ****************************************** ;;;Set the runnable flag for this task and bump its task queue's ;;;NUMBER_OF_RUNNABLE_TASKS. (ct_defmethod (task_queue_element make_runnable) () (cond ((not runnable_p) (%= *total_number_of_runnable_tasks* (1+ *_*)) (setq runnable_p t) (set-iv task_priority_queue myqueue number_of_runnable_tasks (add1 (get-iv task_priority_queue myqueue number_of_runnable_tasks)))))) ;;;(TASK_QUEUE_ELEMENT MAKE_UNRUNNABLE): **************************************** ;;;Clear the runnable flag for this task and decrement its task queue's ;;;NUMBER_OF_RUNNABLE_TASKS. (ct_defmethod (task_queue_element make_unrunnable) () (cond (runnable_p (%= *total_number_of_runnable_tasks* (1- *_*)) (setq runnable_p nil) (set-iv task_priority_queue myqueue number_of_runnable_tasks (sub1 (get-iv task_priority_queue myqueue number_of_runnable_tasks)))))) ;;;(TASK_QUEUE_ELEMENT MAKE_WAIT_FOR_INFERIORS): ******************************** ;;;If this task has any inferiors, set its WAITING_FOR_INFERIORS_TO_FINISH variable ;;;and make it unrunnable. This will be undone when the last inferior task ;;;terminates. (ct_defmethod (task_queue_element make_wait_for_inferiors) (list_of_inferiors) (cond (inferior_tasks (setq waiting_for_inferiors_to_finish list_of_inferiors) (ct_send self 'make_unrunnable)))) ;;;(TASK_QUEUE_ELEMENT WAIT_FOR_DURATION): ************************************** ;;;Make SELF unrunnable and set the RESTART_TIME instance variable to ;;;(current_time) + (duration). FIND_RUNNABLE_TASK will check and clear this ;;;when choosing a runnable task. This uses Penny's ELAPSED_TIME function ;;;(see end of file if you want a copy). (ct_defmethod (task_queue_element wait_for_duration) (delay_in_seconds) (let ((current_time_in_seconds #+lispm (multiple-value-bind (a b c d d1 d2 d3) (time:get-time) (list a b c)) #+franz (status localtime))) (ct_send self 'make_unrunnable) (setq waiting_for_delay_to_timeout t) (set-iv task_priority_queue myqueue number_of_delayed_tasks (add1 (get-iv task_priority_queue myqueue number_of_delayed_tasks))) (setq restart_time (plus (elapsed_time current_time_in_seconds '(0 0 0)) delay_in_seconds)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Internal Use Only Functions/Macros -- ;;;DELETE_INFERIOR_LINK: ******************************************************* ;;;If PARENT exists, delete CHILD from PARENT's list of INFERIOR_TASKS. ;;;In addition, if PARENT is waiting for inferior tasks to finish and ;;;CHILD was the last inferior task on which it was waiting, re-enable PARENT. (defun delete_inferior_link (parent child) (cond (parent (let ((am_i_waiting (get-iv task_queue_element parent waiting_for_inferiors_to_finish))) (set-iv task_queue_element parent inferior_tasks (remove child (get-iv task_queue_element parent inferior_tasks))) (set-iv task_queue_element parent waiting_for_inferiors_to_finish (remove child (get-iv task_queue_element parent waiting_for_inferiors_to_finish))) (cond ((and am_i_waiting (null (get-iv task_queue_element parent waiting_for_inferiors_to_finish))) (ct_send parent 'make_runnable))))))) ;;;FIND_RUNNABLE_TASK: ********************************************************** ;;;Starting on the queue at START, look for a TASK_QUEUE_ELEMENT with either ;;;RUNNABLE_P = T, or a WAITING_FOR_DURATION time that is in now in the past. ;;;Return either it (or NIL if no runnable elements exist on this queue). ;;;If START is NIL, return NIL. (defun find_runnable_task (start) (cond (start (loop with task = start do (cond ((get-iv task_queue_element task runnable_p) (return task)) ((let ((tasktime (get-iv task_queue_element task restart_time))) (and (numberp tasktime) (greaterp (ct_millisecond_time) tasktime))) (ct_send task 'make_runnable) (set-iv task_queue_element task restart_time nil) (set-iv task_queue_element task waiting_for_delay_to_timeout nil) (let ((taskqueue (get-iv task_queue_element task myqueue))) (set-iv task_priority_queue taskqueue number_of_delayed_tasks (sub1 (get-iv task_priority_queue taskqueue number_of_delayed_tasks)))) (return task))) (setq task (get-iv task_queue_element task next_element)) until (eq task start))))) ;;;SET_SUPERIOR_AND_INFERIOR_LINKS: ******************************************** ;;;If PARENT exists, add CHILD to PARENT's list of INFERIOR_TASKS, and set ;;;PARENT to be CHILD's SUPERIOR_TASK. (defun set_superior_and_inferior_links (parent child) (cond (parent (set-iv task_queue_element parent inferior_tasks (cons child (get-iv task_queue_element parent inferior_tasks))) (set-iv task_queue_element child superior_task parent)))) ;;;*************************************************************************** ;;;Assorted queue-relevant functions, mostly useful for debugging. #| ;;;FPPQ: *********************************************************************** ;;;(i.e., FRANZ_PRINT_PRIORITY_QUEUE.) Use DESCRIBE to display the contents of ;;;the QUEUE_OF_PRIORITY_QUEUES set up by the function SETUP below. Use this ;;;on Franz instead of PRINT_PRIORITY_QUEUE: PRINTing of queues doesn't work ;;;well in Franz. (defun fppq nil (loop for item in '(foo t10 t10a t10b t10c t5 t5a t5b t5c t5d t1 t1a t1b t1c) do (ct_format t "~a: ~%~" item) (describe (eval item)) (ct_terpri) (ct_terpri) (ct_terpri))) ;;;PRINT_PRIORITY_QUEUE: ******************************************************* ;;;Print the contents of a QUEUE_OF_PRIORITY_QUEUES, including all of its ;;;component TASK_PRIORITY_QUEUES. Useful for debugging Lispm queues, where a ;;;flavor can be PRINTed as its symbol. (defun print_priority_queue (q) (loop with first = (get-iv queue_of_priority_queues q first_element) with elem = first and count = 0 initially (ct_format t "~&Queue ~a:~ ~%MOST_RECENTLY_EXECUTED_TASK = ~a" q 'most_recently_executed_task) do (ct_format t "~% Element ~d: ~a~ ~% PRIORITY = ~a" (setq count (+ count 1)) elem (get-iv task_priority_queue elem priority)) (print_task_queue elem) (setq elem (get-iv task_priority_queue elem tpq_next_element)) until (eq elem first) finally (return q))) (fset 'ppq 'print_priority_queue) ;;;PRINT_TASK_QUEUE: *********************************************************** ;;;Print the individual elements of a TASK_ELEMENT_QUEUE. (defun print_task_queue (q) (loop with first = (get-iv task_priority_queue q first_element) with elem = first and count = 0 initially (ct_format t "~&~10xMOST_RECENTLY_EXECUTED_TASK = ~a~ ~%~10xQueue ~a:" (get-iv task_priority_queue q most_recently_executed_task) q) when elem do (ct_format t "~%~10x Element ~d: ~a~ ~%~10x VALUE = ~a~ ~%~10x RUNNABLE_P = ~a~ ~%~10x SUPERIOR_TASK = ~a~ ~%~10x INFERIOR_TASKS = ~a" (setq count (+ count 1)) elem (get-iv task_queue_element elem value) (get-iv task_queue_element elem runnable_p) (and (get-iv task_queue_element elem superior_task) (get-iv task_queue_element (get-iv task_queue_element elem superior_task) value)) (loop for task in (get-iv task_queue_element elem inferior_tasks) collect (get-iv task_queue_element task value)) ) (setq elem (get-iv task_queue_element elem next_element)) until (or (null elem) (eq elem first)) finally (return q))) ;;;SETUP: ********************************************************************** ;;;Set up a sample QUEUE_OF_PRIORITY_QUEUES for debugging. (defun setup () (setq foo (ct_make_instance 'queue_of_priority_queues)) (setq *total_number_of_runnable_tasks* 0) (let ((val (ct_send foo 'add_task_to_priority_queue 10. 'task_10a nil))) (setq t10 (first val) t10a (second val))) (setq t10b (second (ct_send foo 'add_task_to_priority_queue 10. 'task_10b t10a))) (setq t10c (second (ct_send foo 'add_task_to_priority_queue 10. 'task_10c t10a))) (let ((val (ct_send foo 'add_task_to_priority_queue 5. 'task_5a nil))) (setq t5 (first val) t5a (second val))) (setq t5b (second (ct_send foo 'add_task_to_priority_queue 5. 'task_5b t5a))) (setq t5c (second (ct_send foo 'add_task_to_priority_queue 5. 'task_5c t5b))) (setq t5d (second (ct_send foo 'add_task_to_priority_queue 5. 'task_5d t5c))) (let ((val (ct_send foo 'add_task_to_priority_queue 1. 'task_1a nil))) (setq t1 (first val) t1a (second val))) (setq t1b (second (ct_send foo 'add_task_to_priority_queue 1. 'task_1b nil))) (setq t1c (second (ct_send foo 'add_task_to_priority_queue 1. 'task_1c t10b))) (set_superior_and_inferior_links t1b t1a) (set-iv queue_of_priority_queues foo most_recently_executed_task t5b) (set-iv task_priority_queue t5 most_recently_executed_task t5b) (ct_send t5a 'make_runnable) (ct_send t5b 'make_runnable) (ct_send t5c 'make_runnable) (ct_send t1b 'make_runnable)) ;;;Penny's ELAPSED_TIME function (for debugging outside of the interpreter) ;;;Returns number of SECONDS since ??? (defun elapsed_time(t1 t2) ;;;;;;;;;;;; (let* ((hrs (- (third t1)(third t2))) (mins (- (second t1)(second t2))) (secs (- (first t1)(first t2)))) (cond ((lessp secs 0) (%= secs (+ secs 60)) (%= mins (1- mins))) ((lessp mins 0) (%= mins (+ mins 60)) (%= hrs (1- hrs))) ((lessp hrs 0) (%= hrs (+ hrs 24)) )) (plus (times 3600 hrs) (times 60 mins) secs))) |# ;;; eof ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;