$modcal$

{  SEGMENTER module -- Original author: Sam Sands                   }
{                      Reviewed by John Schmidt 5/83                }
{                                                                   }
{   Bug history:                                                    }
{      1. 5/24/83                                                   }
{         Larry Chapman (TAG) reported failure if STOP key was      }
{         hit while segment was loading. John S. verified bug,      }
{         determined hangup was in "loadtext" routine in loader.    }
{         Sam Sands suggested fix that was implemented by John S.   }
{         which repaired loader open file list pointer. Fix appears }
{         to work, and was verified by Sam, John, and Larry.        }
{                                                                   }
{      2. 3/35/85                                                   }
{         Fixes to flush 68020 I-cache before calling code. jws     }
{                                                                   }
{      3. 6/10/85                                                   }
{         The system variable 'INITSTACK' was not getting updated   }
{         for a call going through the segmenter.  The following    }
{         bug is the result of this.  If the entry point being      }
{         called is a main program and if at some point during      }
{         the execution of that program a NON-LOCAL goto is         }
{         executed where the destination is the main program that   }
{         was initially called, register A6 is incorrectly given    }
{         a value which corresponds to original main program.       }
{         This in turn causes the program envoked by the segmenter  }
{         to return to the command interpreter instead of the       }
{         environment that called it.  The fix implemented is to    }
{         save the value of 'INITSTACK', set up a proper new value, }
{         and restore the original value prior to returning to the  }
{         original scope.                                           }
{                                                                   }
{      4. 3/16/90                                                   }
{         The system variables heapbase and heapmax were not        }
{         getting updated for a call going through the              }
{         segmenter.  As a result, when both the segmenter          }
{         application and the called program were using heap_dispose}
{         the free list for the application was getting trashed.    }
{         This is only applicable for programs, not library entry   }
{         points (call_segment only)                                }

module segmenter;

import loader, ldr, sysglobals, MISC;             { JWS 5/24/83 }

export
  type segment_proc = procedure;
       proc_name    = string[120];

  procedure init_segmenter(anyvar lowcode,   highcode,
				  lowglobal, highglobal: byte);

  procedure load_segment     (filename: fid);
  procedure load_heap_segment(filename: fid);
  procedure unload_segment;
  procedure unload_all;

  procedure call_segment     (filename: fid);
  procedure call_segment_proc(filename: fid; symbol: proc_name);

  function find_proc(symbol: proc_name): segment_proc;
  function exists_proc(p: segment_proc): boolean;

  procedure segment_space(var code, global: integer);

implement

external module asm;
export
  function  allocate(size: integer): anyptr;
  procedure newbytes(var p: anyptr; size: integer);
  procedure flush_icache;
  function getA7 : integer;   { BAR 6/10/85 }
end;

import asm;

type  proc = procedure;

      trick_proc = record case boolean of
	     true:  (p: proc);
	     false: (ep, sl: integer);
	     end;

      state_ptr = ^state_rec;
      name_ptr  = ^proc_name;

      state_rec = record
	    savelist:  state_ptr;
	    restore_heap: boolean;
	    saveheap:  ^integer;
	    saveglob,
	    savecod:   integer;
	    saveentry,
	    savedef:   moddescptr;
	    savefiles: anyptr;
	    end;

var highglob, lowglob:     integer;
    lowcod,   highcod:     integer;
    segment_list:          state_ptr;
    initstack['INITSTACK'] : integer;   { BAR 6/10/85 }

procedure init_segmenter(anyvar lowcode,   highcode,
				lowglobal, highglobal: byte);
begin
 lowcod := integer(addr(lowcode));
 highcod := integer(addr(highcode));
 if highcod < lowcod then begin
			  lowcod := integer(addr(highcode));
			  highcod := integer(addr(lowcode));
			  end;
 lowglob := integer(addr(lowglobal));
 highglob := integer(addr(highglobal));
 if highglob < lowglob then begin
			  lowglob := integer(addr(highglobal));
			  highglob := integer(addr(lowglobal));
			  end;
 if odd(lowcod)   then lowcod   := lowcod + 1;
 if odd(lowglob)  then lowglob  := lowglob + 1;
 if odd(highcod)  then highcod  := highcod - 1;
 if odd(highglob) then highglob := highglob - 1;
end;

procedure segment_space(var code, global: integer);
begin
  code   := highcod  - lowcod;
  global := highglob - lowglob;
end;

procedure no_proc; begin escape(120); end;

function exists_proc(p: segment_proc): boolean;
begin
  exists_proc := not(p = no_proc);
end;

function find_proc(symbol: proc_name): segment_proc;
var
  modp: moddescptr;
  ptr, valueptr: addrec;
  found: boolean;
  proc_rec: trick_proc;
begin
find_proc := no_proc;
found := false;
modp := sysdefs;
while (modp<>nil) and not found do
  with modp^ do
    begin
      ptr := defaddr;
      while (ptr.a<defaddr.a+defsize) and not found do
	begin
	  found := ptr.syp^=symbol;
	  ptr.a := ptr.a+strlen(ptr.syp^)+1;
	  ptr.a := ptr.a+ord(odd(ptr.a));
	  valueptr.a := ptr.a+2;
	  if found then with proc_rec do
	    begin
	    sl := 0;
	    ep := valueptr.vep^.value;
	    find_proc := p;
	    end;
	  ptr.a := ptr.a+ptr.gvp^.short;
	end; {while}
      modp := link;
    end; {with modp^}
end;

procedure save_state(var state: state_rec; heapoff, codeoff: integer);
begin with state do
  begin
       savelist   := segment_list;      segment_list := addr(state);
  mark(saveheap);                       restore_heap := true;
       saveheap   := addr(saveheap^, heapoff);
       saveglob   := highglob;
       savecod    := lowcod + codeoff;
       savedef    := sysdefs;
       saveentry  := entrypoint;
       savefiles  := openfileptr;       openfileptr := anyptr(-1);
  end;
end;

procedure unload_segment;
begin
if segment_list = nil then escape(121) else
with segment_list^ do
  begin
	       segment_list := savelist;
  if restore_heap then release(saveheap);
	       highglob     := saveglob;
	       lowcod       := savecod;
	       sysdefs      := savedef;
	       entrypoint   := saveentry;
	       openfileptr  := savefiles;
  end;
end;

procedure unload_all;
begin
while segment_list <> nil do unload_segment;
end;

procedure load_seg(var filename: fid; p: proc);
var space: integer;
    modnum:    integer;
    highheap0: addrec;
    ESCTEMP: INTEGER;                 { JWS 5/24/83 }
    IOTEMP:  INTEGER;                 { JWS 5/24/83 }


begin
LOADFIB.PHP:=NIL;                     { JWS 5/24/83 }
try
  space := memavail - 5000;              {guess as to required stack space}
  if space <= 0 then escape(-2);
  mark(lowheap.p);
  highheap.a := lowheap.a + space; release(highheap.p);
  highheap0 := highheap;
  newmods := sysdefs;    endmod := sysdefs;

  openlinkfile(filename);
  if fdirectory = nil then escape(-10);
  for modnum := 1 to fdirectory^[0].dnumfiles do
			    begin loadinfo(modnum, true, false); checkrev; end;
  allresolved := true; matchfile;

  if not allresolved then escape(119);

  highheap := highheap0;

  countcode;

  startglobal := highglob - a5;
  highglob := highglob - totalglobal;
  if highglob < lowglob then escape(117);
  zeromem(anyptr(highglob), totalglobal);
  call(p);
recover begin
	LOCKUP;                   { JWS 5/24/83 }
	ESCTEMP:=ESCAPECODE;      { JWS 5/24/83 }
	IOTEMP:=IORESULT;         { JWS 5/24/83 }
	unload_segment; {moved to ensure it's always done, whether the
			 file close escapes or not, and to release enough
			 memory for the dam call in closefiles.       SFB}

       {NOTE: closefiles assumes FIB is open. If openlinkfile escaped,
	it may not be. So check it ourselves. Also, we assume the
	loader's extra list contains only one file, loadfib.fbp^.  SFB}

	if loadfib.php <> nil then      {SFB}
	  if loadfib.fbp^.freadable then
	   CLOSEFILES;            { JWS 5/24/83 }
	IORESULT:=IOTEMP;         { JWS 5/24/83 }
	LOCKDOWN;                 { JWS 5/24/83 }
	escape(ESCTEMP);          { JWS 5/24/83 }
	end;
end;

procedure release_heap;
begin with segment_list^ do
  begin
  release(saveheap);
  restore_heap := false;
  end;
end;

procedure local(var filename: fid; p: proc);
var state: state_rec;

  procedure loadproc;
  begin
  highheap.a := highheap.a - totalreloc;
  if highheap.a < lowheap.a then escape(-2);
  release(highheap.p);
  startreloc := integer(allocate(totalreloc));
  loadtext(false);

  highheap.a := highheap.a - totaldefs;
  if highheap.a < lowheap.a then escape(-2);
  release(highheap.p);
  movedefs(integer(allocate(totaldefs)));
  release_heap;
  call(p);
  end;

begin
save_state(state, 0 , 0);
load_seg(filename, loadproc);
unload_segment;
end;

procedure call_segment     (filename: fid);

 procedure callit;
 var proc_rec: trick_proc;
     modptr: moddescptr;
     initstack_temp : integer;   { BAR 6/10/85 }
     recover_executed : boolean;{ BAR 6/10/85 }
     heapmaxsave:ANYPTR;        { DEW 3/16/90 }
     heapbasesave:ANYPTR;       { DEW 3/16/90 }
 begin
 modptr := entrypoint;
 while modptr<>nil do with modptr^ do
   begin
   if startaddr <> 0 then with proc_rec do
     begin
     sl := 0;
     ep := startaddr;
     flush_icache;
     recover_executed := false;     { BAR 6/10/85 }
     try                            { BAR 6/10/85 }
       initstack_temp := initstack; { BAR 6/10/85 }
       initstack := getA7 - 8;      { BAR 6/10/85 }
       heapmaxsave  := heapmax;     { DEW 3/16/90 }
       heapbasesave := heapbase;    { DEW 3/16/90 }
       call(p);
     recover
       recover_executed := true;    { BAR 6/10/85 }
     initstack := initstack_temp;   { BAR 6/10/85 }
     heapmax   := heapmaxsave;      { DEW 3/16/90 }
     heapbase  := heapbasesave;     { DEW 3/16/90 }
     if recover_executed then       { BAR 6/10/85 }
	escape(escapecode);         { BAR 6/10/85 }
     end;
   if lastmodule then modptr := nil else modptr := link;
   end;
 end;

begin
 local(filename, callit);
end;

procedure call_segment_proc(filename: fid; symbol: proc_name);
var p: segment_proc;
    initstack_temp : integer;  { BAR 6/10/85 }
    recover_executed : boolean;{ BAR 6/10/85 }

 procedure callit;
  begin
    flush_icache;                     {JWS 3/25/85}
    recover_executed := false;     { BAR 6/10/85 }
    try                            { BAR 6/10/85 }
      initstack_temp := initstack; { BAR 6/10/85 }
      initstack := getA7 - 8;      { BAR 6/10/85 }
      call(find_proc(symbol));
    recover
      recover_executed := true;    { BAR 6/10/85 }
    initstack := initstack_temp;   { BAR 6/10/85 }
    if recover_executed then       { BAR 6/10/85 }
       escape(escapecode);         { BAR 6/10/85 }
  end;

begin
p := find_proc(symbol);
if exists_proc(p) then begin
    flush_icache;                     {JWS 3/25/85}
    recover_executed := false;     { BAR 6/10/85 }
    try                            { BAR 6/10/85 }
      initstack_temp := initstack; { BAR 6/10/85 }
      initstack := getA7 - 8;      { BAR 6/10/85 }
      call(p);
    recover
      recover_executed := true;    { BAR 6/10/85 }
    initstack := initstack_temp;   { BAR 6/10/85 }
    if recover_executed then       { BAR 6/10/85 }
       escape(escapecode);         { BAR 6/10/85 }
  end
  else local(filename, callit);
end;

procedure load_segment     (filename: fid);
var state:  state_ptr;

  function code_space(size: integer): anyptr;
  begin
   if lowcod + size > highcod then escape(122)
   else
    begin
    code_space := anyptr(lowcod);
    lowcod := lowcod + size;
    end;
  end;

  procedure loadproc;
  begin
  startreloc := integer(code_space(totalreloc));
  loadtext(false);
  movedefs(integer(code_space(totaldefs)));
  release_heap;
  end;

begin
state := code_space(sizeof(state_rec));
save_state(state^, 0, -sizeof(state_rec));
load_seg(filename, loadproc);
end;

procedure load_heap_segment(filename: fid);
var state:  state_ptr;

  procedure loadproc;
  begin
  loadtext(true);
  movedefs(startreloc+totalreloc);
  release(anyptr(startdefs+totaldefs));
  end;

begin
newbytes(state, sizeof(state_rec));
save_state(state^, -sizeof(state_rec), 0);
mark(lowheap.p); startreloc := lowheap.a;
load_seg(filename, loadproc);
end;

end.
