reduce-historical/psl-1983/3-1/comp/faslout.red

%
% FASLOUT.RED - Top level of fasl file writer
% 
% Author:      Eric Benson
%	       Symbolic Computation Group
%              Computer Science Dept.
%              University of Utah
% Date:        16 February 1982
% Copyright (c) 1982 University of Utah
%

%  <PSL.COMP>FASLOUT.RED.8, 19-Apr-83 07:54:22, Edit by KESSLER
%  Flat Faslabort as Ignore, so you need not type compiletime faslabort.
%  <PSL.COMP>FASLOUT.RED.7, 28-Mar-83 07:49:53, Edit by KESSLER
%  Added FaslAbort Command to Terminate Faslout Gracefully.
%  <PSL.COMP>FASLOUT.RED.6, 16-Dec-82 12:49:59, Edit by KESSLER
%  Take out Semic!* as a fluid.  Not used by anyone that I can see
%  and is already a global in RLISP.
%  <PSL.COMP>FASLOUT.RED.35, 10-Jun-82 10:41:18, Edit by GRISS
%  Made CompileUncompiledExpressions regular func
%  <PSL.COMP>FASLOUT.RED.12, 30-Apr-82 14:45:59, Edit by BENSON
%  Removed EVAL and IGNORE processing
%  <PSL.COMP>FASLOUT.RED.8, 29-Apr-82 06:23:18, Edit by GRISS
%  moved DEFINEROP call to RLISP-PARSER


CompileTime <<
 flag('(CodeFileHeader CodeFileTrailer AllocateFaslSpaces),
      'InternalFunction);
 load Fast!-Vector;
>>;

fluid '(!*WritingFaslFile
	!*Lower
	!*quiet_faslout
	DfPrint!*
	UncompiledExpressions!*
	ModuleName!*
	CodeOut!*
	InitOffset!*
	CurrentOffset!*
	FaslBlockEnd!*
	MaxFaslOffset!*
	BitTableOffset!*
	FaslFilenameFormat!*);

FaslFilenameFormat!* := "%w.b";

lisp procedure DfPrintFasl U;		%. Called by TOP-loop, DFPRINT!*
begin scalar Nam, Ty, Fn, !*WritingFaslFile;
	!*WritingFaslFile := T;
	if atom U then return NIL;
	Fn := car U;
	IF FN = 'PUTD THEN GOTO DB2;
	IF NOT (FN MEMQ '(DE DF DM DN)) THEN GOTO DB1;
	NAM:=CADR U;
	U:='LAMBDA . CDDR U;
	TY:=CDR ASSOC(FN, '((DE . EXPR)
			    (DF . FEXPR)
			    (DM . MACRO)
			    (DN . NEXPR)));
DB3:	if Ty = 'MACRO then begin scalar !*Comp;
	    PutD(Nam, Ty, U);		% Macros get defined now
	end;
	if FlagP(Nam, 'Lose) then <<
	ErrorPrintF("*** %r has not been defined, because it is flagged LOSE",
			Nam);
	return NIL >>;
	IF FLAGP(TY,'COMPILE) THEN
	<<  PUT(NAM,'CFNTYPE,LIST TY); 
            U := LIST('!*ENTRY,NAM,TY,LENGTH CADR U)
                         . !&COMPROC(U, NAM);
	    LAP U >>
	ELSE				% should never happen
	     SaveUncompiledExpression LIST('PUTD, MKQUOTE NAM,
						  MKQUOTE TY,
						  MKQUOTE U);
	if IGreaterP(Posn(), 0) then WriteChar char BLANK;
        Prin1 NAM;
	RETURN NIL;
DB1:	% Simple S-EXPRESSION, maybe EVAL it;
        IF NOT PAIRP U THEN RETURN NIL;
	if (Fn := get(car U, 'FaslPreEval)) then return Apply(Fn, list U)
	else if (Fn := GetD car U) and car Fn = 'MACRO then
	    return DFPRINTFasl Apply(cdr Fn, list U);
	SaveUncompiledExpression U;
	RETURN NIL;
DB2:	NAM:=CADR U;
	TY:=CADDR U;
	FN:=CADDDR U;
	IF EQCAR(NAM,'QUOTE) THEN <<  NAM:=CADR NAM;
	IF EQCAR(TY,'QUOTE) THEN << TY:=CADR TY;
	IF PAIRP FN AND CAR FN MEMBER '(FUNCTION QUOTE) THEN <<  FN:=CADR FN;
	IF TY MEMQ '(EXPR FEXPR MACRO NEXPR) THEN
	<<  U:=FN; GOTO DB3 >> >> >> >>;
	GOTO DB1;
   END;

FLAG ('(DEFLIST FLAG FLUID GLOBAL REMFLAG REMPROP UNFLUID),'EVAL);

lisp procedure FaslPreEvalLoadTime U;
    DFPrintFasl cadr U;		% remove LOADTIME

put('LoadTime, 'FaslPreEval, 'FaslPreEvalLoadTime);
put('BothTimes, 'FaslPreEval, 'FaslPreEvalLoadTime);
put('StartupTime, 'FaslPreEval, 'FaslPreEvalLoadTime);	% used in kernel

% A few things to save space when loading

put('Flag,
    'FaslPreEval,
    function lambda U;
	if EqCar(second U, 'QUOTE) then
	    DFPrintFasl('progn . for each X in second second U collect
				     list('Flag1, MkQuote X, third U))
	else SaveUncompiledExpression U);

put('fluid,
    'FaslPreEval,
    function lambda U;
	if EqCar(second U, 'QUOTE) then
            DFPrintFasl('progn . for each X in second second U collect
				     list('Fluid1, MkQuote X))
	else SaveUncompiledExpression U);

put('global,
    'FaslPreEval,
    function lambda U;
	if EqCar(second U, 'QUOTE) then
	    DFPrintFasl('progn . for each X in second second U collect
				     list('Global1, MkQuote X))
	else SaveUncompiledExpression U);

put('DefList,
    'FaslPreEval,
    function lambda U;
	if EqCar(second U, 'QUOTE) then
	    DFPrintFasl('progn . for each X in second second U collect
				     list('put, MkQuote first X,
						third U,
						MkQuote second X))
	else SaveUncompiledExpression U);

put('ProgN,
    'FaslPreEval,
    function lambda U;
	for each X in cdr U do
	    DFPrintFasl X);

put('LAP,
    'FaslPreEval,
    function lambda U;
	if EqCar(cadr U, 'QUOTE) then Lap cadr cadr U
	else SaveUncompiledExpression U);

UncompiledExpressions!* := NIL . NIL;

lisp procedure SaveUncompiledExpression U;
<<  if atom U then NIL
    else TConc(UncompiledExpressions!*, U);
    NIL >>;

lisp procedure FaslOut FIL;
<<  ModuleName!* := FIL;
    if not !*quiet_faslout then
    <<  if not FUnBoundP 'Begin1 then
	<<  Prin2T "FASLOUT: IN files; or type in expressions";
	    Prin2T "When all done execute FASLEND;" >>
	else
	<<  Prin2T "FASLOUT: (DSKIN files) or type in expressions";
	    Prin2T "When all done execute (FASLEND)" >> >>;
    CodeOut!* := BinaryOpenWrite BldMsg(FaslFilenameFormat!*, ModuleName!*);
    CodeFileHeader();
    DFPRINT!* := 'DFPRINTFasl;
    !*WritingFaslFile := T;
    !*DEFN := T >>;

lisp procedure FaslEnd;
    if not !*WritingFaslFile then
	StdError "FASLEND not within FASLOUT"
    else
    <<  CompileUncompiledExpressions();
	UncompiledExpressions!* := NIL . NIL;
	CodeFileTrailer();
	BinaryClose CodeOut!*;
	DFPRINT!* := NIL;
        !*WritingFaslFile := NIL;
	!*DEFN := NIL >>;

FLAG('(FaslEND), 'IGNORE);

% FaslAbort.  Abort the Fasl process cleanly.  The code file will be closed
% and the various flags will be reset.
lisp procedure FaslAbort;
    if not !*WritingFaslFile then
	StdError "FASLAbort not within FASLOUT"
    else
    <<  UncompiledExpressions!* := NIL . NIL;
	BinaryClose CodeOut!*;
	DFPRINT!* := NIL;
        !*WritingFaslFile := NIL;
	!*DEFN := NIL >>;

Flag('(FaslAbort), 'Ignore);

lisp procedure ComFile Filename;
begin scalar !*Defn, !*WritingFaslFile, TestFile, FileBase, FileExt,
		I, N, DotFound, TestExts, !*quiet_faslout;
    if IDP Filename then
    (lambda (!*Lower); Filename := BldMsg("%w", Filename))(T);
    if not StringP Filename then return
	NonStringError(Filename, 'ComFile);
    N := ISizeS Filename;
    I := 0;
    while not DotFound and ILEQ(I, N) do
    <<  if IGetS(Filename, I) = char '!. then DotFound := T;
	I := IAdd1 I >>;
    if DotFound then
    <<  if not FileP Filename then return ContError(99, "Couldn't find file",
							ComFile Filename)
	else
	<<  FileBase := SubSeq(Filename, 0, I);
	    FileExt := SubSeq(Filename, ISub1 I, IAdd1 N) >> >>
    else
    <<  TestExts := '(".build" ".sl" ".red");
	while not null TestExts
		and not FileP(TestFile := Concat(Filename, first TestExts)) do
	    TestExts := rest TestExts;
	if null TestExts then return ContError(99,
					       "Couldn't find file",
					       ComFile Filename)
	else
	<<  FileExt := first TestExts;
	    FileBase := Filename;
	    Filename := TestFile >> >>;
    ErrorPrintF("*** Compiling %w", Filename);
    !*quiet_faslout := T;
    Faslout FileBase;
    if FileExt member '(".build" ".red") then
	EvIn list Filename
    else DskIn Filename;
    Faslend;
    return T;
end;

lisp procedure CompileUncompiledExpressions();
<<  ErrorPrintF("*** Init code length is %w",
			length car UncompiledExpressions!*);
    DFPRINTFasl list('DE, '!*!*Fasl!*!*InitCode!*!*, '(),
			'PROGN . car UncompiledExpressions!*) >>;

lisp procedure CodeFileHeader();
<<  BinaryWrite(CodeOut!*, const FASL_MAGIC_NUMBER);
    AllocateFaslSpaces() >>;

fluid '(CodeBase!* BitTableBase!* OrderedIDList!* NextIDNumber!*);

lisp procedure FindIDNumber U;
begin scalar I;
    return if ILEQ(I := IDInf U, 128) then I
    else if (I := get(U, 'IDNumber)) then I
    else
    <<  put(U, 'IDNumber, I := NextIDNumber!*);
	OrderedIDList!* := TConc(OrderedIDList!*, U);
	NextIDNumber!* := IAdd1 NextIDNumber!*;
	I >>;
end;

lisp procedure CodeFileTrailer();
begin scalar S;
    SystemFaslFixup();
    BinaryWrite(CodeOut!*, IDifference(ISub1 NextIDNumber!*, 2048));
					% Number of local IDs
    for each X in car OrderedIDList!* do
    <<  RemProp(X, 'IDNumber);
	X := StrInf ID2String X;
	S := StrLen X;
	BinaryWriteBlock(CodeOut!*, X, IAdd1 StrPack S) >>;
    BinaryWrite(CodeOut!*,		% S is size in words
		S := IQuotient(IPlus2(CurrentOffset!*,
				      ISub1 const AddressingUnitsPerItem),
				const AddressingUnitsPerItem));
    BinaryWrite(CodeOut!*, InitOffset!*);
    BinaryWriteBlock(CodeOut!*, CodeBase!*, S);
    BinaryWrite(CodeOut!*, S := IQuotient(IPlus2(BitTableOffset!*,
					   ISub1 const BitTableEntriesPerWord),
					  const BitTableEntriesPerWord));
    BinaryWriteBlock(CodeOut!*, BitTableBase!*, S);
    DelWArray(BitTableBase!*, FaslBlockEnd!*);
end;

lisp procedure UpdateBitTable(NumberOfEntries, FirstEntry);
if !*WritingFaslFile then
<<  PutBitTable(BitTableBase!*, BitTableOffset!*, FirstEntry);
    BitTableOffset!* := IAdd1 BitTableOffset!*;
    for I := 2 step 1 until NumberOfEntries do
    <<  PutBitTable(BitTableBase!*, BitTableOffset!*, 0);
	BitTableOffset!* := IAdd1 BitTableOffset!* >>;
    if IGreaterP(BitTableOffset!*, MaxFaslOffset!*) then
	FatalError "BPS exhausted during FaslOut; output file too large" >>;

lisp procedure AllocateFaslSpaces();
begin scalar B;
    B := GTWarray NIL;			% how much is left?
    B := IDifference(B, IQuotient(B, 3));
    FaslBlockEnd!* := GTWArray 0;	% pointer to top of space
    BitTableBase!* := GTWarray B;	% take 2/3 of whatever's left
    CurrentOffset!* := 0;
    BitTableOffset!* := 0;
    CodeBase!*
	:= Loc WGetV(BitTableBase!*,	% split the space between
		     IQuotient(B,	% bit table and code
			       IQuotient(const BitTableEntriesPerWord,
					 const AddressingUnitsPerItem)));
    MaxFaslOffset!* := IDifference(FaslBlockEnd!*, CodeBase!*);
    OrderedIDList!* := NIL . NIL;
    NextIDNumber!* := 2048;		% local IDs start at 2048
end;

END;