⟦4824bdddb⟧

TextFile

job pm 4 600 time 5 0 temp disc 1200 20 perm mini 100 1 size 100000
platonenv = set bs bblenv
(
; o allocout
  head 1 cpu
  pascal80 codesize.12000 spacing.12000 ,
    stack.220,
    codelist.no,
    debugenvir
; o c
; convert allocout
  ballocator = set 1 mini
  ballocator = move pass6code
  if ok.yes
    scope project ballocator
  finis
)


process allocator(var allocsem, deallocsem : semaphore);

(* request formats:

data message:
-------------
request:
   u1 =  opcode;  opcode = 0
   u2 = number of messages
   u3.u4 = number of words in data part of message, -32768 means 32k words
answer:
   messagekind: no of double words (in datapart)
   size       : no of words (in datapart)
   u2 = number of messages allocated
   * the allocated messages are returned as a stack of messages
   * with the request message as top element

channel message:
----------------
request:
   u1 =  opcode; opcode = 1
   u2 = device;
   u3.u4 = mask
answer:
   messagekind = -128 * 256 + device
   size = mask
   u2 = result   0 : core not available
                 1 : granted
                 2 : device not available
   * the allocated channel_message is returned as a stack of two
   * messages with the requestmessage as top element
*)

const
nilbase = base_type (0, 1, 0, 0, 0);
niladdr = addr (nilbase, 0);
bytes_per_unit = 4; (* must be power of two *)  (* = double word *)
words_per_unit = bytes_per_unit div 2;
lastindex = (32768 div (bytes_per_unit div 2)) - 1;
nilindex  = lastindex + 2;
headersize = 32 div bytes_per_unit; (* no of storage units in header *)
not_processed = 0;
ok  = 1;
nocore = 2;

type
core_array = array (0..lastindex) of record (* note: element size must be equal to bytes_per_unit *)
memnext: integer; (* index of next in freelist (or nilindex) *)
memsize: integer; (* no of storage units *)
end;
device_array = packed array (minint .. minint+127) of boolean;
mem_array    = packed array (0..15) of boolean;

var
memtable : array (0..15) of integer; (* index to first free-elem (or nilindex) *)
devmap   : device_array;
core     : ^ core_array;
memaddr  : addr := addr (base_type(0, 0, 0, 0, 0), 0); (* disp is always zero *) 
previndex: integer;
coreindex: integer;
index    : integer;
mem      : integer;
size     : integer;
a        : addr;
mess     : reference;
head     : reference;
stack    : reference;
pkind    : integer;
param    : integer;
op       : integer;
no       : integer;
i        : integer;
nill     : ! ^ niltype;

procedure asgnaddrref (var a: addr; var r: reference); external;
procedure asgnrefaddr (var r: reference; a: addr);     external;
function uadd (i,j: integer): integer; external;
function udiv (i,j: integer): integer; external;
function umul (i,j: integer): integer; external;

<*
procedure printfree;
var
mem: integer;
index: integer;
i: integer;
memaddr : addr := addr (base_type(0,0,0,0,0),0);
core : ^ core_array;
begin
memaddr.base := addr_of(own.chain).base;
for mem := 0 to 15 do
begin
index := memtable (mem);
if index <> nilindex then
begin
memaddr.base.mem_no := mem;
core := ptraddr (memaddr);
printnl;
printtext ('mem no #');
printhex (mem);
i := 0;
repeat
with core^(index) do
begin
if i mod 5 = 0 then printnl;
i := i + 1;
printchar (sp);
printhex (index);
printchar ('=');
printhex (memsize);
index := memnext;
end;
until index = nilindex;
printnl;
end;
end;
end;
*>



procedure releasecore (startaddr: addr; size: integer);
(* size is number of storage units (= double words) *)
begin
mem       := startaddr.base.mem_no;
memaddr.base.mem_no := mem;
core      := ptraddr (memaddr);
coreindex := udiv (startaddr.disp, bytes_per_unit);

previndex := nilindex;
index     := memtable (mem);

while index < coreindex do
begin
previndex := index;
index     := core^(index).memnext;
end;

if previndex = nilindex then (* first in list *)
memtable (mem) := coreindex
else (* not first in list *)
with core^(previndex) do
if previndex + memsize = coreindex then
begin (* collaps at low end *)
coreindex := previndex;
size      := size + memsize;
end
else
memnext := coreindex;

if coreindex + size = index then
with core^(index) do
begin (* collaps at high end *)
index := memnext;
size  := size + memsize;
end;

with core^(coreindex) do
begin
memnext := index;
memsize := size;
end;
end;

function getcore (size: integer): addr;
(* size is number of storage units (= double words) *)
label found;
begin
for mem := 0 to 15 do
begin
memaddr.base.mem_no := mem;
core := ptraddr (memaddr);

previndex := nilindex;
index     := memtable (mem);

while index <> nilindex do
with core^(index) do
begin
if memsize < size then
begin
previndex := index;
index     := memnext;
end
else
begin (* free element is large enough *)
if memsize > size then
begin (* split *)
coreindex := index + size;
core^(coreindex).memnext := memnext;
core^(coreindex).memsize := memsize - size;
memnext := coreindex;
end;
if previndex = nilindex then
memtable (mem) := memnext
else
core^(previndex).memnext := memnext;
getcore.base := memaddr.base;
getcore.disp := umul (index, bytes_per_unit);
goto found;
end;
end;
end;

getcore.base := nilbase;
found:
end;

procedure gethead (pkind, psize: integer; var head: reference);
begin
asgnrefaddr (head, getcore (headersize));
if not nil(head) then
with head^ do
begin
owner       := ref (allocsem);
answer      := owner;
msg_chain   := nill;
stackchain  := nill;
messagekind := pkind;
size        := psize;
start.base  := nilbase;
end;
end;

label endloop;

begin (* allocator *)
own.secret_pointer^(allocatorstack)^.chain := addr_of(own.chain);
wait (mess, deallocsem);
own.secret_pointer^(deallocatorsem) := ref (allocsem);
memaddr.base := addr_of(own.chain).base;

with mess^ do
begin

lock mess as m: record
?       : array (0..5) of integer;
devices : device_array;
mems    : mem_array;
end
do
with m do
begin
devmap := devices;
devmap (minint+0) := false;
devmap (minint+1) := false;
for mem := 0 to 15 do memtable (mem) := nilindex;
for mem := u2 + 1 to 15 do
if mems (mem) then
begin
start.base.mem_no := mem;
releasecore (start, lastindex + 1);
end;
end;

start.base.mem_no := u2;
start.disp        := umul (u3, 256) + (u4 and (-bytes_per_unit));
if (u4 and (bytes_per_unit-1)) <> 0 then
start.disp      := uadd (start.disp, bytes_per_unit);
releasecore (start, lastindex+1 - udiv (start.disp, bytes_per_unit));
end;

return (mess);

repeat (* forever *)
wait (mess, allocsem);

with mess^ do
if answer = ref (allocsem) then
begin (* deallocation *)
pop (head, mess);
with head^ do
if messagekind < 0 then (* channelkind *)
devmap (messagekind) := true
else
if messagekind <> 0 then
if start.base.nill = 0 then
releasecore (start, messagekind);
asgnaddrref (a, head); asgnrefaddr (head, niladdr);
releasecore (a, headersize);
if not nil (mess) then
begin
u2 := not_processed;
return (mess);
end;
end

else

begin (* allocation *)
op    := u1 and 3;
no    := u2;
param := umul (u3, 256) + u4;

case op of

0: (* allocate data *)
begin
if param < 0 then param := -32768;
pkind := udiv (param, words_per_unit);
if (param and (words_per_unit-1)) <> 0 then pkind := pkind + 1;

for i := 1 to no do
begin
gethead (pkind, param, head);
if not nil (head) then
if pkind <> 0 then
with head^ do
begin
start := getcore (pkind);
if start.base.nill = 1 then return (head);
end;
if nil (head) then
begin
if not nil(stack) then
return (stack);
u2 := 0;
goto endloop;
end;
push (head, stack);
end;
endloop:
end;

1: (* allocate device *)
begin
pkind := minint + no;
u2 := nocore;
if no < 128 then
if devmap (pkind) then
begin
gethead(pkind, param, stack);
if not nil (stack) then
begin
devmap (pkind) := false;
u2 := ok;
end;
end;
end;

otherwise u2 := 3;
end;

push (mess, stack);
return (stack);

end; (* with mess^ *)

until false;
end.
▶EOF◀
DataMuseum.dk

RC4000/8000/9000

⟦4824bdddb⟧ TextFile

Derivation

TextFile
