DataMuseum.dk

top - metrics - download

    Length: 6912 (0x1b00)
    Types: TextFileVerbose
    Names: »tmonitor«

└─⟦2c55ea56f⟧ Bits:30001844 SW-save af projekt 1000, Alarm-system
    └─⟦6b41451d2⟧ 
        └─⟦this⟧ »tmonitor« 

TextFileVerbose

job pm 3 600 time 11 0 perm mini 100 1 size 92000
platonenv = set bs bblenv
(
 o monitorout
  head 1 cpu
  pascal80 codesize.12000 spacing.12000 ,
    short.yes,
    stack.256,
    codelist.yes
 o c
 convert monitorout
  bmonitor = set 1 mini
  bmonitor = move pass6code
  if ok.yes
    scope project bmonitor
  finis
)

(*$5 2 0*)
(*$5 4 0*)

process monitor(var monitorsem : semaphore);

const
monitorpriority = 1;
monreg = 992;
niladdr=addr(base_type(0,1,0,0,0),?);

stopfunction = 0;
startfunction = 1;
setpriorityfunction = 2;

ok = 1;
stoperror = 3;
starterror = 3;
setpriorityerror = 3;
paramerror = 3;

stopstate = -1;
runstate = 0;

instr_cwtac = #h016;
instr_mwtac = #h017;
sem_waits = (.
#h10, (* cwait *)
#h18, (* mwis  *)
#h30, (* mwst  *)
#h38, (* mwist *)
#h58, (* mcis  *)
#h78  (* mcist *)
.);

type
(* priority >=0  => class II  : coroutine scheduling  *)
(* priority < 0  => class III : timesliced scheduling *)
activetype=array(minpriority..maxpriority) of addr;

kind = (stop,start,mes);
const kindall = (.stop..mes.);

var
mask : set of kind:=(..);
msg : reference;


pr : ^ ext_incarnation_descriptor;
activequeue:activetype := activetype(maxpriority-minpriority+1***niladdr);
result : integer;
r : integer;
instr : byte;  (* instruction of stopped process *)
ref_var: addr; (* used when stopping a process *)

procedure setregister(value,index : integer); external;
procedure selectlevel(level : integer); external;
procedure linklast(queueaddr: addr; elemptr: ^ext_incarnation_descriptor);
external;
function addr_of(var a: addr): addr; external;
procedure getaddr (var dest: addr; source: addr); external;
procedure setqueueptr(var queueptr : addr; var queue : addr); external;
procedure getincpntr(var pr: ^ ext_incarnation_descriptor;
var p: ext_incarnation_descriptor); external;
procedure setregcouble(index: integer; var a: addr); external;
procedure scheduler; external;
procedure stopprocess(var p: ext_incarnation_descriptor); external;
procedure startdriver(var p: ext_incarnation_descriptor); external;
procedure asgnaddrinc(var a:addr; var p:ext_incarnation_descriptor);
external;

procedure printchar(ch:char);
begin
writeram(8,ord(ch));
end;

procedure printhex (val: integer);
type convarr = array (0..15) of char;
const hextab = convarr('0','1','2','3','4','5','6','7','8','9','a','b','c','d','e','f');
var ch1: integer;
begin
if val < 0 then
begin
ch1 := 8;
val := val - minint;
end
else
ch1 := 0;

printchar (hextab(ch1 + val div (16*16*16)));
printchar (hextab(val div (16*16) mod 16));
printchar (hextab(val div 16      mod 16));
printchar (hextab(val             mod 16));
end;

procedure printaddr( a : addr);
begin
with a.base do
printhex((((- lockbit * 2 + nill) * 256 + moduletype) * 32 + mem_no) * 2 + nullbit);
printchar('.');
printhex(a.disp)
end;

procedure printtext (text:alfa);
var i: integer;
begin
i := 1;
while text(i) <> '#' do
begin
printchar(text(i));
if i = alfalength then text(i) := '#' else i := i + 1;
end;
end;

procedure printnl;
var i: integer;
begin
printchar (cr); printchar (nl);
for i := 1 to 10 do printchar(del);
end;

procedure setexcept;
external;

procedure except;
label rep;

begin
with own do
begin
printnl;
printtext ('*** #       ');
printtext ('exception: #');
printhex (exception_mask);
printtext (' at: #      ');
printaddr(exic);
printnl;
end;
rep:goto rep;
end;

procedure platoninit;
begin
setexcept; except;
end;

procedure print(k: kind;txt: alfa; var p: ext_incarnation_descriptor);
var a: addr;

begin
if k in mask then begin
printnl; printtext(txt);
asgnaddrinc(a,p);
if a.base.nill=0 then
printtext(' lev=#      '); printhex(p.level);
printtext(', ic=#      ');
printaddr(p.entry_point);
printtext(' gf= #      '); printaddr(a);

end
end;


procedure setactivequeue(var q:addr;var m:reference);
begin
with m^ do
begin
r:=u3-128;
if (r<minpriority) or (r>maxpriority) then
result :=setpriorityerror
else setqueueptr(q,activequeue(r))
end
end;



(***********************************************************************)
(*                                                                     *)
(*          monitor main loop                                          *)
(*                                                                     *)
(*                                                                     *)
(***********************************************************************)

begin

platoninit;

own.secret_pointer^(monitorstack)^.chain := addr_of(own.chain);
own.secret_pointer^(activebase)^.chain := addr_of(activequeue(minpriority));

setqueueptr(own.activequeue,activequeue(monitorpriority));
setregcouble(monreg,activequeue(0));
setregister(maxpriority,monreg+2);
setregister(minpriority,monreg+3);
setregister(-1         ,monreg+4);
setregister(maxpriority,monreg+5);
selectlevel(0);
scheduler;

repeat
wait(msg,monitorsem);
result:=ok;
lock msg as p : ext_incarnation_descriptor do begin
case msg^.u1 of
stopfunction: begin
if p.incstate <> stopstate then begin
stopprocess(p);
(* repeat whole wait-sequences, when process is waiting *)
getbyte (instr, p.entry_point);
if (instr = instr_cwtac) or (instr = instr_mwtac) then
begin
p.entry_point.disp := p.entry_point.disp-1; (* repeat wait *)
getbyte (instr, p.entry_point);
if instr in sem_waits then (* don't repeat if semaphore-wait is terminated *)
begin
getaddr (ref_var, p.msg_waited);
if ref_var.base.nill = 0 then
p.entry_point.disp := p.entry_point.disp + 1; (* don't repeat *)
end;
end;
print(stop,'stopprocess ',p);
p.incstate := stopstate
end (* p.regsetbase <> stopstate *)
else
result := stoperror; (* end of stopfunction *)
end;
startfunction: begin
if (p.incstate = stopstate) then begin
setactivequeue(p.activequeue,msg);
if result = ok then begin
getincpntr(pr,p); p.incstate := runstate;
print(start,'startproc   ',p);
if p.level > 0 then startdriver(p) else begin
setqueueptr(p.chainhead,activequeue(r));
linklast(p.activequeue,pr);
end;
end
end
else
result := starterror
end;
setpriorityfunction:
setactivequeue(p.activequeue,msg)
otherwise
result := paramerror
end; (* case *)
end; (*lock *)

msg^.u2 := result;
if result <> ok then print(mes,'dummyrequest',pr^);
return(msg);
until false;
end (* monitor main loop *)
.
«eof»