|
DataMuseum.dkPresents historical artifacts from the history of: RC4000/8000/9000 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about RC4000/8000/9000 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 9216 (0x2400)
Types: TextFile
Names: »centrlog4tx «
└─⟦01e83a425⟧ Bits:30008166 Bånd med SW8010 og SW8500 source code
└─⟦75ff9bef3⟧
└─⟦this⟧ »centrlog4tx «
external long procedure centralogic(test);
value test;
integer test;
begin
<* test is used to specify testoutput (on current output) and
kill of activities:
dump == print of coroutinestable, coroutinedescr, messages, and counters.
test=
1 < 0 : print counters
1 < 1 : dump semaphoretable if cause < 0
1 < 2 : dump semaphoretable if cause <= 0
1 < 3 : dump semaphoretable on start
*>
\f
integer max_sem,max_cor,sem_basis,cor_basis;
integer array ia(1:13);
system(5,co_own_base,ia);
maxsem:=ia(1);
sem_basis:=ia(2);
cor_basis:=ia(4);
max_cor:=(ia(3)-cor_basis) shift (-4);
begin
integer <* constant semafor *>
sem_mess_pool,
sem_mess,
sem_answ_pool,
sem_free,
sem_io,
sem_virt,
sem_ready;
integer <* reference *> array mess(1:1);
zone zt,zmess(1,1,stderror);
integer array timemess(1:12);
boolean array virt_arr(1:max_cor);
integer timebufadr, timersetup;
integer cor,sem,cause,state, term_cor, virt_error;
real cpu,time,start;
long antal, res, newnexttimeout, nexttimeout;
boolean take_message;
\f
procedure init;
begin
integer ny_sem;
cause :=4;
virterror :=
timebufadr :=
timersetup :=
sem_mess_pool :=0;
sem_mess :=-1;
sem_answ_pool :=-2;
sem_virt :=-5;
sem_free :=-6;
sem_io :=-8;
sem_ready :=-9;
for cor:=1 step 1 until max_cor do
begin
virt_arr(cor):=false;
system(12,cor,ia);
nysem:=sem:=where(cor);
case ia(8)+1 of
begin
<* empty *> ny_sem := sem_free;
<* pass. *> if sem <= sem_virt then ny_sem := sem_ready;
<* i/o *> ny_sem := sem_io;
<* passivated by activate *> system(9,cor,<:<10>activate:>)
end;
if sem<>ny_sem then
begin
write(out,<:<10>coroutine:>,cor,<: moved from :>);
writesem(sem);
write(out,<: to :>);
writesem(nysem);
cor_to_sem(ny_sem,cor);
end;
end;
open(zt,2,<:clock:>,0);
getshare6(zt,timemess,1);
timemess(4):=2;
nexttimeout:=extend 1 shift 46;
initref(mess);
cpu:=systime(1,0,start);
time:=0;
antal:=0;
dump;
printtime;
end;
\f
procedure print_result;
begin
long array arr(1:4);
long array field navn;
integer i,j;
navn:=8;
i:=getalarm(arr);
write(out,<:<10><10>coroutine:>,cor,<: result:>,cause);
if cause < 1 and cor>0 then cor_to_sem(sem_free,cor);
if alarmcause extract 24= -11 then
begin
write(out,<:<10>device status :>,arr.navn);
for j:=23 step -1 until 0 do write(out,if j mod 6=5 then <: :> else <::>,
if i shift (-j) extract 1=1 then<:1:> else <:.:>);
end;
end;
procedure printtime;
begin
real lcpu,ltime;
lcpu:=cpu;
ltime:=time;
cpu:=systime(1,start,time);
if test<>0 then
write(out,<:<10>cpu=:>,<<ddddd.0 >,cpu-lcpu, <:s. real=:>,time-ltime,
<<ddddddd >,<:s.<10>counters: passivate=:>,antal,<:blocksread=:>,
blocksread,<:blocksout=:>,blocksout,<:<10>delay's=:>,timersetup,
<:virt. error:>,virt_error);
end;
\f
procedure dump;
begin
integer i;
integer array semcore(1:3), corcore(1:8), messcor(1:9);
integer adr,sem;
procedure printsem(semadr);
value semadr;
integer semadr;
begin
integer adr;
procedure printcor(adr);
integer adr;
begin
system(5,adr-6,corcore);
if test shift 22<0 then
writeint(out,<:<10> cor:>,<<ddd >,corcore(8),<<-dddd >,<:prio=:>,corcore(1),
<:wait select=:>,<<-ddddddd >,corcore(5),<:, :>,corcore(6),
<:time to timeout:>,<<dddd.d000>,extend corcore(7) shift 10
);
adr:=corcore(3);
end;
procedure printmess(adr);
integer adr;
begin
integer i,lgd;
system(5,adr-6,messcor);
if test shift 21<0 then
begin
write(out,<:<10> mess prio=:>,<<-dddd >,messcor(1),<:lgd=:>,messcor(2));
lgd:=if messcor(2) > 10 then 5 else messcor(2) shift (-1);
for i:=1 step 1 until lgd do write(out,<<-ddddddd>,messcor(4+i));
end;
adr:=messcor(3);
end;
system(5,semadr-6,semcore);
if semcore(1)<>semadr-4 or semcore(3)<>semadr then
begin
write(out,<:<10><10>:>);
writesem(sem);
end;
adr:=semcore(3);
while adr<>semadr do printcor(adr);
adr:=semcore(1);
while adr<>semadr-4 do printmess(adr);
end;
\f
if test extract 1=1 then printtime;
if cause<4 then print_result;
if (cause = 4 and test extract 4 > 7)
or (cause < 0 and test extract 3 > 1)
or (cause = 0 and test extract 2 > 1) then
for sem:=-9 step 1 until max_sem do printsem(sem*8 + sembasis);
regret_timemess;
end;
procedure writesem(sem);
integer sem;
write(out,<:sem:>,<<-ddd >,sem,if sem>0 then <:user:> else
case sem+10 of (<:ready:>,<:impl. pass.:>,<:?:>,<:free:>,<:virt. space:>,
<:?:>,<:delay:>,<:wait answ. pool:>,<:wait mess.:>,<:wait mess. pool:>));
integer procedure where(cor);
value cor;
integer cor;
begin
integer array ia(1:4);
for cor:=cor shift 4 + cor_basis, ia(4) while ia(1)<2048 do
begin
where:=(cor-sem_basis)//8;
system(5,cor-6,ia);
end;
end;
\f
procedure virt;
begin
integer i;
if cause=-2 then
begin
virt_arr(term_cor):=true;
virt_arr( cor):=false add term_cor;
cor_to_sem(sem_virt,cor);
virt_error:=virt_error+1;
cause:=3;
end else
begin
virt_arr(term_cor):=false;
for i:=1 step 1 until max_cor do
if virt_arr(i) extract 12 = term_cor then
begin
cor_to_sem(sem_ready,i);
virt_arr(i):=false;
end;
end;
end;
\f
procedure delay;
begin
newnexttimeout:=extend co_time shift 10 + co_time_base;
if newnexttimeout<nexttimeout then
begin
regret_timemess;
timemess(5):=co_time shift (-14);
timemess(6):=co_time shift 10;
setshare6(zt,timemess,1);
timebufadr:=monitor(16,zt,1,timemess);
timersetup:=timersetup+1;
nexttimeout:=newnexttimeout;
end;
end;
procedure regret_timemess;
begin
if timebufadr<>0 then timebufadr:=monitor(82,zt,1,timemess);
nexttimeout:=extend 1 shift 46;
end;
\f
procedure event(proc);
value proc;
integer proc;
begin
integer result,nr,co_last_buf,co_next_buf;
state:=1;
co_last_buf:=co_next_buf:=co_8000_event:=0;
repeat
result:= monitor(if state=1 then proc else 66,zmess,co_next_buf,ia);
case result+2 of
begin
<* no event *>
begin
end;
<* message *>
if wait(sem_mess_pool,mess) > 0 then
begin
system(5,co_next_buf+2,mess);
mess(1):=mess(3);
mess(2):=abs mess(2);
mess(3):=co_next_buf;
if signal(sem_mess,mess) then
begin
state:=3;
monitor(26,zt,co_next_buf,mess); <* zt and mess dummy parameter *>
co_next_buf:=co_last_buf;
end else
begin
co_8000_event:=1;
wait(sem_mess,mess);
signal(sem_mess_pool,mess);
end;
end;
<* answer *>
if co_next_buf = time_buf_adr then
begin
regret_timemess;
co_next_buf:=co_last_buf;
if state=1 then state:=2;
end else
begin
co_last_buf:=co_next_buf;
wait_select:=co_next_buf;
if wait(sem_answ_pool,mess) > 0 then
begin
if signal(mess(3),mess) then state:=3
end else
if ia(1)<>0 then
begin
nr:=abs ia(1);
system(12,nr,ia);
if co_next_buf=ia(1) then
begin
state:=3;
cor_to_sem(sem_ready,nr);
end else co_8000_event:=1
end else co_8000_event:=1
end;
end;
until result=-1;
end;
\f
init;
trap(error);
for antal:= antal+1 while cause > 0 do
begin
wait_select:=0;
wait_time := state:=0;
if co_8000_event <> 0 then event(66);
res:=schedule(cor);
while cor=0 do
begin
if state=0 then event(66);
if state<>3 then co_time:=0;
res:=schedule(cor);
if cor=0 then
begin
delay;
event(24);
end;
end;
cause:=res extract 24;
term_cor:=res shift (-24) extract 24;
if cause=2 then cor_to_sem(sem_io,term_cor) else
if cause=-2 or virt_arr(term_cor) then virt;
end;
if false then error:cause:=-4;
dump;
centralogic:=res;
end;
end;
end;
▶EOF◀