From:	CRDGW2::CRDGW2::MRGATE::"SMTP::CRVAX.SRI.COM::RELAY-INFO-VAX" 22-MAY-1991 12:19:09.23
To:	ARISIA::EVERHART
CC:	
Subj:	was "tasking in VMS" now CONTEXT 1/2

From:	RELAY-INFO-VAX@CRVAX.SRI.COM@SMTP@CRDGW2
To:	Everhart@Arisia@MRGATE

Received:  by crdgw1.ge.com (5.57/GE 1.97)
	 id AA24997; Wed, 22 May 91 12:04:15 EDT
Message-Id:  <9105221604.AA24997@crdgw1.ge.com>
Received: From scfb.nwc.navy.mil ([26.3.0.85]) by CRVAX.SRI.COM with TCP; Wed, 22 MAY 91 07:37:52 PDT
Date: 22 May 91 07:36:00 PDT
From: "351M::LEVINE" <levine%351m.decnet@scfb.nwc.navy.mil>
Subject: was "tasking in VMS" now CONTEXT 1/2
To: "info-vax" <info-vax@kl.sri.com>

Jeff
	A user at my site had a similar request a while back, only his
language was Fortran. I wrote the following macro-32 code to handle the
context switching. Each context has its own stack and if yours gets too
large, you may have to increase the canned size.
	I'm sending two files in VMS_SHARE format (2 parts), CONTEXT.MAR
with all the documentation included in the source file, and TEST.FOR to
demonstrate the context switching. No priv's are required.

Michael N. LeVine  Naval Weapons Center, China Lake, Ca 93555, USA
Internet: levine%fidler.decnet@scfb.nwc.navy.mil,levine%fidler.decnet@26.3.0.85
(619) 939-2614  avn  437-2614 

 "Waiter, there's a bug in my soup!"        
 "No, Sir, it's not a bug, it's a feature!" 

$! ------------------ CUT HERE -----------------------
$ v='f$verify(f$trnlnm("SHARE_VERIFY"))'
$!
$! This archive created by VMS_SHARE Version 7.2-007  22-FEB-1990
$!   On 22-MAY-1991 07:16:39.13   By user LEVINE 
$!
$! This VMS_SHARE Written by:
$!    Andy Harper, Kings College London UK
$!
$! Acknowledgements to:
$!    James Gray       - Original VMS_SHARE
$!    Michael Bednarek - Original Concept and implementation
$!
$!+ THIS PACKAGE DISTRIBUTED IN 2 PARTS, TO KEEP EACH PART
$!  BELOW 30 BLOCKS
$!
$! TO UNPACK THIS SHARE FILE, CONCATENATE ALL PARTS IN ORDER
$! AND EXECUTE AS A COMMAND PROCEDURE  (  @name  )
$!
$! THE FOLLOWING FILE(S) WILL BE CREATED AFTER UNPACKING:
$!       1. CONTEXT.MAR;30
$!       2. TEST.FOR;10
$!
$set="set"
$set symbol/scope=(nolocal,noglobal)
$f=f$parse("SHARE_TEMP","SYS$SCRATCH:.TMP_"+f$getjpi("","PID"))
$e="write sys$error  ""%UNPACK"", "
$w="write sys$output ""%UNPACK"", "
$ if f$trnlnm("SHARE_LOG") then $ w = "!"
$ ve=f$getsyi("version")
$ if ve-f$extract(0,1,ve) .ges. "4.4" then $ goto START
$ e "-E-OLDVER, Must run at least VMS 4.4"
$ v=f$verify(v)
$ exit 44
$UNPACK: SUBROUTINE ! P1=filename, P2=checksum
$ if f$search(P1) .eqs. "" then $ goto file_absent
$ e "-W-EXISTS, File ''P1' exists. Skipped."
$ delete 'f'*
$ exit
$file_absent:
$ if f$parse(P1) .nes. "" then $ goto dirok
$ dn=f$parse(P1,,,"DIRECTORY")
$ w "-I-CREDIR, Creating directory ''dn'."
$ create/dir 'dn'
$ if $status then $ goto dirok
$ e "-E-CREDIRFAIL, Unable to create ''dn'. File skipped."
$ delete 'f'*
$ exit
$dirok:
$ w "-I-PROCESS, Processing file ''P1'."
$ if .not. f$verify() then $ define/user sys$output nl:
$ EDIT/TPU/NOSEC/NODIS/COM=SYS$INPUT 'f'/OUT='P1'
PROCEDURE Unpacker ON_ERROR ENDON_ERROR;SET(FACILITY_NAME,"UNPACK");SET(
SUCCESS,OFF);SET(INFORMATIONAL,OFF);f:=GET_INFO(COMMAND_LINE,"file_name");b:=
CREATE_BUFFER(f,f);p:=SPAN(" ")@r&LINE_END;POSITION(BEGINNING_OF(b));
LOOP EXITIF SEARCH(p,FORWARD)=0;POSITION(r);ERASE(r);ENDLOOP;POSITION(
BEGINNING_OF(b));g:=0;LOOP EXITIF MARK(NONE)=END_OF(b);x:=ERASE_CHARACTER(1);
IF g=0 THEN IF x="X" THEN MOVE_VERTICAL(1);ENDIF;IF x="V" THEN APPEND_LINE;
MOVE_HORIZONTAL(-CURRENT_OFFSET);MOVE_VERTICAL(1);ENDIF;IF x="+" THEN g:=1;
ERASE_LINE;ENDIF;ELSE IF x="-" THEN IF INDEX(CURRENT_LINE,"+-+-+-+-+-+-+-+")=
1 THEN g:=0;ENDIF;ENDIF;ERASE_LINE;ENDIF;ENDLOOP;t:="0123456789ABCDEF";
POSITION(BEGINNING_OF(b));LOOP r:=SEARCH("`",FORWARD);EXITIF r=0;POSITION(r);
ERASE(r);x1:=INDEX(t,ERASE_CHARACTER(1))-1;x2:=INDEX(t,ERASE_CHARACTER(1))-1;
COPY_TEXT(ASCII(16*x1+x2));ENDLOOP;WRITE_FILE(b,GET_INFO(COMMAND_LINE,
"output_file"));ENDPROCEDURE;Unpacker;QUIT;
$ delete/nolog 'f'*
$ CHECKSUM 'P1'
$ IF CHECKSUM$CHECKSUM .eqs. P2 THEN $ EXIT
$ e "-E-CHKSMFAIL, Checksum of ''P1' failed."
$ ENDSUBROUTINE
$START:
$ create 'f'
X`09.title`09context_switch
X`09.subtitle`09declarations
X`09.ident`09/v01.4/
X`09.enable`09global
X`09.enable`09debug
X;
X;`09this macro subroutine is used to simulate context
X;`09switching between subroutines.
X;
X;`09The context switching is started by calling the`20
X;`09entry point CONTEXT_SWITCH
X;
X;`09this proceedure in turn calls`20
X;`09`09get_active_task`09-Integer function-no arguments
X;`09`09`09returns either
X;`09`09`09`090 (all done)
X;`09`09`09`09positive number indicateing what`20
X;`09`09`09`09`09subroutine to context switch to.
X;`09`09`09`09`09(or call if it has not been started)
X;`09`09`09`09negative number indicateing that the current
X;`09`09`09`09`09context of the indicated subroutine
X;`09`09`09`09`09is to be discarded and the routine
X;`09`09`09`09`09is to be entered as if it were
X;`09`09`09`09`09being called for the first time(via
X;`09`09`09`09`09begin_task)
X;`09`09`09This is a user supplied routine.
X;`09`09begin_task -subroutine-one argument (by reference)
X;`09`09`09a user supplied subroutine that is passed
X;`09`09`09the task number  and it in turn calls the
X;`09`09`09subroutine at its entry point. When the called
X;`09`09`09routine returns from the call, the subroutine is
X;`09`09`09considered to have finished its work and is marked
X;`09`09`09inactive. This proceedure must be reenterent.
X;
X;`09When a subroutine finds it is time for it to stop for a while
X;`09and let another context switch in, it calls the entry point
X;`09in this proceedure CONTEXT_SWITCH. When it is time to continue
X;`09executing the subroutine, it will contine at the next line
X;`09following the call to context_switch
X;
X;
X;`09context block structure declarations
X;
X`09ctx_l_fp`09=`090`09;saved fp of subr
X`09ctx_l_ap`09=`094`09;saved ap of subr
X`09ctx_l_sp`09=`098`09;saved sp of subr
X`09ctx_l_r0`09=`0912`09;saved r0 of subr
X`09ctx_l_r1`09=`0916`09;saved r1 of subr
X`09ctx_l_status`09=`0920`09;current subr status
X`09`09ctx_not_running`09=`090
X`09`09ctx_running`09=`091
X`09ctx_l_number`09=`0924`09;context block number
X`09ctx_stack_length`09=`09<1500*4>`09;stack for this context
X`09ctx_length`09=`0928 + ctx_stack_length`09;length of context blocvk
X`09ctx_l_stack`09=`09ctx_length`09;starting loc of stack
X
X`09num_of_tasks`09=`0950`09`09;this is the max number of
X`09`09`09`09`09`09;subroutines that will be called
X`09`09`09`09`09`09;and context switch
X
X;
X;`09define macros
X;
X;`09this macro is used to build the pointer table
X;`09it is invoked once per context block.
X;
X`09.macro`09build_address`09label,number
X`09`09.address`09'label''number'
X`09.endm`09build_address
X;
X;`09this macro is used to put a label on each context block
X;
X`09.macro`09build_label`09label,number
X'label''number':
X`09.endm`09build_label
X`09.page
X`09.subtitle`09build pointer tables
X`09.psect`09pointer_tables,rd,nowrt,noexe,shr,gbl,page
X;
X;`09this is a table of pointers to the context blocks.
X;`09by useing this table, it is much easyer to find the new
X;`09context block
X;
X;`09the context blocks are numbered 0-num_of_tasks, where
X;`09context 0 is that of the main program as it called`20
X;`09run_ts.
X;
Xcontext_table:
Xi=0
X`09.repeat`09<num_of_tasks+1>
X`09`09build_address`09ctx_,\i
X`09`09i=i+1
X`09.endr
X`09.page
X`09.subtitle`09build context blocks
X`09.psect`09context_blocks,rd,wrt,noexe,shr,gbl,page
X;
X;`09these are the context blocks, holding the current context
X;`09status and stacks for each subroutine
X;
Xi=0
X`09.repeat`09<num_of_tasks+1>
X`09`09build_label`09ctx_,\i
X`09`09.blkb`09`09ctx_length
X`09`09i=i+1
X`09.endr
X`09.page
X`09.subtitle`09local data area
X`09.psect`09data,rd,wrt,noexe,shr,gbl,page
Xactive_tasks:`09`09.long`090`09;how many tasks are active
Xcurrent_active_task:`09.long`090`09;task number of current active task
Xcurrent_active_block:`09.long`090`09;pointer to context block of current tak
Vs
X`09.page
X`09.subtitle`09initial entry point from main program
X`09.psect`09code,rd,nowrt,exe,shr,gbl,page
X;
X;`09initalization entry point for context switching progam
X;`09called only once
X;
X`09.entry`09run_ts,`5Em<r2,r3,r4,r5,r6,r7,r8,r9,r10,r11>
X;
X;`09init all data areas
X;
X`09moval`09context_table,r11`09;get addr of context block
X`09`09`09`09`09;pointer table
X`09movl`09#<num_of_tasks+1>,r10`09;init counter to number of blocks
X;
X;`09start init of context block 0
X;
X`09movl`09r0,context_table+ctx_l_r0(r11)`09;load current r0
X`09movl`09r1,context_table+ctx_l_r1(r11)`09;load current r1
X;
X;`09start of per block init loop
X;
X1$:`09`09movl`09(r11)+,r9`09;get addr of context block
X`09`09movl`09#ctx_not_running,ctx_l_status(r9) ;initial status
X`09`09`09`09`09;of all blocks is subr not started yet
X`09`09subl3`09r10,#<num_of_tasks+1>,ctx_l_number(r9)`09;block number
X`09`09moval`09ctx_l_stack-20(r9),r0`09;get addr of stack after
X`09`09movl`09r0,ctx_l_sp(r9)`09`09;a false call frame has been`20
X`09`09movl`09r0,ctx_l_fp(r9)`09`09;added and set new sp/fp
X`09`09; the next 5 moves inits the stack with a phony call frame
X`09`09; this is needed for traceback and debugger to work
X`09`09; properly.
X`09`09movl`09(fp),(r0)`09;condition handler
X`09`09movl`094(fp),4(r0)`09;psw/reg mask/s flag/longword alignment
X`09`09movl`098(fp),8(r0)`09;saved ap
X`09`09movl`0912(fp),12(r0)`09;saved fp
X`09`09movl`0916(fp),16(r0)`09;saved pc
X;`09`09any saved registers flagged in the reg mask not put in
X`09`09decl`09r10`09`09;dec block counter
X`09`09bgtr`091$`09`09; repeat till done
X;
X;`09finish set up context block 0 for proper return to calling routine
X;`09after all subr's have completed
X;
X`09movl`09context_table,r11`09;get addr of context block 0
X`09movl`09fp,ctx_l_fp(r11)`09;load current fp
X`09movl`09ap,ctx_l_ap(r11)`09;load current ap
X`09movl`09sp,ctx_l_sp(r11)`09;load current sp
X;
X;`09other setup
X;
X`09clrl`09active_tasks`09`09;no tasks are active yet
X`09clrl`09current_active_task`09;current active task is context 0
X`09movl`09context_table,current_active_block`09;pointer to ctx_0
X;
X;`09now go enter the context switch code
X;
X`09brw`09get_next_task
X`09.page
X`09.subtitle`09context switch
X`09.entry`09context_switch,`5Em<r2,r3,r4,r5,r6,r7,r8,r9,r10,r11>
X;
X;`09called by subr when it is ready to sleep for a while and let
X;`09another subr take over.
X;
X;`09save context
X;
X`09movl`09current_active_block,r11`09;get addr of current context blk
X`09movl`09fp,ctx_l_fp(r11)`09`09;save current fp
X`09movl`09ap,ctx_l_ap(r11)`09`09;save current ap
X`09movl`09sp,ctx_l_sp(r11)`09`09;save current sp
X`09movl`09r0,ctx_l_r0(r11)`09`09;save current r0
X`09movl`09r1,ctx_l_r1(r11)`09`09;save current r1
X;
X;`09call user supplied high order language routine
X;`09to determine what the next subroutine is to be called.
X;`09the user routine must be an integer function returing
X;`09the task number of the next subr to run
X;
Xget_next_task:
X`09calls`09#0,get_active_task`09;ask user routine for next subr to run
X`09tstl`09r0`09;test the return value
X`09blss`09reset`09;value .lt.0 is reset context and restart
X`09bgtr`091$
X`09brw`09done`09;value .eq.0 means all done-return to
X;`09`09`09;calling routine
X1$:`09cmpl`09#num_of_tasks,r0`09;see if number too large
X`09blss`09get_next_task`09`09;if too high-try agin
X;
X;`09get the context block of selected subr and set context
X;
X`09movl`09context_table`5Br0`5D,r11`09;get pointer to new context block
X`09movl`09r0,current_active_task`09;set up pointers and data structures
X`09movl`09r11,current_active_block`09;for new current context
X;
X;`09check to see if subr already running or done
X;
X`09cmpl`09#ctx_not_running,ctx_l_status(r11)
X`09beql`09start_task`09;if-not start it
X;
X;`09subr already running-switch context and let it continue
X;
X;`09restore the key context registers (ap,sp,fp) to the same`20
X;`09values that then had when this subroutine called
X;`09context_switch.
X;
X`09movl`09ctx_l_ap(r11),ap`09;restore ap
X`09movl`09ctx_l_sp(r11),sp`09;restore sp
X`09movl`09ctx_l_fp(r11),fp`09;restore fp
X`09movl`09ctx_l_r0(r11),r0`09;restore r0
X`09movl`09ctx_l_r1(r11),r1`09;restore r1
X`09ret`09;continue in subr at line following call context_switch
X;
X;`09reset a task here then fall through to start it
X;
Xreset:
X`09mnegl`09r0,r1
X`09cmpl`09#num_of_tasks,r1`09;see if number too large
X`09blss`09get_next_task`09`09;if too high-try agin
X`09movl`09context_table`5Br1`5D,r11`09;get pointer to new context block
X;
X;`09get the context block of selected subr and set context
X;
X`09movl`09r1,current_active_task`09;set up pointers and data structures
X`09movl`09r11,current_active_block`09;for new current context
X`09cmpl`09#ctx_not_running,ctx_l_status(r11)
X`09beql`09start_task
X;
X;`09reinit the context block as if new
X;
X`09moval`09ctx_l_stack-20(r11),r2`09;get addr of stack after
X`09movl`09r2,ctx_l_sp(r11)`09;a false call frame has been`20
X`09movl`09r2,ctx_l_fp(r11)`09;added and set new sp/fp
X;
X;`09traceback info on stack should not have been diddled
X;
X;`09other cleanup
X;
X`09decl`09active_tasks
X;
X;`09when a subr is first called-do it here
X;
Xstart_task:
X`09incl`09active_tasks`09`09;up the active subr counter
X`09movl`09#ctx_running,ctx_l_status(r11)
X`09movl`09ctx_l_sp(r11),sp`09;init both the sp and fp
X`09movl`09ctx_l_sp(r11),fp`09;the sp points to the new stack
X`09`09`09`09`09;dedicated to this context. Stack
X`09`09`09`09`09;has pseudo call frame so that
X`09`09`09`09`09;fp is consistent with sp when
X`09`09`09`09`09;error condition causes traversial
X`09`09`09`09`09;back down the stack looking for
X`09`09`09`09`09;traceback handler
X`09pushal`09ctx_l_number(r11)`09;pass by reference the subr number
X`09calls`09#1,begin_task`09`09;call high level lang routine to
X`09`09`09`09`09;call subr. when subr is done, it
X`09`09`09`09`09;will return here
X;
X;`09subroutine begin_task(i)
X;`09if(i.eq.1)then
X;`09`09call a
X;`09elseif(i.eq.2)then
X;`09`09call b
X;`09.
X;`09.
X;`09else
X;`09`09error-action
X;`09endif
X;`09return
X;`09end
X;
X;`09clean up after completed subr
X;
X`09decl`09active_tasks`09`09;this one is done-dec active count
X`09movl`09#ctx_not_running,ctx_l_status(r11)`09;set status as done
X`09movl`09current_active_block,r11`09;get addr of current context blk
X`09movl`09fp,ctx_l_fp(r11)`09`09;save current fp
X`09movl`09ap,ctx_l_ap(r11)`09`09;save current ap
X`09movl`09sp,ctx_l_sp(r11)`09`09;save current sp
X`09movl`09r0,ctx_l_r0(r11)`09`09;save current r0
X`09movl`09r1,ctx_l_r1(r11)`09`09;save current r1
X`09brw`09get_next_task`09`09`09; go get next subr to run
X`09.page
X`09.subtitle`09exit
X;
X;`09done with all subrs-exit
X;
X;`09restore original context of that of call to initialize`20
X;`09context switching and return to original caller
X;
Xdone:`09movl`09context_table,r11`09;get context block 0
X`09movl`09ctx_l_ap(r11),ap`09;restore ap
X`09movl`09ctx_l_sp(r11),sp`09;restore sp
X`09movl`09ctx_l_fp(r11),fp`09;restore fp
X`09movl`09ctx_l_r0(r11),r0`09;restore r0
X`09movl`09ctx_l_r1(r11),r1`09;restore r1
X`09ret`09`09`09`09;context switching done
X`09`09`09`09`09;return from CALL RUN_TS
X`09.end
$ CALL UNPACK CONTEXT.MAR;30 1264474278
$ create 'f'
X`09program main
X
X`09implicit integer*4 (a-z)
X
X`09logical active(5)/5*.true./
X`09common/flags/active
X
X`09call run_ts
X
X`09stop
X`09end
X`09integer*4 function get_active_task
X
X`09implicit integer*4 (a-z)
X
X`09logical first/.true./
X
X`09logical active(5)
X`09common/flags/active
X
X`09integer*4 ii
X`09real*4    iii
X`09equivalence(ii,iii)
X`09common/random/ii
X`09if(first)then
X`09`09iii=secnds(0.0)
X`09`09first=.false.
X`09endif
X
X`09count=0
+-+-+-+-+-+-+-+-  END  OF PART 1 +-+-+-+-+-+-+-+-


