Power-Programmierung/CD1.mdf/magazine/drdobbs/1989/02/ilg&brow.asc

Text File | 1989-01-04 | 19KB | 498 lines

_A Timed Event Network Scheduler in Forth_
by Gregory Ilg and R.J. Brown

[NOTE: FORTH SCREENS ACCOMPANY THESE LISTINGS]

[LISTING ONE]

\   Hypothetical Network To Handle Omelette Selection On
\   Brodie's Egg-Master


        CONSULT TENS            \ Timed Event Network Scheduler

184 EQU ticks/10secs            \ system clock time constant

: MS ( miliseconds -- ticks )   \ time units conversion
    184 10000 */ ;

: sec ( seconds -- ticks )
    184 10 */ ;

: min ( minutes -- ticks )
    60 * sec ;


(  Define stubs for un-implemented words...  )

  STUB[ Break-Egg           seasoning-valve     open
        close               mixer               on
        off                 griddle             pour-valve
        wait-for-coins      Cook-Fried          Cook-Poached
        Cook-Hard-Boiled    Cook-Benedict   ]


(   Define buttons as an enumeration set...  )

  1 ENUM[   Fried-button
            Poached-button
            Hard-Boiled-button
            Benedict-button
            Omelette-button     ]

: read-a-button Omelette-button ;   \ always choose "omelette"

: None ;  IMMEDIATE  ( noise word to improve readability )



NETWORK Mix-Omelette                \ subnetwork also used
                                    \ in fancier omelettes

    NODE Start-Mix-Omelette         \ dummy for single entry
        Predecessors    NIL
        Entry-Action    None
        Delay           0 sec
        Exit-Action     None
    END-NODE


\ Wrap up subnetwork Break-Egg.  Break-Egg not detailed here

    NODE Crack-Egg
        Predecessors    Start-Mix-Omelette
        Entry-Action    Break-Egg
        Delay           0 sec
        Exit-Action     None
    END-NODE


\ concurrent with Crack-Egg

    NODE Add-Seasoning
        Predecessors    Start-Mix-Omelette
        Entry-Action    seasoning-valve open
        Delay           100 MS
        Exit-Action     seasoning-valve close
    END-NODE


    NODE Blend
        Predecessors    Crack-Egg
                        Add-Seasoning
        Entry-Action    mixer on
        Delay           3 sec
        Exit-Action     mixer off
    END-NODE


END-NETWORK  ( Mix-Omelette )




NETWORK Cook-Omelette               \ net head to process...
                                    \ ...Omelette-button

    NODE Start-Cook-Omelette        \ dummy for single entry
        Predecessors    NIL
        Entry-Action    None
        Delay           0 sec
        Exit-Action     None
    END-NODE


    NODE Preheat-Griddle
        Predecessors    Start-Cook-Omelette
        Entry-Action    griddle on
        Delay           30 sec
        Exit-Action     None
    END-NODE


\ subnetwork...

    NODE Mix-Omelette'
        Predecessors    Start-Cook-Omelette
        Entry-Action    Mix-Omelette
        Delay           0 sec
        Exit-Action     None
    END-NODE


    NODE Pour-Mixture
        Predecessors    Preheat-Griddle
                        Mix-Omelette'
        Entry-Action    pour-valve open
        Delay           2 min
        Exit-Action     pour-valve close
                        griddle off
    END-NODE


END-NETWORK  ( Cook-Omelette )



\ This word is hooked to the power-up vector on the
\ Egg-Master vending machine.


: EGG_MASTER ( -- )
    BEGIN  wait-for-coins  read-a-button  CASE
        Fried-button        OF Cook-Fried       ENDOF
        Poached-button      OF Cook-Poached     ENDOF
        Hard-Boiled-button  OF Cook-Hard-Boiled ENDOF
        Benedict-button     OF Cook-Benedict    ENDOF
        Omelette-button     OF Cook-Omelette    ENDOF
    ENDCASE AGAIN ;


[LISTING TWO]

\                  TIMED EVENT NETWORK SCHEDULER
\           Copyright (c) 1988 Elijah Laboratories Inc.


( This package makes use of a number of programs that are
not detailed here.  The word CONSULT is used to load these
packages.  The packages are included in the companion DDJ
source disk. )


    CONSULT     STRUC           \ structure definitions
    CONSULT     PRIQUE          \ priority queue manager
    CONSULT     MACROS          \ for the evaluator
    CONSULT     BALLS           \ for backtracking control
    CONSULT     XSHEETS         \ transient storage words


  CREATE TQ NIL ,               \ the timer queue

  : nothing ; *MITT* SETQ nothing \ no default THROW handler
  6 INFLATE BALL tens.ball      \ trap door for exit
            BALL te.ball        \ ditto


(  A timed event network is a linked data structure composed of
the following timed event nodes. )

sizeof pq struc TEnode              \ a timed event node
1w              TEnode  word-1      \ execute before delay
1w              TEnode  delay       \ # ticks to delay
1w              TEnode  path-length \ path length from start
1w              TEnode  word-2      \ execute after delay
1w              TEnode  ^Succ's     \ ptr to successor list
0               TEnode  Pred's      \ start of predecessor list


(  These words start and stop the timer cell, and fetch its
value, and add its value to the top-of-stack, thereby
converting a time interval into an absolute time value.  )

  VARIABLE now                                \ the timer cell

: start-now ( -- ) -2 now ! now TICKER DROP ; \ start the timer

: stop-now ( -- ) now -TICKER ;               \ stop the timer

: now@ ( -- #tics )  now @ NEGATE ;           \ fetch the timer

: now+ ( delay -- time ) now@ + ;             \ add timer value


(  This word defines the processing that occurs when a node is
activated.  This consists of performing the entry action
routine and enqueueing for the required delay time.  )

: entry-action ( node -- )              \ start up a node
    >R                                  \ save node pointer
    R@ NIL = IF T tens.ball THROW THEN  \ if none, we're done!
    R@ BODY> >NAME CR .NAME             \ display its name
    R@ word-1 PERFORM                   \ do pre-delay stuff
    R@ delay @ now+ R@ key !            \ figure dispatch time
    TQ R> pq-enque ;                    \ put on timer queue


(  This word waits until the head of the timer queue is past
its dispatch time, and then dequeues the head element from the
timer queue for subsequent processing. )

: wait-till ( -- node )             \ take next node off queue
    TQ @ 0= ABORT" Empty timer queue "
    BEGIN TQ @ key @ now@ < UNTIL   \ wait until its time
    TQ pq-deque                     \ then remove it
." DQ " ;


(  The following structures are used in the word "notify".  The
first is passed as a parameter block, and the second is SPREAD
as a SHEET.  )

0 struc n.parm              \ passed parameters...
1w      n.parm  n.pred      \ ptr to predecessor
1w      n.parm  n.succ      \ ptr to its successor

0 struc n.temp              \ temporaries...
1w      n.temp  n.trig      \ trigger indicator


(  This word searches the predecessor list of a node for a
match with the cfa of a completing predecessor.  When the match
is found, the low order bit of the predecessor address is set
as a flag to indicate that that predecessor has completed.  If
all such flags are set, "n.trig" is set to trigger the node.  )

: set-done-flag ( _n.temp -- _n.temp )     \ set pred's done fg
    AT #[ parm n.parm n.succ ]+ SH@ Pred's \ pt to succ's preds
    BEGIN DUP @ ?DUP WHILE                 \ for all preds
        AT #[ parm n.parm n.pred ]+ SH@ =  \ we got a match?
        IF DUP 1 |! THEN                   \ yes, set done flag
        DUP @ AT n.trig SH@ AND            \ figure new trigger
        AT n.trig SH! w+ REPEAT DROP ;     \ save it & continue


(  This word clears all the done flags that were set to trigger
the activation of a node.  This word is performed just prior to
activating the node, thus preparing it for re-triggering at a
later time.  )

: clear-done-flags                  \ clear succ's done flags
    AT #[ parm n.parm n.succ ]+     \ point to successor
    SH@ Pred's                      \ point to his predecessors
    BEGIN DUP @ ?DUP WHILE          \ for all predecessors
        [ 1 NOT ]# AND OVER !       \ clear its done flag
    w+ REPEAT ;                     \ loop to end of list


(  The "notify" word tells a successor to a node that one of
its predecessors has completed.  If all of its predecessors
have completed, then that successor node is started.  )

: notify ( pred succ -- )       \ notify a successor
    sizeof n.temp SPREAD        \ make room for temps
    1 AT n.trig SH!             \ cock the trigger
    set-done-flag               \ set pred's done flag
    AT n.trig SH@ IF            \ has succ been triggered?
        clear-done-flags        \ yes, clear his done flags
        CRUSH NIP entry-action  \ & start him up!
    ELSE CRUSH 2DROP THEN ;     \ no, just return...


(  This word is executed after a node has been removed from the
timer queue after waiting its required delay time.  It causes
the exit action routine for that node to be performed, and then
notifies all the successors of that node that it  has completed
execution.  )

: exit-action ( node -- )           \ complete a node
    DUP word-2 PERFORM              \ do after delay stuff
    DUP ^Succ's DUP @ NIL =         \ point to successor chain
    IF T tens.ball THROW THEN       \ if none, we're done!
    BEGIN @ ?DUP WHILE              \ for all his successors
        2DUP w+ @ notify            \ notify them he's done
    REPEAT DROP ;                   \ then clean up & exit


(  This is the "Timed Event Network Scheduler", the entry point
for the DOES> word of a timed event network.  Running such a
network is done by executing the name of the network, which
calls TENS with the address of the network list head.  )

: TENS ( net -- )                       \ run a timed event net
    tens.ball CATCH IF                  \ exit via trap door?
                 DROP EXIT THEN         \ yes, stop timer, exit
    start-now @ entry-action BEGIN      \ no, start first node
        wait-till exit-action AGAIN ;   \ wait, then finish it


(  This word links a node into the successor lists of all of
its predecessors.  After this has been done recursively for
all the successors of that node, ad infinitum, then the entire
event network will be linked both forwards and backwards.  )

F: link-to-pred                 \ declare forward reference

: link-to-pred's ( node -- )    \ fix up forward lnks in network
    DUP Pred's >R               \ point to it predecessor list
    BEGIN R@ @ ?DUP WHILE       \ for all its predecessors...
        OVER SWAP link-to-pred  \ link this node to its pred
        R> w+ >R REPEAT         \ point to next pred ptr
    DROP R> DROP ;              \ tidy up stacks

R: link-to-pred ( node pred -- )    \ ping pongs with word above
    DUP >R                          \ remember predecessor ptr
    ^Succ's                         \ point to successor ptr
    BEGIN DUP @ ?DUP WHILE          \ for all successors...
        NIP DUP w+ @ 2 PICK =       \ duplicate?
        IF R> 3DROP EXIT THEN       \ yes, skip this node
    REPEAT                          \ until end of list
    HERE SWAP !                     \ append new CONS cell
    NIL ,                           \ CDR is NIL
    ,                               \ CAR is successor node
    R> link-to-pred's ;             \ fix his predecessors too!


(  This word kicks off the action to reverse link the event
network by passing the address of the first node to the
recursive network traversal algorithm.  It takes the address
of the network list head as its parameter.  )

: fix-Succ's ( head -- )        \ generate successor lists
    w+ @                        \ point to last node
    link-to-pred's ;            \ link it to its predecessors


( This word recursively traverses the network accumulating the
maximum path length to each node.  This length from the first
to last nodes is the critical path length, or network delay. )

: set-path-len ( ^node old-path-length -- )
    SWAP >R                         \ save this node's pointer
    R@ delay @ +                    \ add this delay to old len
    R@ path-length @                \ get current len
    MAX DUP                         \ new len is max of the two
    R@ path-length !                \ save new len
    R> Pred's >R                    \ point to pred ptrs list
    BEGIN R> DUP w+ >R @ ?DUP WHILE \ for all predecessors...
        OVER RECURSE REPEAT         \ set their path length too
    DROP R> DROP ;                  \ clean up and exit


(  This word calls the recursive network traversal routine to
compute the length of the critical path through the network.
The result is stored in the network's list head.  )

: set-path-lengths ( nethead -- )
    DUP w+ @                \ point to last node
    0                       \ initial path length is zero
    set-path-len            \ recursively set path lengths
    DUP @ path-length @     \ get computed critical path length
    SWAP 2 w*+ ! ;          \ save it in network head


(  This word displays the name of a network and its critical
path length in milliseconds, It is used as a tuning aid.  )

: .pathlen ( nethead -- )       \ display critical path length
        CR                      \ start on a new line
        ." Critical path of "   \ indentify it
        DUP BODY> >NAME .NAME   \ show network name
        ."  is "                \ more verbiage
        2 w*+ @                 \ fetch length in ticks
        10 184 */               \ convert to seconds
        .                       \ display the number
        ." seconds long. "      \ more verbiage
        CR ;                    \ and a new line


(  This word displays the critical path on the screen at
compilation time to facilitate tuning.  )

: .critpath ( nethead -- )
    ." Critical path is: " w+ @     \ point to last node
    BEGIN ?DUP WHILE                \ for each node on critpath
        CR 4 SPACES                 \ indent to look pretty
        DUP BODY> >NAME .NAME       \ display its name
        Pred's >R 0 0 BEGIN         \ for each predecessor
            R> DUP w+ >R @          \ get a predecessor pointer
            ?DUP WHILE              \ as long as they exist
            DUP path-length @       \ get its path length
            2 PICK OVER MAX         \ take maximum of old & new
            OVER = IF 2SWAP THEN    \ update max & ptr
            2DROP REPEAT R> 2DROP   \ discard excess baggage
        REPEAT CR ;                 \ loop till done


(  The Top-of-Stack is used by END-NETWORK to generate the
successor lists for all of the nodes in the network. For this
reason, the last node instantiated *MUST* be the unique
terminal node for the network. Likewise, the first node
instantiated *MUST* be the unique initial node for the
network. )

: END-NETWORK ( head first last -- )
        ROT >R SWAP             \ save head, put first on top
        R@ !                    \ save first in head
        R@ w+ !                 \ save last in head
        R@ fix-Succ's           \ generate successor lists
        R@ set-path-lengths     \ compute critical path length
        R@ .pathlen             \ display critical path length
        R> .critpath ;          \ display critical path


(  The following word is used to begin the definition of a
timed event network.  The network is terminated by the word
END-NETWORK.  )

: NETWORK ( -- )            \ begin a timed event network
        CREATE HERE         \ give it a name and remember where
        NIL , NIL ,         \ initialize first & last pointers
        NIL   NIL           \ initialize 2 pointers on stack
        0 ,                 \ initialize critical path length
        DOES> TENS ;        \ runs the scheduler when called


( This is the format for declaring a node in a TENS network.

        NODE <node-name>
            Predecessor     pred1 ... predn
            Entry-Action    word1 ... wordn
            Delay           n  \ tics
            Exit-Action     word1 ... wordn
        END-NODE
)


  NIL EQU ^NODE                     \ pointer to current node

: NODE ( -- )                       \ define network step node
        CREATE                      \ make a dictionary header
        HERE EQU ^NODE              \ remember where it is
        sizeof TEnode ALLOT         \ make room for it
        0 ^NODE path-length !       \ initialize path length
        NIL ^NODE ^Succ's !         \ terminate successor chain
        DROP ?IF ^NODE              \ set 1st
        ELSE ^NODE DUP THEN ;       \ & last pointers


: Predecessors                      \ start predecessor list
        DUP                         \ insert cushion
        te.ball CATCH NIL =         \ to end predecessor list
        IF BEGIN DEPTH >R EVAL      \ mark stack & eval token
                DEPTH R>            \ did eval return a value
                - 1 = IF ,          \ yes, store it as a pred
                      ELSE          \ no, more than one value?
    T ABORT" Illegal Predecessor "  \ yes, abort with a msg!
                      THEN          \ no value, treat as comment
            AGAIN THEN              \ build predecessor list
        DROP                        \ remove cushion
        CP @ ^NODE word-1 !         \ make entry action header
        HERE PFA, nest JMP,         \ stuff cfa and pfa into it
        ] ;                         \ compile entry action


: Entry-Action NIL , T te.ball THROW ; \ end predecessor list


: Delay                             \ specify delay time
    COMPILE EXIT                    \ last word in entry action
    [COMPILE] [                     \ set interpret state
    ; IMMEDIATE                     \ must run while compiling


: Exit-Action                       \ specify exit action
        ^NODE delay !               \ save delay time
        CP @ ^NODE word-2 !         \ make exit action header
        HERE PFA, nest JMP,         \ stuff cfa & pfa into it
        ] ;                         \ force compile state


: END-NODE                      \ terminate node definition
        COMPILE EXIT            \ last word in exit action
        [COMPILE] [             \ set interpret mode
        ; IMMEDIATE             \ must run while compiling