ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/PROG/MISC/FORTHCMP.ZIP/MULTI.4TH

Text File | 1992-03-30 | 10.8 KB | 416 lines

\ ForthCMP Multitasking Module
\ Copyright 1987 (C) By Thomas Almy.  All rights reserved.

\ Permission is granted to registered users of ForthCMP to sell or distribute
\ computer programs incorporating the compiled contents of this file.

\ IBM BIOS is used for terminal I/O.

\ See the manual for usage of this module.

\   IBM is a trademark of International Business Machines, Inc.

 .( LOADING MULTI) CR
INCLUDE INTS
INCLUDE FARMEM1
10

DECIMAL

0 0 IN/OUT NEED SINGLE
0 0 IN/OUT NEED MULTI
0 0 IN/OUT NEED PAUSE
0 0 IN/OUT NEED end-timer
0 0 IN/OUT NEED start-timer

VARIABLE ?multi         \ true if multitasking turned on
VARIABLE user           \ disp into user segment--used at compile time
VARIABLE CTASK          \ pointer to task list
VARIABLE dispused       \ semaphore for display output
VARIABLE inexpect       \ executing EXPECT -- only one at a time, please!

 \ Semaphores

1 0 IN/OUT
: SEMA  BEGIN DUP @ WHILE PAUSE REPEAT  ON ;

1 0 IN/OUT
: PHORE  OFF PAUSE ;


0 0 IN/OUT
: BYE  end-timer bye ;

 \ Memory management interface
1 1 IN/OUT
: GET malloc IF    ." OUT OF MEMORY " BYE THEN ;

 \ USER VARIABLES
H: UALLOT  DSEG user @  +  user ! ;
1 2 IN/OUT
H: UCREATE user @ CONSTANT ;
H: UVARIABLE  UCREATE 2 UALLOT ;
H: URESET DSEG  0 user ! ;
URESET
 \ redefinition of primitive I/O functions
HEX
0 0 IN/OUT
CODE setcursor  \ set the cursor to the correct location
    CTASK [] BX MOV
    CS: 12 +[BX] DH MOV     \ Y value
    CS: 14 +[BX] DL MOV     \ X value
    BH BH XOR
    2 # AH MOV
    10 INT
    RET
END-CODE \ setcursor

0 0 IN/OUT
CODE getcursor  \ get the correct cursor coordinates
    3 # AH MOV
    BH BH XOR
    10 INT
    CTASK [] BX MOV
    DH CS: 12 +[BX] MOV     \ Y value
    DL CS: 14 +[BX] MOV     \ X value
    RET
END-CODE \ getcursor

2 0 IN/OUT
: GOTOXY  CTASK @ 12 + CS: 2! ;

0 2 IN/OUT
: ?XY     CTASK @ 12 + CS: 2@ ;

1 0 IN/OUT
CODE emit
    0E # AH MOV
    BX BX XOR
    10 INT
    RET
END-CODE

0 0 IN/OUT
CODE CLS
    3 # AX MOV
    10 INT
    RET
END-CODE

0 1 IN/OUT
CODE ?TERMINAL
    CALL' PAUSE     \ allow another task to execute
    1 # AH MOV
    16 INT
    0 # AX MOV
    =0 ~ IF, AX DEC  THEN,
    RET
END-CODE \ ?TERMINAL

: PAD CTASK @ 16 + CS: @ ;

DECIMAL

: EMIT
    dispused SEMA
    setcursor
    emit
    getcursor
    dispused PHORE ;

: TYPE
    dispused SEMA
    setcursor
    0 ?DO COUNT emit LOOP DROP
    getcursor
    dispused PHORE ;

: CS:TYPE
    dispused SEMA
    setcursor
    0 ?DO CS: COUNT emit LOOP DROP
    getcursor
    dispused PHORE ;

: SPACES        \ send out all characters in a burst
    dispused SEMA
    setcursor
    DUP 0> IF 0 DO BL emit LOOP  ELSE DROP THEN
    getcursor
    dispused PHORE ;


: KEY  BEGIN ?TERMINAL setcursor UNTIL  0 8 BDOS ;

 \ EXPECT

FIND SPAN #IF DROP #ELSE VARIABLE SPAN #THEN

0 0 IN/OUT
: bu  8 emit BL emit 8 emit -1 SPAN +! ;

: EXPECT
    inexpect SEMA       \ too hard if two or more tasks want input at once!
    >R SPAN OFF
    BEGIN
        SPAN @ R@ < WHILE       \ more room on line
        KEY  dispused SEMA  setcursor  CASE
        27 OF BEGIN SPAN @ 0> WHILE bu REPEAT  ENDOF
        8  OF SPAN @ 0> IF bu THEN ENDOF
        13 OF BL emit
            R> DROP DROP
            getcursor
            dispused PHORE
            inexpect PHORE
            EXIT ENDOF
        ( ELSE ) DUP emit
            OVER SPAN @ + C!
            1 SPAN +!
        0 ENDCASE
        getcursor dispused PHORE
    REPEAT
    inexpect PHORE
    R> 2DROP ;


 \ TASK CREATION
HEX
H: TASK              \ values after INIT-TASKS:
   CSEG FORCE CREATE HERE E92E , \ DISP 0 -- JMP ( task asleep )
   DSEG CTASK @ ,  CTASK !    \     02 -- relative addr nxt task
   user @ ,                   \     04 -- size of user area (not used?)
   0 ,                        \     06 -- SS register contents
   user @ pssize 10 * + ,     \     08 -- SP register contents
   user @ pssize 10 * + rssize + , \     0A -- BP register contents
   ,                          \     0C -- PC contents
\ the following fields are for per-task variables
\ and could be selectively elimiated if not needed if space is
\ at a premium.  In that case, offsets may need to be adjusted
\ for words which use latter fields.
   0 ,                        \     0E -- Message list
   0 ,                        \     10 -- Timer
   0 ,                        \     12 -- Y cursor coordinate
   0 ,                        \     14 -- X cursor coordinate
   DSEG HERE 80 ALLOT 20 + ,  \     16 -- PAD, a per-task work area
;
0 #IF
Initially, DISP 2 has absolute address of next task.
This value as well as DISP 6 get
filled in by INIT-TASKS when application is run.
#THEN

CSEG FORCE  HERE  CREATE MAIN-TASK  \ Give it a name
DSEG CTASK !                  \ Task list points to it
80CD ,                        \ DISP 0 -- INT 80 (task awake)
   0 ,                        \     02 -- relative addr next task
   0 ,                        \     04 -- NOT USED
   0 ,                        \     06 -- SS register contents
   0 ,                        \     08 -- SP register contents
   0 ,                        \     0A -- BP register contents
   0 ,                        \     0C -- PC contents
   0 ,                        \     0E -- Message list
   0 ,                        \     10 -- Timer
   0 ,                        \     12 -- Y cursor coordinate
   0 ,                        \     14 -- X cursor coordinate
   DSEG HERE 80 ALLOT 20 + ,  \     16 -- PAD, a per-task work area
0 #IF
DISP-2, 6, 12, and 14 get filled in by INIT-TASK.  -8 -0A and -0C
are filled by first task swap (which is done by INIT-TASK).
#THEN

 \ TASK INITIALIZATION
0 0 IN/OUT
: INIT-TASKS \ This MUST be executed to start multitasking
    CTASK @
    BEGIN ?DUP WHILE  \ for each task DO:
        2+ DUP CS: @ IF  \ one follows, this isn't main task
            DUP 8 + CS: @ 10 + 4 >>  GET
         OVER 4 + CS: ! \ stackseg
            DUP CS: @ TUCK   \ next task
        ELSE
            0 SWAP CTASK @ \ next task is head of list
        THEN
        OVER - 2- SWAP CS: !
    REPEAT
    MAIN-TASK CTASK !
    getcursor       \ sets main task cursor
    ?SS: MAIN-TASK 6 + CS: !    \ sets main task stack segment
    start-timer
    MULTI ( GO!!! ) ;

 \ TASK DISPATCHER
CODE PAUSE
    0 # ?multi [] CMP
    =0 IF, RET THEN,
    CTASK [] BX MOV         \ current task
    CS: 0C +[BX] POP        \ save PC
    BP CS: 0A +[BX] MOV     \ save BP
    SP CS: 08 +[BX] MOV     \ save SP
    CS: 2 +[BX] BX ADD
    4 # BX ADD
    CLI                \ no ints during dispatch
    BX JMPI  ( dispatch )
END-CODE \ PAUSE

0 #IF
Tasks are linked together so that jumping to a task will cause
jumping to the next if it is asleep, or doing an INT 80 if it
is awake.  Thanks to Henry Laxen's Forth 83 model for the
technique.
#THEN

L: start-task ( the INT80 routine )
    BX POP
    BX DEC
    BX DEC                  \ Pointer to the task
    CS: 6 +[BX] SS >SEG     \ restore stack segment
    CS: 8 +[BX] SP MOV      \ restore SP
    STI                     \ Interrupts are safe now
    CS: 0A +[BX] BP MOV     \ restore BP
    BX  CTASK [] MOV        \ current task
    CS: 0C +[BX] JMPI       \ go!
FORTH \ start-task
0 #IF
This code starts up a new task by setting up all registers,
fixing CTASK, and jumping to where we left off.
#THEN

 \ TASK MANAGEMENT
: SINGLE  ?multi OFF ;

: MULTI   ?multi ON
    ?CS: start-task 0 200  2!L  \ install interrupt vector
    PAUSE  \ start with a task swap
;

1 0 IN/OUT
: WAKE 80CD CS: <- ;

1 0 IN/OUT
\ the 2e prefix byte (CS override) makes the jmp instruction 4 bytes long
: SLEEP (  task -- )   E92E CS: <- ;

1 1 IN/OUT
: WAITING?  10 + CS: @ 0<> ;

0 0 IN/OUT
: STOP  CTASK @ SLEEP PAUSE ;

0 1 IN/OUT
: ACTIVE-TASKS
    0 CTASK @
    BEGIN
        DUP WAITING? IF SWAP 1+ SWAP ELSE
            DUP CS: @ 80CD = IF SWAP 1+ SWAP THEN THEN \ check for active
        DUP 2+ CS: @ + 4 + \ address of next task
    DUP CTASK @ = UNTIL     \ Loop until back to start
    DROP ( task address )
;

 \ MESSAGE PASSING
0 1 IN/OUT
: MESSAGE?  CTASK @ 0E + CS: @ ;

0 1 IN/OUT
: GET-MESSAGE
    BEGIN MESSAGE? ?DUP 0= WHILE STOP REPEAT
    DUP  0 @L CTASK @ 0E + CS: !         \ Unlink message
;

1 1 IN/OUT
: MESSAGES
    0 SWAP 0E + CS: @ ?DUP IF
        BEGIN SWAP 1+ SWAP  0 @L  ?DUP 0= UNTIL
    THEN ;

2 0 IN/OUT
: SEND-MESSAGE
    OVER 0 SWAP 0 !L        \ set message's next field to NIL
    DUP WAITING? NOT IF DUP WAKE THEN \ fire up receiving task
                                \ unless waiting for timer
    0E + DUP CS: @ ?DUP IF  \ Existing messages in queue
        NIP
        BEGIN DUP 0 @L ?DUP WHILE NIP REPEAT \ find end of list
        0 !L  \ store message at end of list
    ELSE
        CS: !     \ no existing messages, put at head of queue.
    THEN
    PAUSE ;  \ Give it a chance to run

 \ control-break handler
\ always gets control and (currently) dumps task information

2VARIABLE cb_save

1B CONSTANT cb_int

0 0 IN/OUT
: cbt
    CLS
    SINGLE
    end-timer
    ." Task statistics: "
    MAIN-TASK \ start with first
    BEGIN CR
        HEX DUP 0 <# # # # # #> TYPE SPACE \ address
        DUP WAITING? IF ." Waiting " DUP 10 + CS: @ . ." ticks" ELSE
            DUP CS: @ 80CD = IF ." Active" ELSE ." Sleeping" THEN THEN
        DUP 2+ CS: @ + 4 + \ address of next task
    DUP MAIN-TASK = UNTIL     \ Loop until back to start
    DROP ( task address )
    bye
;


' cbt TASK cb-task


L: cb_handler ( actual interrupt handler )
      80CD # CS: cb-task [] MOV \ wake cb task
    STI
    IRET FORTH


 \ timer

1C CONSTANT t_int               \ timer interupt vector number
CSEG FORCE
CREATE t_save 4 ALLOT           \ original interupt vector
L: t_handler
    PUSHF CS: t_save CALLF    \ do original functions
    BX PUSH
    MAIN-TASK # BX MOV ( start of list )
    BEGIN,
        CS: 0 # 10 +[BX] CMP =0 ~ IF, ( non_zero time )
            CS: 10 +[BX] DEC  ( count down )
            =0 IF, 80CD # CS: [BX] MOV THEN, ( wake task )
        THEN,
        CS: 2 +[BX] BX ADD
        4 # BX ADD ( next task )
        MAIN-TASK # BX CMP
    =0 UNTIL, ( back at start? )
    BX POP
    IRET
FORTH \ t_handler

\ timer start and end                          08:09 11/18/85

: start-timer  \ and control-break handler
    t_int get-handler  t_save CS: 2!
    ?CS: t_handler t_int set-handler
    cb_int get-handler cb_save 2!
    ?CS: cb_handler cb_int set-handler
;

: end-timer
    t_save CS: 2@  t_int set-handler
    cb_save 2@ cb_int set-handler
;

2 0 IN/OUT
: TIME-OUT ( ticks task -- )  DUP SLEEP 10 + CS: ! ;

: WAIT ( ticks -- ) CTASK @ TIME-OUT PAUSE ;

DSEG 0A = #IF DECIMAL #THEN