!***********
!* sup010  *
!*05.mar.82*
!***********

%control x'4001'
%externalroutinespec push(%record(*)%name q,%record(*)%name m)
%externalrecord(*)%mapspec pop(%record(*)%name q)
%constrecord (*) %name null == 0

%recordformat dummy(%integer x)


%begin
     %constinteger task low limit=30
     %constinteger task limit=75
     %constinteger free cells=80
     %constinteger no of services=task limit
     %constinteger frag no=15
     %constinteger psect length=48
     %constinteger svc limit=23
     %constinteger int limit=-90
     %constinteger k seg limit=125

     %constinteger highest priority = 3

     %constinteger ttid=30;           ! task lo limit
     %constinteger dkid=31;           !   "   "    " +1
     %constinteger dirid=32;          !   "   "    " +2
     %constinteger loadid=33;         !   "   "    " +2
     %constinteger mother=35;         !   "   "    " +4

     %constintegername ps==k'177776'; ! status word
     %constintegername stack limit==k'177774'

     %recordformat ef(%record (ef) %name link, %integer id, a1)
     %recordformat qf(%record (ef) %name e)
     %recordformat tf(%record (tf) %name link, %integer id, t)

     %recordformat ksegf((%integer use, dadd, par, pdr %or %c
     %record (ksegf) %name l, %integer b, c, d))

     %recordformat uregsf(%integer r0, r1, r2, r3, r4, r5, pc, %c
                                   ps, sp)
     %recordformat segf(%integer par, pdr, %record (ksegf) %name ksl, %c
       %integer use)
     %recordformat psectf(%record (qf) %name e,%byteinteger id, state, %c
       %byteintegerarray name(0:3), %c
       %integer prio, %record (qf) poffq, %c
       %record (uregsf) urs, %integer trapv, %c
       %record (segf) %array seg(0:7))
     %recordformat pstf(%record (psectf) %name p)

     %recordformat pf((%byte service, reply %or %integer d),  %c
       %integer a1, a2, a3)
     %recordformat mainpf(%record (pf) %name l, %record (pf) p)

     %recordformat storef(%integer len, block no)
     %recordformat addrfn(%record (addrfn) %name psecta, last32, corea)
     %constrecord (addrfn) %name adds==k'120'





     %record (ef) %name e
     %record (tf) %name t, t2, tn, tb
     %record (psectf) %name psect, psect2, psectn, psect3
     %record (segf) %name seg1, seg2
     %record (ksegf) %name ks1, ks2
     %record (ksegf) %name kl
     %externalrecord (ksegf) %name free segl
     %owninteger ipl ticks = 0

     %externalrecord (qf) %array cpuq(0:highest priority)
     !*

     %record (pf) px
     %record (pf) %name p, q
     %record (pf) %name p2, q2, pxp
     %record (mainpf) %name mainp, mp2
     %externalrecord (mainpf) %name free param
     %record (tf) time q;             ! head of timer list

     %integer qu, service, ticks, len, i, pt, l2, block, s, id, call seg
     %integer par, pdr



     %externalrecord (pstf) %array psecta(task low limit:task limit)
     %externalrecord (tf) %array ontmq(task low limit:task limit)

     %externalrecord (mainpf) %array params(0:free cells)

     %externalrecord (storef) %array store(0:frag no)
     %record (storef) %name st1, st2

     %externalrecord (ksegf) %array ksegl(1:k seg limit)

!     %externalrecord (pf) %array last thirty2(0:15);  %owninteger last=0

      %externalintegerarray display %alias "@DISPLAY" (0:8)

     %externalbyteintegerarray ser map(int limit:no of services)= %c
        0(80), 0, 0, 0, 0, 0, 0, mother, dkid, ttid, ttid, 0,
         ttid, 0, dkid, dirid, loadid, 0, mother, 0(68)

     %constinteger fault ser=-4
     !!   tu 16 int = -5
     !!   dqs11 tx int = -6
     !!   dqs11 rx int = -7




     %systemintegerfnspec run
     %externalroutinespec initialise

     !! %permroutinespec push(%record (qf) %name q, %record (ef) %name e)
     !! %permrecord (qf) %mapspec pop(%record (qf) %name q)

     !*
     %routinespec schedule
     %routinespec deallocate(%record (ksegf) %name ks)
     %routinespec fault(%integer i)

     !***********************************************
     !*          supervisor states                  *
     !***********************************************
     %constinteger idle st=-1
     %constinteger task st=0

     !**********************************************
     !*                task states                 *
     !**********************************************
     %constinteger t wait=1
     %constinteger t poff=2
     %constbyteinteger t cpuq=8
     %constbyteinteger t run=16
     %constbyteinteger t susp=k'200'


     !***********************************************
     !*         svc services (by emt value)         *
     !***********************************************
     %constinteger interrupt=-1
     %constinteger wait=1
     %constinteger pon r=2
     %constinteger poff r=3
     %constinteger insert=4
     %constinteger delete=5
     %constinteger allocate core=6
     %constinteger freesp=7
     %constinteger set time=8
     %constinteger schedule t=9
     %constinteger map virt=10
     %constinteger get abs=11
     %constinteger get id=12
     %constinteger linkin=13
     %constinteger map shared=14
     %constinteger map hregs=15
     %constinteger map psect=16
     %constinteger ponpoff=17
     %constinteger set prio=18
     %constinteger set t bit = 19
     %constinteger toff = 20
      %constinteger gpspec = 21
     %constinteger dptab = 22
     %constinteger time ser = 23


     !************************************************
     !*          static core locations               *
     !************************************************
     %constintegername int value==k'40'
     %constintegername alarm f==k'44'
     %constrecord (pstf) %name psectx == k'46'
     %constintegername psect area==k'50'
     %constintegername fault type==k'52'
     %constrecord (pstf) %name last psect == k'54'
      %constrecord (mainpf) %name pxp pt == k'56';  ! points to px&pxp

     %constintegername svcaddress == k'30'
     !*************************************************
     %switch ser(-1:svc limit)

     %constintegerarrayname u par == k'177640'
     %constintegerarrayname u pdr == k'177600'


     !***************************************************
     !*            start of code proper                 *
     !***************************************************

     initialise;                ! held in de-allocatable space


     !*****************************************************
     !*            basic loop is cpu scheduler            *
     !*****************************************************

     *=K'013700'; *=K'30';  ! mov svc, r0
     *=K'010540';          ! mov r5, -(r0)
     *=K'010440';          ! mov r4, -(r0)
     pxp == px; pxp pt_l == pxp; px_reply = 0
     %cycle
      %if %not cpuq(3)_e == null %start
         psect == pop(cpuq(3))
      %else
         %if %not cpuq(2)_e == null %start
            psect == pop(cpuq(2))
         %else
            %if %not cpuq(1)_e == null %start
               psect == pop(cpuq(1))
            %else
               %if %not cpuq(0)_e == null %start
                  psect == pop(cpuq(0))
               %else
                  !! nothing to do
                  psect == null;  psectx_p == null
                  ->go2
               %finish
            %finish
         %finish
      %finish
go:  %if psect_state&t susp#0 %thencontinue;  ! don't run it
     psect_state=t run
     psectx_p == psect
go2: service=run;                   ! external routine
     ->ser(service) %if service<=svc limit
     fault type=5
error:
     int value=fault ser

ser(interrupt):             ; ! device interrupt
     %if int value#fault ser %start
        schedule %unless psect == null
     %else
        px_a2=psect_id
        px_a3=fault type
     %finish
     -> clockint %if int value = 0
     id=ser map(int value)
     px_service=int value
     p==pxp
     !* and send it
     !! send mess to relevant task
     ->do pon

ser(wait):
     psect_state=t wait
     %continue;                   ! find something else

ser(pon r):
ser(ponpoff):;                ! pon-poff from user
     p == psect_urs;           ! map param area to his regs
     !* now plant on q
     !* and schedule process if necessary
     id=ser map(p_service);           ! and find the owning process
do pon:
     psect3==psecta(id)_p;        ! psect of receiving message
     %if psect3==null %or id=0 %start
        fault type=6;  px_a1 = p_service
        -> error
     %finish
     q==psect3_urs
     %if psect3_state&t poff#0 %and %c
        (q_service=0 %or psect3_urs_r0=p_d) %start

        !! is waiting for poff, and is the correct message

         psect3_state = (psect3_state&t susp)!t cpuq; ! code of schedule
         push(cpuq(psect3_prio), psect3)

pon execute:
           q = p
           ! last thirty2(last)=p;  ! last=(last+1)&15
     %else
        mainp==free param;          ! pick up new param cell
        fault(9) %if mainp == null
        free param==mainp_l;        ! relink free list
        mainp_p = p
        push(psect3_poffq, mainp);    ! put on task poff q
      %finish
      %if service < 0 %then %continue;  ! (=interrupt)do a prio scan
      %if service#ponpoff %then ->go2;  ! pon or poff, so just reenter
      
      !**************************************************************
      !  this section is dependent on the format of psectf
      *=K'013700';  *=K'54';  ! mov last psect, r0
      *=K'000360';  *=K'14';    ! swab(last psect_urs_r0)
      ! would be preferable in imp, but would cost at least 10 words
      !**************************************************************

ser(poff r):;             ! user poff
     %unless psect_poffq_e==null %start; ! q non zero
        mp2==psect_poffq_e;    ! get last entry
        q==psect_urs
        %cycle;       ! cycle whole q
           mainp==pop(psect_poffq)
           p==mainp_p
           %if q_service=0 %or q_d = p_d %start
              mainp_l==free param;  free param==mainp; ! relink on q
              ->pon execute
           %finish
           push(psect_poffq, mainp)
        %repeat %until mp2 == mainp
     %finish
     psect_state=t poff
     %continue


ser(schedule t):                ! r0 is id of task to be scheduled
     i = psect_urs_r1; ! 0 = sch, 1 = hold, x = addr
     schedule;     ! re-schedule caller
     psect==psecta(psect_urs_r0)_p
     fault(7) %if psect==null
     %if i&1 = 0 %start
        psect_state = psect_state&(\t susp); ! ensure not suspended
        %if i # 0 %start;            ! force neww address and start up
           psect_urs_pc = i
        %else
           %if psect_state&t poff # 0 %then %continue
        %finish
        schedule
     %else
        psect_state = psect_state!t susp;  ! susp it
     %finish
        %continue

ser(delete):                      ! delete the running task
         i = psect_urs_r0
        %if psect_id<=loadid+1 %or i # 0 %start
           schedule;     ! re-schedule loader
           psect==psecta(i)_p
        %finish
        %cycle;                  ! clear out the poff q
           mainp==pop(psect_poffq)
           %exitif mainp==null
           mainp_l==free param;  free param==mainp
        %repeat
       %cycle i=7, -1, 0;         ! go down the segs
           ks1==psect_seg(i)_ksl
           %unless ks1 == null %start
              ks1_use=ks1_use-1
              deallocate(ks1) %if ks1_use=0
           %finish
        %repeat
        psecta(psect_id)_p==null


search cpu q:
     %continue

clockint:                        ! clock has ticked
     ipl ticks = ipl ticks+1
     %if alarmf # 0 %start
        alarmf = alarmf-1
        %if alarmf = 0 %start
           !* send message to first task on q
           !* set clock to next time
           tn==pop(time q)
           %unless timeq_link==null %start
              alarm f=timeq_link_link_t
              %if alarmf=0 %then alarmf=1
           %finish
           id=tn_id
           px_service=id;  px_reply=0
           p==px;  tn_t=0
           ->do pon
        %finish
     %finish

     %repeat;                    ! of main loop

ser(set time):                         ! set timer for urs_r0 ticks
     id=psect_id
     tn==ontmq(id)
     ticks=psect_urs_r0;          ! no of ticks
     %if ticks=0 %or ontmq(id)_t#0 %then fault type=7 %and ->error
     tb==timeq_link;                     ! last entry
     ->bot %if tb==null
     t==tb_link;  ! point to first entry, if only one it is a looped pointer
     t_t=alarm f;       ! adjust for time past
     t2==tb
     %cycle;                          ! check the list
        %if ticks<t_t %start;        ! put on q here
           tn_link==t2_link;  t2_link==tn
           t_t=t_t-ticks
           %exit
        %finish
        ticks=ticks-t_t
        %if t==tb %start;             ! at bottom
bot:       push(timeq, tn);           ! plant on end
           %exit
        %finish
        t2==t
        t==t2_link
     %repeat
     tn_t=ticks
     alarm f = timeq_link_link_t
     ->go;                            ! immediate reschedule

ser(time ser):
        psect_urs_r0 = ipl ticks
        ->go;                         ! immediate reschedule

ser(allocate core):
     last psect_p == null;    ! must reload seg regs on exit
     st1 == null
     %if psect_id <= loadid %start
        len=psect_urs_r0;                ! core required in blocks
        psect_urs_r0=0;                  ! urs_r1 is the new seg
        l2=k'77777'
        %cycle i=frag no, -1, 0
           st2 == store(i)
           %if st2_len>=len %and st2_len<l2 %then %c
             st1 == st2 %and l2=st2_len
        %repeat
     %finish
     %if st1 == null %or free segl == null %then ->go;    ! no core
        par=st1_block no;           ! address of block (in blocks)
        %if l2>len %start;            ! excess, so trim
           st1_blockno=st1_block no+len
           st1_len=st1_len-len
        %FINISH %else st1 = 0
     kl==free segl
                    !! fault(12) - no free segment cells, now passed as no core
     free segl==kl_l
     ks1==kl;                           ! map the 'real' type on
     ks1_use=0;                         ! 'shared' will make it '1'
     s = 6
     pdr=(len-1)<<8!6
     ks1_par=par;  ks1_pdr=pdr
     call seg = psect_urs_r1
     seg1==psectn_seg(call seg)
     psect_urs_r0=block
     ->do shared;                    ! fill his seg entry
ser(get abs):                      ! get absolute address of virt seg
                                   ! r0=target id
                                   ! r1=target segment
                                   ! r2=0 - drop  =1 - get
     %if psect_urs_r2=0 %then psect_urs_r1=-1 %elsec
       psect_urs_r2=0
     !! this changes it to the format expected by map virt
     !! it is always mapped to the callers segment zero


ser(map virt):                       ! map user a to b
                                      ! r0 = target id
                                      ! r1 = target seg
                                      ! r2 = callers seg
                                      ! r1 = -1 signifies drop seg
     call seg=psect_urs_r2;        ! get callers seg no
     seg1==psect_seg(call seg)

map2:
     s=0; par=0; pdr=0
     %if psect_id=loadid %then s=6
     %if psect_urs_r1<0 %start;        ! drop segment
        ks1==seg1_ksl
        %if ks1==null %then ->mv fail;  ! no seg
        ks1_use=ks1_use-1
        %if ks1_use=0 %then deallocate(ks1)
        seg1=0;                        ! zero callers entry
     %else
        !! map to desired seg
         i = ser map(psect_urs_r0)
         -> mv fail %unless task low limit <= i <= task limit
        psect2==psecta(i)_p
        -> mv fail %if psect2==null
        ks1==psect2_seg(psect_urs_r1)_ksl
do shared:
        %unless ks1==null %start
           par=ks1_par;  pdr=ks1_pdr!s
           seg1_par=par;  seg1_pdr=pdr
           seg1_ksl==ks1
           ks1_use=ks1_use+1
        %finish
     %finish
mv fail:                    ! comes here if call fails or is ok
     psect_urs_r0=par;  psect_urs_r1=pdr;  ! pass result back

set segregs:
     upar(call seg) = par
     updr(call seg) = pdr
     ->go


ser(get id):                      ! return id of task in r0
        psect_urs_r0=psect_id
        ->go
ser(linkin):                       ! r0 is required service
     ser map(psect_urs_r0)=psect_id
     ->go

ser(map shared):                  ! r0 is id, r1=seg, r2=shared no
     psect2==psecta(psect_urs_r0)_p
     fault(8) %if psect2==null
     seg1==psect2_seg(psect_urs_r1)
      ks1 == record(psect_urs_r2);           ! loader passes address of descript
      last psect_p == null
     s=2;  call seg = 1
     ->do shared

ser(insert):                     ! allocate a new psect (and map to r0?)
     %cycle id=task low limit, 1, task limit
        -> got free %if psecta(id)_p==null
     %repeat

      psect_urs_r0 = 0;      ! pass back failed
      -> go

got free:
     psectn == record(psect area+(id-mother-1)*(psect length*2))
      psecta(id)_p == psectn
     psectn_id=id
     ser map(id)=id
     ->mps;                       ! restart loader

ser(map hregs):                  ! map hardware regs to seg r0
     seg1==psect_seg(psect_urs_r0)
        seg1_par=k'7600';  seg1_pdr=k'77406';  seg1_ksl==null
        last psect_p == null;    ! force a reload of segment regs
        ->go

ser(map psect):                 ! map psect 'r0' to seg in r1
     id = psect_urs_r0;        ! target task id
mps: call seg=psect_urs_r1
     seg1==psect_seg(call seg)
     pt=0
     %if psect_id=loadid %then pdr=2<<8!6 %else pdr=2<<8!2
      i = addr(psecta(id)_p)
     %unless par = 0 %start
         par = i>>6
        seg1_par=par;      ! map to the start of its block
        seg1_pdr=pdr;    ! access depends on task
        seg1_ksl == null
        pt=call seg<<13!(i&k'77');  ! point r0 to its beginning
     %finish
     psect_urs_r0=pt
     ->set segregs

ser(set prio):                 ! set prio between 0 and 3
     psect_prio = psect_urs_r0&3
     schedule;                 ! check a higher one not running
     ->search cpu q

ser(set t bit):                ! set the trace trap
     psect_urs_ps = psect_urs_ps!k'20'
      -> go

ser(toff):                      ! test for messages
     psect_urs_r0 = 0
     %if %not psect_poffq_e == null %then psect_urs_r0 = 1
     -> go

ser(gpspec):         ! pass a char to app tower plotter
      i = svcaddress-6;  ! pointer to gpchar
      i = integer(i);      ! i should now point to gpchar itself
      integer(i) = psect_urs_r0;  ! put charinto location
      -> go

ser(dptab):
     i = integer(svcaddress-6);          !  = 0 if no dp code in brun
     pt = psect_urs_r0;    ! target segment
     psect_urs_r0 = i
     psect_seg(pt)_par = i>>6; psect_seg(pt)_pdr = k'406'
     psect_seg(pt)_ksl == null;  last psect_p == null; ! force reload
     -> go




     %routine schedule
        psect_state=(psect_state&t susp)!t cpuq
        push(cpuq(psect_prio), psect)
     %end

     %routine deallocate(%record (ksegf) %name ks)
        %record (storef) %name s, s2, s3
        %record (ksegf) %name ksl
        %integer i, bot, block, len

        block=ks_par;  len=ks_pdr>>8+1
        bot=block+len;  s2==null
        %cycle i=frag no, -1, 0
           s==store(i)
           %if s_block no+s_len=block %start
              %if s2==null %start
                 s_len=s_len+len;   ! add it on the bottom
                 s2==s;               ! remember it
              %else
                 s_len=s_len+s2_len
                 s2 = 0
                 %exit
              %finish
           %else
              %if s_block no=bot %start
                 %if s2==null %start; ! not found the upper half
                    s_block no=block;  s_len=s_len+len
                    s2==s;         ! mark found
                 %else
                     s_block no=s2_block no
                     s_len=s_len+s2_len
                     s2_block no=0;  s2_len=0
                    %exit
                 %finish
              %finish
           %finish
           %if s_block no=0 %then s3==s; ! remember empty slot
        %repeat
        %if s2==null %start
           s3_block no=block;  s3_len=len
        %finish
        ksl==ks
        ksl_l==free segl
        free segl==ksl;               ! map seg entry back to free list
     %end

     %routine fault(%integer i)
        *=K'016500'; *=4; ! mov 4(lnb),r0
         *=K'010046';    ! mov r0,-(sp)
         *=K'004737'; *=K'140';  ! jsr pc,@#140 - ie jump to dump
     %end

%endofprogram