-------------------------------------------------------------------------- This file contains printouts of the support which is required to implement true multitasking within the UCSD p-system on the TI 99/4A. The Minimemory module (or anything with RAM at 7000H-7FFFH) must be inserted in the machine to make it possible. The difference with this multitasking, compared to the concurrency already implemented in the p-system, is that this is truly pre-emptive. The standard features only allow volountary task switching, i.e. when the current process releases control to another process on its own behalf. If a process loops forever, then no other process will ever run. But with this system installed, the scheduler will run 10 times a second, and control the distribution of the CPU to the different tasks, which are ready to run. The program multitasking is run to install the multitasking kernel. Must be done first. The unit multisupport is then used by the programs, which employ services given by this multitasking package. Notice that this multitasking system was never properly completed. Due to bugs in the UCSD IV.0 operating system, and the lack of the source code for the the operating system units concurrency and heapops, it was impossible for me to fix the problem with that dynamic memory allocation didn't protect itself against being switched out in the middle of a critical task. Thus, dynamic memory couldn't be used in multitasking progams, and that's virtually necessary. There are several assembly programs supporting these routines. I hope I've included them all, to cover all references to external procedures and functions. But I may have missed some. If you find something that seems to be lacking, get in touch and I can see if I can find it. The time stamps for the creation of the files is when they were printed, not when they were written. Anders Persson Sweden, 2005-11-18 apersson850@rixtele.com -------------------------------------------------------------------------- Created at Nov 18, Fri, 22:21.53 MULTI:MULTIPAS.TEXT program multitasking; (* Used to install multitask support *) procedure multi; external; function install:boolean; external; begin writeln; if install then writeln('A-DATA multitasking active') else begin writeln('Installation of multitasking failed'); writeln('Mini Memory not available'); end; end. Created at Nov 18, Fri, 22:22.02 MULTI:MULTISERV.TEXT ;----------------- ; ; Task switching kernel in A-DATA multitasking system. ; Contains routines used by unit multisupport too. ; ; A-DATA 860319 ; PASCALWS .EQU 8380H SP .EQU 10 PCODEBANK .EQU 1F80H ;Base address for p-code bank switch bit SLICE .EQU 5 ;Time slice is 50/slice. CALL1 .EQU 4928H ;Allowed interrupt return addresses. CALL2 .EQU 51F6H ;Task switching is done only at some interrupt calls. CALL3 .EQU 589CH ;------------------------ ; ; MULTIWS ; ; R0 Need schedule. ; R1 Temp. ; R2 Temp. Return address, PASCALWS R6 ; R3 Temp. READYQ, source pointer. ; R4 Temp. CURTSK, dest pointer ; R5 ; R6 In INTO. ; R7 ; R8 Interrupt count to see if time to try task switch. ; R9 Interrupt count limit. Loaded during installation. ; R10 Secondary return link. ; R11 Return link. ; R12 CRU base. ; R13 Old WP ; R14 Old PC ; R15 Old ST ; ;------------------------- .ABSOLUTE .PROC MULTI .ORG 7000H .DEF MULTSTRT,LAST MULTSTRT .WORD MULTIWS ;Calling vector .WORD MULTIPGM .WORD MULTINIT ;Address of startup code ENABLE .WORD 0 ;Flag used to disable switching .WORD SETPRIO ;Address to set_priority routine .WORD INTO ;Addresses to queue management .WORD OUT .WORD REMOVE ;Removes a task to be killed .WORD DELAY ;Called when a process wants to wait some time KEYSEM .BLOCK 4 ;Semaphore for processes waiting for keyboard input. .WORD ENTER ;Monitor routines .WORD EXIT .WORD CAUSE .WORD AWAIT MULTIWS .BLOCK 32,0 ;--------------- ; Startup code ; MULTINIT LWPI MULTIWS LI R9,SLICE ;Count limit MOV R9,R8 SETO @ENABLE ;Allow switching CLR @DELAYQUE CLR @KEYSEM ;seminit(keysem,0) CLR @KEYSEM+2 CLR @WAITING ;Key input flags SETO @SLEEPING LI R12,PCODEBANK LWPI PASCALWS B *R11 ;------------------- ; ; Main switching program ; MULTIPGM runs on every interrupt ; WAITQ .EQU 0 PRIOR .EQU 3 ;Location of priority byte in TIB TICK .EQU 12 ;Reserved for future use. Used for tick count. HANG_PTR .EQU 20 MAINTASK .EQU 24 READYQ .EQU 2AB6H ;Ready queue pointer. CURTSK .EQU 2ABAH ;Current TIB pointer. BUFFLAG .EQU 28A2H EMPTY .EQU 2D9EH VDPWA .EQU 8C02H VDPWD .EQU 8C00H VDPIMAGE .EQU 0800H ;Screen image table ;Cursor data CURVISBL .WORD 0 CURVDP .WORD 0 CURRAM .WORD 0 ;Address to the replaced character CURBLINK .WORD 0 ;Blink timer CURWIND .WORD 0 ;Window where the cursor is BLNKRATE .WORD 30 ;Data for current print location SCRROW .EQU 2CC0H SCRCOL .EQU 2CC2H SCRRAM .EQU 2CC4H SCRWIDTH .EQU 2CC6H SCRWIND .EQU 2CCAH WAITTICK .WORD ;High speed scan time count WAITTIME .WORD 30 ;Scan limit KEYTICK .EQU 2CD4H KEYTIME .EQU 2CD2H SAVETIME .WORD WAITING .WORD SLEEPING .WORD ;--- CURSOFF ;Replaces the cursor with the character it's covering. MOV @CURVDP,R1 MOVB @MULTIWS+3,@VDPWA ORI R1,4000H MOVB R1,@VDPWA MOV @CURRAM,R1 MOVB *R1,@VDPWD B *R11 WINDLEFT ;Calculates left column in current window MOV @SCRWIDTH,R1 ;Calculate proper screen window SRL R1,1 ;See if current must be changed MPY @SCRWIND,R1 MOV R2,R3 C @SCRCOL,R2 B *R11 WINDCALC ;Calculates new window MOV @SCRWIDTH,R3 SRL R3,1 MOV @SCRCOL,R2 CLR R1 S R3,R2 DIV R3,R1 MOV R1,@SCRWIND B *R11 CURVDPCALC ;Calculates cursor VDP address MOV @SCRWIDTH,R1 MPY @SCRROW,R1 A @SCRCOL,R2 S R3,R2 AI R2,VDPIMAGE MOV R2,@CURVDP B *R11 MULTIPGM ;First check if there is someone waiting for a key LI R4,READYQ ;Where to insert tasks allowed to run LI R2,KEYSEM+2 ;Queue waiting for keyboard CLR R0 MOV *R2,R2 JNE LOOKBUF B @KEYEND ;No waiting LOOKBUF MOV @BUFFLAG,R1 ;Anything in buffer COC @EMPTY,R1 JEQ NO_AVAIL ;Key available. Move waiting tasks to ready queue SETO R0 ;Need schedule CLR R8 KEYEVENT MOV R2,R1 ;Move all waiting to Ready queue CLR @HANGPTR(R1) MOV *R2,R2 BL @INTO MOV R2,@KEYSEM+2 JNE KEYEVENT MOV @CURVISBL,R1 ;Cursor management JEQ NOVIS1 C @SCRWIND,@CURWIND ;Cursor on current window JNE NOVIS1 BL @CURSOFF NOVIS1 CLR @CURBLINK C @SCRWIND,@CURWIND JEQ NOSHIFT MOV @CURWIND,@SCRWIND ;Show window where input is done when key BL @47D2H ;is pressed NOSHIFT CLR @WAITING ;Not waiting SETO @SLEEPING B @KEYEND NOAVAIL ;No character in buffer MOV @WAITING,R1 ;Se if first time in wait state JNE NOTWAIT MOV @WAITTIME,@WAITTICK ;Load delay counter CLR @SLEEPING ;High speed scan SETO @WAITING MOV @KEYTIME,@SAVETIME LI R1,1 MOV R1,@KEYTIME MOV R1,@KEYTICK BL @WINDLEFT ;Find leftmost column in current window JHE COLGTE1 C @SCRCOL,@SCRWIDTH JHE COLGTE2 CLR @SCRWIND JMP SHOW COLGTE2 BL @WINDCALC INC @SCRWIND JMP SHOW COLGTE1 MOV R3,R1 A @SCRWIDTH,R1 C @SCRCOL,R1 JL SETUP BL @WINDCALC SHOW BL @47D2H ;Show window SETUP MOV @SCRWIND,@CURWIND ;Load cursor info after window calculation MOV @SCRRAM,@CURRAM MOV @SCRWIDTH,R1 ;row*width+col-window*width/2+screenbase SRL R1,1 MPY @SCRWIND,R1 MOV R2,R3 BL @CURVDPCALC CLR @CURVISBL JMP CURSOR NOTWAIT MOV @SLEEPING,R1 JNE CURSOR DEC @WAITTICK ;End of high speed? JGT CURSOR SETO @SLEEPING ;Normal speed MOV @SAVETIME,@KEYTIME CURSOR DEC @CURBLINK JGT KEYEND MOV @BLNKRATE,@CURBLINK MOV @CURVISBL,R1 JEQ NOVIS2 C @SCRWIND,@CURWIND JNE NEQWIND BL @CURSOFF NEQWIND CLR @CURVISBL JMP KEYEND ;Figure out if current write position is shown NOVIS2 MOV @CURVDP,R2 C @SCRWIND,@CURWIND ;Easy if same window JEQ PUTOUT BL @WINDLEFT JL KEYEND A @SCRWIDTH,R2 C @SCRCOL,R2 JHE KEYEND MOV @SCRWIND,@CURWIND ;Load cursor data BL @CURVDPCALC PUTOUT SETO @CURVISBL MOVB @MULTIWS+5,@VDPWA ;Put out the cursor ORI R2,4000H MOVB R2,@VDPWA CLR R2 MOVB R2,@VDPWD KEYEND LI R2,DELAYQUE ;Wait queue for delayed tasks WAITWHIL MOV *R2,R2 JEQ WAITEND ;Queue end? WAITDEC DEC @TICK(R2) JNE WAITWHIL ;Not start yet? SETO R0 ;Force switch as soon as possible CLR R8 MOV R2,R1 CLR @HANGPTR(R1) ;Not waiting any more MOV *R2,R2 ;Next in queue BL @INTO ;Insert in ready queue MOV R2,@DELAYQUE ;Finally remove from wait queue JNE WAITDEC ;More? WAITEND MOV R0,R0 ;Some task timed-out. Try to start it. JNE WANTTO MOV R8,R8 ;Already waiting for good interrupt? JEQ TRY DEC R8 JNE LEAVE ;Not this time? TRY C @ENABLE,R8 ;If ENABLE is zero then no switching. JEQ LEAVE WANTTO MOV @28(R13),R2 ;Fetch call address (actually return address). CI R2,CALL1 ;Ordinary switch? JEQ TYPE1 CI R2,CALL2 ;Special? JEQ TYPE2 CI R2,CALL3 ;Special? JEQ TYPE2 LEAVE MOV @PASCALWS+22,R11 ;Reload p-code IPC LWPI PASCALWS ;Might have been destroyed by normal BL @4144H ;interrupt routine. LWPI MULTIWS MOV R11,@PASCALWS+22 RTWP ;--------------- ; Checks if priorities allow task switch ; CHKPRIOR MOV @READYQ,R3 JEQ LEAVE ;If queue is empty MOV @CURTSK,R4 CB @PRIOR(R3),@PRIOR(R4) JL LEAVE ;If head of ready queue has lower priority B *R11 ;--------------- ; Subroutine doing task switching ; Assumes PASCALWS R0-R7 is available ; ; Addresses of PME support routines in normal ROM bank. SAVECURR .EQU 579AH ;Save current registers INTOQUE .EQU 575CH ;Inserts TIB in a queue GETTASK .EQU 578CH ;Get next task to run TASKSWITCH .EQU 57BEH ;Make new task current SWITCH LWPI PASCALWS BL @SAVECURR MOV @READYQ,R4 ;Insert in ready queue BL @INTOQUE BL @GETTASK MOV R4,@READYQ ;New READYQ MOV R5,@CURTSK ;New CURTSK BL @TASKSWITCH LWPI MULTIWS B *R11 ;--------------- ; Prepares for and restores after special task switch ; SAVEAREA .BLOCK 16 ; Saves or reloads eight words. MOVE MOV *R3+,*R4+ MOV *R3+,*R4+ MOV *R3+,*R4+ MOV *R3+,*R4+ MOV *R3+,*R4+ MOV *R3+,*R4+ MOV *R3+,*R4+ MOV *R3+,*R4+ B *R11 ; Prepares for switch PREPARE MOV R11,R10 LI R3,PASCALWS ;Save R0-R7 of PASCALWS LI R4,SAVEAREA BL @MOVE SBZ 0 ;Disable extra ROM bank B *R10 ; Restores after special switch RESTORE MOV R11,R10 LI R3,SAVEAREA LI R4,PASCALWS BL @MOVE SBO 0 ;Enable extra bank. B *R10 ;------------------ ; ; Ordinary task switch. ; Used when interrupt occurs between two p-code instructions. ; TYPE1 MOV R9,R8 ;Reload counter BL @CHKPRIOR ;See if any use to switch. Doesn't return if not. MOV @PASCALWS+12,R2 ;Save PASCALWS R6 BL @SWITCH MOV R2,@PASCALWS+12 RTWP ;------------------ ; ; Special task switch. ; Used when interrupt occurs during some I/O operations. ; TYPE2 MOV R9,R8 BL @CHKPRIOR BL @PREPARE BL @SWITCH BL @RESTORE JMP LEAVE ;----------------- ; Removes a TIB pointed to by R1 from a queue. ; Queue head pointed to by R4. ; Not used here. Intended for Pascal support. ; OUT MOV R4,R3 JEQ NOT_HERE OUTLOOP C *R3,R1 ;Searched TIB? JEQ FOUND MOV *R3,R3 ;Next in queue JEQ NOT_HERE JMP OUTLOOP FOUND MOV *R1,*R3 NOT_HERE B *R11 ;-------------- ; ; Inserts a TIB pointed to by R1 in a queue in priority order. ; Queue head pointed to by R4. ; Not used here. Intended for Pascal support. ; INTO MOV *R4,R3 CLR R6 INTOLOOP MOV R3,R3 ;Nil? JEQ ENDQUEUE CB @PRIOR(R3),@PRIOR(R1) JL ENDQUEUE MOV R3,R6 MOV *R3,R3 ;Next TIB JMP INTOLOOP ENDQUEUE MOV R3,*R1 ;New Wait_Q in TIB MOV R6,R6 JEQ QUENIL MOV R1,*R6 ;Load preceeding Wait_Q B *R11 QUENIL MOV R1,*R4 ;First in queue. Load queue head B *R11 ;--------- ; ; Inserts TIB pointed to by R5 in time delay queue. ; Sorting order is shortest waiting time first. ; INTODELAY MOV @DELAYQUE,R6 ;Fetch queue pointer CLR R7 DELLOOP MOV R6,R6 ;Nil? JEQ ENDDEL C @TICK(R6),@TICK(R5) ;Compare times JHE ENDDEL MOV R6,R7 MOV *R6,R6 JMP DELLOOP ENDDEL MOV R6,*R5 MOV R7,R7 JEQ DELNIL MOV R5,*R7 B *R11 DELNIL MOV R5,@DELAYQUE B *R11 .INCLUDE MULTIAID.TEXT LAST .END Created at Nov 18, Fri, 22:24.09 MULTI:MULTIAID.TEXT ;------------ ; ; Called from multisupport when a task should be killed. ; REMOVE MOV R11,@SAVELINK MOV *SP+,R1 ;Pid CLR *SP ;Default return is false C R1,@CURTSK ;Don't allow killing the task itself JEQ RETURN MOV @MAINTASK(R1),R0 ;Don't allow killing the main task JNE RETURN MOV @HANGPTR(R1),R4 ;See if in a semaphore queue JEQ NOSEM2 INCT R4 ;Pointer to semaphore queue head TAKEOUT BL @OUT INC *SP ;Return true JMP RETURN NOSEM2 LI R4,READYQ ;Must be in ready queue JMP TAKEOUT ;------------- ; ; Called by setpriority in unit multisupport. ; SAVELINK .WORD 0 SETPRIO MOV R11,@SAVELINK MOV *SP+,R0 ;New priority MOV *SP+,R1 ;Pid MOVB @PASCALWS+1,@PRIOR(R1) ;Load priority MOV @HANGPTR(R1),R4 JEQ NOSEM ;Not waiting for a semaphore if nil INCT R4 ;Point to semaphore pointer BL @OUT ;Remove from semaphore queue BL @INTO ;Insert again in priority order JMP RETURN ;No need to schedule NOSEM C R1,@CURTSK ;Running task JEQ SCHEDULE ;No shuffling in queues LI R4,READYQ ;Sort ready queue BL @OUT BL @INTO SCHEDULE MOV @MULTIWS+18,@MULTIWS+16 ;Reload counter because switch now MOV @READYQ,R1 ;Check priorities JEQ RETURN MOV @CURTSK,R2 CB @PRIOR(R1),@PRIOR(R2) JL RETURN LWPI MULTIWS BL @SWITCH LWPI PASCALWS B @4142H ;Return to the p-system RETURN MOV @SAVELINK,R11 ;Return to external call B *R11 ;------------ ; ; Called when a task wants to wait some time ; DUMMYSEM .WORD 0 ;Tasks in the delay queue must look like they are ; waiting for some semaphore. Otherwise, kill doesn't work. DELAYQUE .WORD 0 ;Pointer to tasks waiting for some time DELAY MOV R11,@SAVELINK ;Using PASCALWS MOV @CURTSK,R5 ;Pid for current MOV *SP+,@TICK(R5) ;Time to wait JEQ RETURN ;No time? BL @SAVECURR ;Prepare switch LI R0,DUMMYSEM MOV R0,@HANGPTR(R5) BL @INTODELAY ;Place task in time delay queue MOV @READYQ,R4 ;Next to run MOV R4,@CURTSK MOV *R4,@READYQ ;Head of ready queue now next waiting task BL @TASKSWITCH ;Make new task current B @4142H ;To PME ;-------- ; ; Used for speed enhanchements of monitor operations ; POINTER .WORD ENTER ;Enter Monitor MOV R11,@SAVELINK MOV *SP,@POINTER ;Pointer to monitor MOV *SP+,R5 MOV *R5,R0 JEQ NOTOCC ;Monitor not occupied BL @SAVECURR MOV @CURTSK,R1 MOV @POINTER,R4 INCT R4 ;Point to semaphore MOV R4,@HANGPTR(R1) ;To allow kill INCT R4 BL @INTO REPLACE MOV @MULTIWS+18,@MULTIWS+16 MOV @READYQ,R4 ;Fetch another one to run MOV R4,@CURTSK MOV *R4,@READYQ BL @TASKSWITCH B @4142H ;To PME NOTOCC LI R1,1 MOV R1,*R5 ;Occupied := true JMP RETURN EXIT ;Exitmonitor MOV R11,@SAVELINK MOV *SP+,R5 MOV @4(R5),R1 ;Queue pointer JEQ NOWAITING MOV *R1,@4(R5) ;Remove first in queue CLR @HANGPTR(R1) LI R4,READYQ BL @INTO ;Insert task in ready queue JMP SCHEDULE NOWAITING CLR *R5 ;Occupied := false JMP RETURN AWAIT ;Await event MOV R11,@SAVELINK MOV *SP,@POINTER MOV *SP+,R4 BL @SAVECURR MOV @CURTSK,R1 INCT R4 MOV R4,@HANGPTR(R1) ;For kill INCT R4 BL @INTO ;Insert current in event queue MOV @POINTER,R4 ;Pointer to event MOV *R4,R2 ;Pointer to monitor MOV @4(R2),R1 ;Monitor queue JEQ NOINMON ;Queue empty? MOV *R1,@4(R2) ;Remove first from queue CLR @HANGPTR(R1) LI R4,READYQ BL @INTO JMP REPLACE NOINMON CLR *R2 ;monitor.occupied := false JMP REPLACE CAUSE ;Cause event MOV R11,@SAVELINK MOV *SP,@POINTER MOV *SP+,R2 ;Event pointer MOV *R2,R4 ;Monitor pointer MOV R4,R5 INCT R5 ;Monitor.waiting pointer AI R4,4 ;Monitor.waiting.queue pointer AI R2,4 ;Event.waiting.queue pointer MOV R2,R0 MOV *R2,R2 ;Anything in queue? JNE REPEAT1 B @RETURN REPEAT1 MOV R2,R1 MOV R5,@HANGPTR(R1) ;Waiting for new semaphore MOV *R2,R2 BL @INTO MOV R2,*R0 ;Load new address into event.waiting JNE REPEAT1 B @RETURN Created at Nov 18, Fri, 22:25.05 MULTI:MULTINSTAL.TEXT ;---------------- ; ; Function used to install the task switching code. ; ; function install:boolean; external; ; ; Returns true if the installation worked. ; ; A-DATA 860226 ; ;---------------- SP .EQU 10 MINIMEM .EQU 7000H ;Addr of Mini Memory PATCHADDR .EQU 3368H ;Place to install the call of the task switcher .FUNC INSTALL .REF MULTSTRT,LAST PATCHSIZE .EQU 6 ;Length of patch code MOV R11,R7 CLR *SP ;Default return is false CLR R0 ;Check if mini memory is there MOV R0,@MINIMEM C @MINIMEM,R0 JNE LEAVE INV R0 MOV R0,@MINIMEM C @MINIMEM,R0 JNE LEAVE INC *SP ;Return true LI R0,MINIMEM LI R1,MULTSTRT LI R2,LAST AI R1,-MINIMEM ;Necessary by unfathomable reason AI R2,-MINIMEM INCT R2 S R1,R2 ;Byte count MOVLOOP1 MOV *R1+,*R0+ DECT R2 JNE MOVLOOP1 MOV @MINIMEM+4,R0 ;Initiate server BL *R0 LI R0,PATCHADDR ;Install patch in interrupt handler LI R1,PATCHCODE LI R2,PATCHSIZE MOVLOOP2 MOV *R1+,*R0+ DECT R2 JNE MOVLOOP2 LEAVE B *R7 PATCHCODE BLWP @MINIMEM RTWP .END Created at Nov 18, Fri, 22:25.24 MULTI:MULTIUNIT.TEXT unit multisupport; (* Extended support for A-DATA multitasking system *) interface type monitor = ^monnotice; monnotice = record occupied :boolean; (* Tells if monitor is in use *) waiting :semaphore; (* For tasks to wait for *) end; (* monnotice *) event = ^eventnotice; eventnotice = record mymon :monitor; (* Corresponding monitor *) waiting :semaphore; (* For tasks to wait for *) end; (* eventnotice *) procedure enable; (* Time sharing on *) procedure disable; (* Time sharing (but not concurrency) off *) procedure set_priority(pid :processid; newprio :integer); (* Changes priority of a process *) procedure set_own_priority(newprio :integer); (* Changes priority of the caller *) function get_priority(pid :processid) :integer; (* Returns the priority of a process *) function get_own_priority :integer; (* Returns priority of the caller *) procedure kill(pid :processid); (* Kills antoher process *) procedure delay(ticks :integer); (* Delays the caller ticks/50 secs *) procedure initmonitor(var m :monitor); procedure entermonitor(m :monitor); (* Called at the beginning of monitor operations *) procedure exitmonitor(m :monitor); (* Called at the end of monitor operations *) procedure initevent(var e :event; m :monitor); procedure await(e :event); procedure cause(e :event); function charinput :char; (* Returns a character without echo when available *) function charecho :char; (* As above but with echo *) implementation const readyaddr = 10934; curraddr = 10938; heapaddr = 13844; infoaddr = 13852; patchaddr = 13160; waitsem = 28690; type TIB_ptr = ^TIB; quehead = ^TIB_ptr; sem_ptr = ^semaphore; byte = 0..255; TIB = record (* Task information block *) regs:packed record wait_q :TIB_ptr; (* Link in list of waiting TIBs *) prior :byte; (* Priority of task *) flags :byte; (* Reserved *) fill1 :array[0..7] of integer; hang_ptr:sem_ptr; (* Pointer to semaphore holding the task *) m_depend:integer; end; (* regs *) main_task:boolean; (* True if root or parent task *) fill2 :integer; end; (* TIB *) heaptype = record (* Kernel heap_info type *) lock :semaphore; top_mark, heap_top :^integer; end; (* heaptype *) infotype = record (* Kernel Task_info type *) lock, task_done :semaphore; N_tasks :integer; end; (* infotype *) var readyq, curtsk :quehead; heap_info :^heap_type; task_info :^infotype; keywait :^semaphore; (* To wait for when no key in buffer *) mem_ptr :^integer; procedure prio(pid :processid; newprio :integer); external; procedure hold; external; procedure unlock; external; procedure out(queue :quehead; task :TIB_ptr); external; procedure into(queue :quehead; task :TIB_ptr); external; function removed(pid :processid):boolean; external; procedure waittime(ticks :integer); external; procedure loadpointer(var pointer; value :integer); external; procedure monenter(m :monitor); external; procedure monexit(m :monitor); external; procedure eventawait(e :event); external; procedure eventcause(e :event); external; function bscan :integer; external; procedure enable; (* Enables timesharing *) begin unlock; end; (* enable *) procedure disable; (* Disables timesharing, but not multitasking. Turns the system into the normal state. *) begin hold; end; (* disable *) procedure delay; (* Suspends caller ticks/50 (ticks/60 for US and other 60 Hz) seconds. *) begin waittime(ticks); end; (* delay *) procedure set_priority; (* Changes the priority of some task, except the current *) begin prio(pid,newprio); end; (* set_priority *) procedure set_own_priority; (* Changes the priority of the running task itself. A special procedure is needed for this purpose, since it's usually difficult for a task to learn it's own processid, without using "tricks". *) var pid :processid; begin moveleft(curtsk^,pid,2); prio(pid,newprio); end; (* set_own_priority *) function get_priority; (* Returns the current priority for any task *) var temp :TIB_ptr; begin moveleft(pid,temp,2); get_priority := temp^.regs.prior; end; (* get_priority *) function get_own_priority; (* Returns priority of currently executing process *) begin get_own_priority := curtsk^^.regs.prior; end; (* get_own_priority *) procedure kill; (* Used to terminate a task. Can't terminate itself nor the main task. Avoid killing a task that is terminating by itself at the same time. Due to semaphore management in the Operating System units HEAPOPS and CONCURRENCY, such a kill might create a deadlock. *) var killed :boolean; begin wait(heap_info^.lock); if removed(pid) then with task_info^ do begin wait(lock); N_tasks := N_tasks-1; signal(task_done); signal(lock); end; signal(heap_info^.lock); end; (* kill *) function charinput; (* Returns a character as soon as it's available *) var keep :integer; begin repeat keep := bscan; if keep=-1 then wait(keywait^); until keep<>-1; charinput := chr(keep); end; (* charinput *) function charecho; (* Echoing charinput *) var ch :char; begin ch := charinput; write(ch); charecho := ch; end; (* charecho *) procedure initmonitor; (* Monitors must be initiated before use *) begin new(m); with m^ do begin occupied := false; seminit(waiting,0); end; (* with *) end; (* initmonitor *) procedure entermonitor; (* Called at the beginning of all monitor operations *) begin monenter(m); end; (* entermonitor *) procedure exitmonitor; (* Called at the end of all monitor operations *) begin monexit(m); end; (* exitmonitor *) procedure initevent; (* Events must be initiated before use. They are also bound to their monitor by this routine. Hence, the monitor must be initiated first. *) begin new(e); with e^ do begin mymon := m; seminit(waiting,0); end; (* with *) end; (* initevent *) procedure await; (* Called when a monitor operation wants to wait for some event. *) begin eventawait(e); end; (* await *) procedure cause; (* Used when a monitor wants to cause an event *) begin eventcause(e); end; (* cause *) begin (* multisupport *) loadpointer(memptr,patchaddr); if memptr^<>1056 then begin writeln('Multitasking support not installed'); writeln('Execution aborted'); exit(program); end; (* Load pointers *) loadpointer(readyq,readyaddr); loadpointer(curtsk,curraddr); loadpointer(heap_info,heapaddr); loadpointer(task_info,infoaddr); loadpointer(keywait,waitsem); seminit(keywait^,0); end. Created at Nov 18, Fri, 22:26.38 MULTI:MULTIUASM.TEXT ;--------------- ; ; Low level routines used by unit multisupport ; ; A-DATA 860313 ; MINIMEM .EQU 7000H SP .EQU 10 .PROC PRIO,2 ;Changes process priority MOV @MINIMEM+8,R0 B *R0 .PROC HOLD ;Disables time sharing CLR @MINIMEM+6 B *R11 .PROC UNLOCK ;Enables time sharing SETO @MINIMEM+6 B *R11 .PROC OUT,2 ;Removes a TIB from a queue MOV *SP+,R1 ;processid MOV *SP+,R4 ;Queue MOV @MINIMEM+12,R0 B *R0 .PROC INTO,2 ;Inserts a TIB into a queue in priority order MOV *SP+,R1 ;processid MOV *SP+,R4 ;Queue MOV @MINIMEM+10,R0 B *R0 .FUNC REMOVED,1 ;Removes a task to be killed MOV @MINIMEM+14,R0 B *R0 .PROC WAITTIME,1 MOV @MINIMEM+16,R0 ;Suspends task for *SP ticks B *R0 .END Created at Nov 18, Fri, 22:26.54 MULTI:MULTIUASM2.TEXT ;--------------- ; ; Low level routines used by unit multisupport ; ; A-DATA 860331 ; MINIMEM .EQU 7000H SP .EQU 10 .PROC MONENTER,1 ;EnterMonitor MOV @MINIMEM+22,R0 B *R0 .PROC MONEXIT,1 ;Exit monitor MOV @MINIMEM+24,R0 B *R0 .PROC EVENTAWAIT,1 ;Await event MOV @MINIMEM+28,R0 B *R0 .PROC EVENTCAUSE,1 ;Cause MOV @MINIMEM+26,R0 B *R0 .END -------------------------------------------------------------------------- These are various test programs I've written, to see if the multitasking package behaves as I'd like it to do. To run these programs, with the expected result, the multitasking kernel must first be installed on the 99/4A. Also, if it's referenced, the unit with additional support for multitasking must be installed in SYSTEM.LIBRARY, or available in some other on-line file. The time stamps for the creation of the files is when they were printed, not when they were written. Anders Persson Sweden, 2005-11-18 apersson850@rixtele.com -------------------------------------------------------------------------- Created at Nov 18, Fri, 22:34.28 MULTI:CONCTEST4.TEXT program tester; process putline(line :string); var i :integer; begin while true do begin for i := 1 to length(line) do write(line[i]); writeln; end; end; (* putline *) begin start(putline('FIRST KEEPS ON')); start(putline('second here too')); start(putline('*******')); end. Created at Nov 18, Fri, 22:34.37 MULTI:CONCTEST6.TEXT program currtest; uses (*$U multisupp.code *) multisupport; const NumberOfBuffers = 8; type BufferType = record Getpointer, Putpointer:1..NumberOfBuffers; Mutex :semaphore; Line :array[1..NumberOfBuffers] of string; end; var buffer:buffertype; free, available, terminate :semaphore; scrpid, pid :processid; prio1, prio2, prio3, prio4, i :integer; temp :string; m :monitor; e :event; procedure putline(outline:string); begin wait(free); with buffer do begin wait(mutex); line[putpointer] := outline; putpointer := putpointer mod numberofbuffers+1; signal(mutex); end; signal(Available); end; (* putline *) procedure getline(var outline:string); begin wait(available); with buffer do begin wait(mutex); outline := line[getpointer]; getpointer := getpointer mod numberofbuffers+1; signal(mutex); end; signal(free); end; (* getline *) procedure initbuffer; begin with buffer do begin putpointer := 1; getpointer := 1; end; end; (* initbuffer *) process task_a; var i:integer; temp :string; begin for i := 1 to 30 do begin str(i,temp); putline(concat('Here is process A ',temp)); end; signal(terminate); end; (* taska *) process task_b; var i:integer; temp :string; begin for i := 1 to 30 do begin str(i,temp); putline(concat('Here is process B ',temp)); end; signal(terminate); end; (* taskb *) process task_c; var i:integer; temp :string; begin for i := 1 to 30 do begin str(i,temp); putline(concat('Here is process C ',temp)); end; signal(terminate); end; (* taskb *) process scrmanager; var line:string; begin while true do begin getline(line); writeln(line); end; end; (* scrmanager *) begin (* main *) initmonitor(m); initevent(e,m); initbuffer; seminit(terminate,0); seminit(free,numberofbuffers); seminit(available,0); seminit(buffer.mutex,1); writeln('Starting tasks'); start(scrmanager,scrpid,600,130); start(task_a,pid,600); start(task_b,pid,600); start(task_c,pid,600); for i := 1 to 30 do begin str(i,temp); putline(concat('Here is the main task ',temp)); end; wait(terminate); wait(terminate); wait(terminate); writeln('Attempt to kill screenmanager'); with buffer do begin wait(mutex); while putpointer<>getpointer do begin signal(mutex); wait(free); wait(mutex); end; signal(mutex); end; (* with *) writeln('Allowed to kill'); kill(scrpid); writeln('Got rid of it'); end. Created at Nov 18, Fri, 22:35.11 MULTI:CONCTEST10.TEXT program tester; const infoaddr = 13852; type dual = record case integer of 0 :(int :integer); 1 :(ptr :^integer); 2 :(info :^info_type); end; (* dual *) infotype = record (* Kernel Task_info type *) task_done, lock :semaphore; N_tasks :integer; end; (* infotype *) var point :dual; buffer :array[0..4] of integer; i :integer; task_info :^info_type; ch :char; procedure report; var i :integer; begin writeln('------'); moveleft(point.ptr^,buffer,sizeof(buffer)); for i := 0 to 4 do writeln(buffer[i]); end; begin point.int := infoaddr; task_info := point.info; report; writeln; write('Initiate? '); readln(ch); if ch in ['Y','y'] then with task_info^ do begin write('Value for lock? '); readln(i); seminit(lock,i); write('Value for task_done? '); readln(i); seminit(task_done,i); write('Value for N_tasks? '); readln(i); N_tasks := i; end; (* with *) end. Created at Nov 18, Fri, 22:35.26 MULTI:CONCTEST11.TEXT program tester; (* Test of concurrent file handling *) var copies, stack, i :integer; source, dest :string; pid :processid; process copier(source,dest :string); var file1, file2 :text; line :string; begin reset(file1,source); rewrite(file2,dest); while not eof(file1) do begin readln(file1,line); writeln(file2,line); end; close(file2,lock); end; (* copier *) begin write('Stack size? '); readln(stack); write('How many file copies? '); readln(copies); for i := 1 to copies do begin write('Source: '); readln(source); write('Destination: '); readln(dest); start(copier(source,dest),pid,stack); end; end. Created at Nov 18, Fri, 22:35.39 MULTI:CONCTEST12.TEXT program montest; uses (*$U multisupp.code *) multisupport; type buftype = record m :monitor; txt :string; hastxt :boolean; change :event; end; var buffer :buftype; pid :processid; stack :integer; procedure initbuffer(var buffer:buftype); begin write('Initbuffer'); with buffer do begin initmonitor(m); write('.'); initevent(change,m); writeln('.'); hastxt := false; end; end; (* monitor *) procedure getline(var line :string); begin with buffer do begin entermonitor(m); while not hastxt do await(change); line := txt; hastxt := false; cause(change); exitmonitor(m); end; end; (* monitor *) procedure putline(line :string); begin with buffer do begin entermontior(m); while hastxt do await(change); txt := line; hastxt := true; cause(change); exitmonitor(m); end; end; process screenmanager; var line :string; begin while true do begin getline(line); writeln(line); end; end; process printout(line :string); begin while true do putline(line); end; begin initbuffer(buffer); moveleft(buffer.m,stack,2); writeln('Monitor ',stack); moveleft(buffer.change,stack,2); writeln('Event ',stack); write('Stack size? '); readln(stack); write('Starting'); start(screenmanager,pid,stack,128); write('.'); start(printout('UPPERCASE LETTERS'),pid,stack); write('.'); start(printout('lowercase letters'),pid,stack); write('.'); start(printout('*****************'),pid,stack); writeln('.'); end. Created at Nov 18, Fri, 22:36.01 MULTI:CONCTEST14.TEXT program test; (* Test asynchronus input *) uses (*$U multisupp.code *) multisupport; var nullid :processid; txt :packed array[1..10] of char; i :integer; procedure rs232; external; procedure clock; external; procedure ledoff; external; process null; begin while true do rs232; end; begin start(null,nullid,200,10); repeat writeln('Enter 10 characters'); write(' '); for i := 1 to 10 do begin clock; txt[i] := charecho; end; clock; writeln; writeln('Got a line!'); writeln('I can repeat it ten times'); for i := 1 to 10 do writeln('It was ',txt); writeln('Code report'); for i := 1 to 10 do write(ord(txt[i]),' '); writeln; until txt='SSSSSSSSSS'; kill(nullid); ledoff; end. Created at Nov 18, Fri, 22:36.14 MULTI:CONCTEST15.TEXT program tester; uses (*$U multisupp.code *) multisupport; type messagedata = string; (* For mailbox *) (*$I mailtype.text *) var buffer :mailbox; (*$I mailcode.text *) process screenmanager; var line :message; begin while true do begin getmessage(buffer,line); writeln(line^); dispose(line); end; end; process putline(line :string); var i :integer; txt :message; begin while true do begin new(txt); txt^ := line; putmessage(buffer,txt); end; end; (* putline *) begin initlimitedmailbox(buffer,30); start(screenmanager); start(putline('FIRST KEEPS ON')); start(putline('second here too')); start(putline('*******')); end. Created at Nov 18, Fri, 22:36.27 MULTI:CONCTEST16.TEXT program test; (* Used to test monitors, background tasks and asynchronus input *) uses support, sprite, multiscreen, multisupport; type counttype = record m :monitor; fifty, hundred :event; value :integer; end; var counter :counttype; pid0, pid1, pid2, pid3, pid4 :processid; command :char; stop :boolean; process upcount; begin while true do with counter do begin entermonitor(m); value := value+1; if (value mod 200)=0 then cause(hundred); if (value mod 50)=0 then cause(fifty); exitmonitor(m); end; (* with *) end; (* upcount *) process beeper; (* Once used to beep, but moves a sprite now *) var x :integer; begin x := 0; while true do begin set_spr_attribute(1,62,2,0,20,x,0,0); with counter do begin entermonitor(m); await(hundred); exitmonitor(m); end; x := (x+5) mod 256; end; (* while *) end; (* beeper *) process movesprite; var x :integer; begin set_spr_size(1); x := 0; while true do begin set_spr_attribute(0,42,15,0,0,x,0,0); with counter do begin entermonitor(m); await(fifty); exitmonitor(m); end; x := (x+1) mod 256; end; (* while *) end; (* movesprite *) process rotate; (* Rotates a sprite by repeatedly giving it a new definition *) var charno :integer; begin set_pattern(128,'10101010101010'); set_pattern(129,'02040810204080'); set_pattern(130,'000000FF'); set_pattern(131,'80402010080402'); while true do begin for charno := 128 to 131 do set_spr_attribute(2,charno,1,0,15,210,0,0); end; (* while *) end; (* rotate *) process flyer; (* Moves one sprite fast over the screen *) var x :integer; begin set_pattern(136,'20904824489020'); x := 0; while true do begin set_spr_attribute(3,136,15,0,30,x,0,0); x := (x+1) mod 256; end; (* while *) end; (* flyer *) procedure explain; begin writeln('Press'); writeln(' R - to read the counter'); writeln(' C - to change the counter'); writeln(' S - to stop the program'); writeln(' H - to display this text'); writeln; end; procedure initcounter; begin with counter do begin initmonitor(m); initevent(hundred,m); initevent(fifty,m); value := 0; end; end; (* initcounter *) procedure interpreter(command :char; var stop :boolean); var newval :integer; found :boolean; begin found := false; case command of 'R','r' :begin with counter do begin entermonitor(m); writeln('Value is ',value); exitmonitor(m); end; found := true; end; (* R *) 'C','c' :begin write('Enter new value: '); newval := readint; writeln; with counter do begin entermonitor(m); value := newval; exitmonitor(m); end; found := true; end; (* C *) 'H','h' :begin explain; found := true; end; 'S','s' :begin stop := true; found := true; end; end; (* case *) if not found then writeln('Unknown command: ',command); end; (* interpreter *) procedure pidout(pid :processid); (* Writes a pid on the screen *) type dual = record case boolean of true :(id :processid); false:(int:integer); end; (* dual *) var mix :dual; longer :integer[10]; begin mix.id := pid; longer := mix.int; if longer<0 then longer := longer+65536; writeln(longer); end; (* pidout *) begin initcounter; set_screen(2); start(rotate,pid0,200,20); start(upcount,pid1,200,20); start(beeper,pid2); start(movesprite,pid3); start(flyer,pid4,200,20); writeln; writeln('Process id report'); pidout(pid0); pidout(pid1); pidout(pid2); pidout(pid3); pidout(pid4); writeln; explain; stop := false; repeat write('Command -> '); command := charecho; writeln; interpreter(command,stop); until stop; kill(pid0); kill(pid1); kill(pid4); kill(pid2); kill(pid3); set_screen(1); (* Easy to see if this point is reached *) end. Created at Nov 18, Fri, 22:37.19 MULTI:CONCTEST17.TEXT program mailtest; uses random, multisupport; type messagedata = integer; (*$I mailtype.text *) var testbox :mailbox; pid1, pid2 :processid; stack :integer; prod, cons :text; (*$I mailcode.text *) process producer; var mess :message; i :integer; begin writeln(prod,'Producer record'); for i := 1 to 100 do begin new(mess); mess^ := rnd_int(100); writeln(prod,'Value ',i,' is ',mess^); writeln(i); putmessage(testbox,mess); delay(20); end; close(prod,lock); end; (* producer *) process consumer; var mess :message; i :integer; begin writeln(cons,'Consumer record'); for i := 1 to 100 do begin getmessage(testbox,mess); writeln(cons,'Value ',i,' is ',mess^); dispose(mess); delay(40); end; close(cons,lock); end; (* consumer *) begin randomize; initmailbox(testbox); write('Stack size? '); readln(stack); writeln('Starting'); rewrite(cons,'dacons.text'); rewrite(prod,'daprod.text'); start(producer,pid1,stack); start(consumer,pid2,stack); end. Created at Nov 18, Fri, 22:37.36 MULTI:CONCTEST18.TEXT program mailtest; uses random, multisupport; type messagedata = integer; (*$I mailtype.text *) var testbox :mailbox; pid1, pid2 :processid; screen :semaphore; stack :integer; (*$I mailcode.text *) process producer; var mess :message; i :integer; begin for i := 1 to 100 do begin writeln('New in producer'); new(mess); mess^ := rnd_int(100); wait(screen); writeln('Producer value ',i,' is ',mess^); signal(screen); putmessage(testbox,mess); delay(15); end; end; (* producer *) process consumer; var mess :message; i :integer; begin for i := 1 to 100 do begin getmessage(testbox,mess); wait(screen); writeln('Consumer value ',i,' is ',mess^); signal(screen); writeln('Dispose in consumer'); dispose(mess); delay(35); end; end; (* consumer *) begin randomize; initmailbox(testbox); seminit(screen,1); write('Stack size? '); readln(stack); writeln('Starting'); start(producer,pid1,stack); start(consumer,pid2,stack); end.