optim.p

<B>Digital的Unix操作系统VAX 4.2源码</B>

			    prooton^.expr^.opnd2^.exprVal^.exprVar;
		end;
	    end;
	    if not possible then begin
		ExprError(prooton^.expr,'AnalyzeForLoop: not opnd1 or opnd2?');
		PrintOptExpr(prooton);
	    end;
	end;
    end;
    if possible then begin
	if TraceOptim then begin
	    writeln(output,'AnalyzeForLoop: found induction expression');
	    PrintOptExpr(prooton);
	end;
	{ 
	    create a parent expression node
	    CopyExpr the non-index operand (of the binop) to outside the loop
	    add the forFrom expression as the other operand
	    EnterExpr the new parent expression
	    assign the new expr as the forFrom
	    repeat the above for the forTo expression
	    if the binop is *, repeat the above for the forBy expression

	    For each induction variable expression
		ReduceCounts on expression (will not be evaluated)
		Purge OptNode
		set expr and parent pointers to nil.
		    (must leave around because it might be rootCongruent)
		set expr^.kind to EXPRVAR, expr^.exprVar to indexVar
		EnterExpr new parent expression (parent pointer in old OptNode)
	}
	pen := prooton^.expr;
	{ change expression type of variable to match expression }
	ien^.exprType := pen^.exprType;
	InductionExpr(ien,pen,stn^.forFrom,sol,opnd1);
	InductionExpr(ien,pen,stn^.forTo,sol,opnd1);
	if pen^.exprBinOp = TKASTERISK then begin
	    InductionExpr(ien,pen,stn^.forBy,sol,opnd1);
	    { make index operation be expression type }
	    stn^.forIndexType := pen^.exprType;
	end;
	if TraceOptim then begin
	    write(output,'from ');
	    WriteExpr(output,stn^.forFrom);
	    write(output,' to ');
	    WriteExpr(output,stn^.forTo);
	    write(output,' by ');
	    WriteExpr(output,stn^.forBy);
	    writeln(output);
	end;
	on := prooton;
	repeat
	    if on^.uniqueId >= ion^.uniqueId then begin
		{ find expressions for this loop only }
		ReduceNeededCounts(on,1);
		on^.purged := true;
		RemoveFromActiveList(on);
		if opnd1 then begin
		    opndon := ExprToOpt(on^.expr^.opnd1);
		end else begin
		    opndon := ExprToOpt(on^.expr^.opnd2);
		end;
		opndon^.removed := true;
		en := on^.expr;	{ induction expression }
		{ copy expression node so OptNodes will still be valid }
		olden := NewExprNode(EXPRBINOP);
		olden^ := en^;
		{ replace en with value var index }
		en^.kind := EXPRVAL;
		ven := NewExprNode(EXPRVAR);
		SameExprLine(ven,en);
		en^.exprVal := ven;
		ven^.exprVar := ien^.exprVar;
		time := EnterExpr(ven,en,0);
		time := EnterExpr(en,on^.parent,0);
		on^.expr := olden;
		on^.parent := nil;	{ expr is now detached }
	    end;
	    on := on^.nextCongruent;
	until on = prooton;
    end;
until not possible;
end;

function ConsiderMove(on : OptNode; var preEval : ExprList; sol : SaveOptLevel)
	: boolean;
var
    pon : OptNode;
    didit : boolean;
    en, ien : ExprNode;
begin
    didit := false;
    if OptNloop or on^.loopConsidered then begin
	{ do nothing }
    end else begin
	if not on^.marked
	    and (on^.nonTrivial or (on^.containedNonTrivial <> nil))
	    and (on^.rootCongruent^.defineTime < blockOptTime)
	    and (on^.createLevel >= optBlockCeiling)
	then begin
	    { candidates for moving out are not marked, non-trivial, }
	    {  depend only on things outside the loop, }
	    {  and were calculated in this block }
	    { check parent first }
	    if on^.parent <> nil then begin
		pon := ExprToOpt(on^.parent);
		didit := ConsiderMove(pon,preEval,sol);
	    end;
	    if not didit then begin
		if TraceActions then begin
		    writeln(output,'Move out of loop ',blockOptTime:1);
		    PrintOptExpr(on);
		end;
		en := on^.expr;
		ien := CopyExpr(en,sol,nil);
		{ expression should be preserved through whole block }
		on^.rootEqual^.neededCount := on^.rootEqual^.neededCount + 1;
		on^.rootEqual^.eligible := true;
		preEval := AddToExprList(preEval,ien);
	    end;
	end;
	on^.loopConsidered := true;
    end;
    ConsiderMove := didit;
end;

procedure OptFinishLoop(var preEval : ExprList; sol : SaveOptLevel);
var
    on, prevActive : OptNode;
begin
    preEval := AddToExprList(nil,nil);
    on := activeExprs^.prevActive;
    { traverse list backwards to get outermost expressions first }
    while on <> activeExprs do begin
	prevActive := on^.prevActive;
	if on^.rootEqual <> on then begin
	    { not a rootEqual expression }
	    if TraceOpt then begin
		writeln(output,'OptFinishLoop: active but not rootEqual ',
		    on^.uniqueId:1);
	    end;
	end else if ConsiderMove(on,preEval,sol) then begin
	    { moved it out of loop }
	end else if on^.createLevel >= optBlockCeiling then begin
	    { purge expression }
	    on^.purged := true;
	    RemoveFromActiveList(on);
	end;
	on := prevActive;
    end;
end;

procedure Optimize;
begin
    InitOptimizer;
    OptModule(globalModule);
end;

procedure StartOptProc;
begin
    ResetOptimizer;
    optBlockLevel := 1;
    optBlockCeiling := 1;
    optBlockFloor := 1;
end;

procedure EndOptProc;
begin
end;

procedure StartOptSplit{(var sol : SaveOptLevel)};
begin
    sol.level := optBlockLevel;
    sol.floor := optBlockFloor;
    sol.ceiling := optBlockCeiling;
    sol.blockTime := blockOptTime;
    blockOptTime := optTime;
    optBlockLevel := optBlockLevel + 1;
    optBlockCeiling := optBlockLevel;
end;

procedure NextOptSplit{(var sol : SaveOptLevel)};
begin
    OptRefresh;
end;

procedure EndOptSplit{(var sol : SaveOptLevel)};
begin
    OptRefresh;
    optBlockLevel := sol.level;
    optBlockFloor := sol.floor;
    optBlockCeiling := sol.ceiling;
    blockOptTime := sol.blockTime;
    OptJoin;
end;

procedure StartOptLoop{(var sol : SaveOptLevel)};
begin
    sol.level := optBlockLevel;
    sol.floor := optBlockFloor;
    sol.ceiling := optBlockCeiling;
    sol.blockTime := blockOptTime;
    blockOptTime := optTime;
    optBlockLevel := optBlockLevel + 1;
    optBlockFloor := optBlockLevel;
    optBlockCeiling := optBlockLevel;
    optLoopNest := optLoopNest * LOOPBIAS;
end;

procedure EndOptLoop{(var sol : SaveOptLevel; var preEval : ExprList)};
begin
    optLoopNest := optLoopNest div LOOPBIAS;
    OptFinishLoop(preEval,sol);
    optBlockLevel := sol.level;
    optBlockFloor := sol.floor;
    optBlockCeiling := sol.ceiling;
    blockOptTime := sol.blockTime;
end;

procedure OptRecursionReturn{(proc : ProcNode; stn : StmtNode)};
var
    en : ExprNode;
    ok : boolean;
    pen : ExprNode;
    pn : ParamNode;
    on : OptNode;
    numParams : integer;
begin
    if OptNtail then begin
    end else begin
	en := stn^.returnVal;
	if en^.kind = EXPRFUNC then begin
	    if en^.func^.kind <> EXPRCONST then begin
		{ not a constant procedure name }
	    end else if en^.func^.exprConst^.kind <> DTPROC then begin
		{ not a procedure constant }
	    end else if proc <> en^.func^.exprConst^.procVal then begin
		{ not the right procedure }
	    end else begin
		if TraceOptim then begin
		    write(output,'OptRecursionReturn ');
		    WriteString(output,proc^.name);
		    writeln(output);
		end;
		ok := true;
		numParams := 0;
		if proc^.procType^.paramList <> nil then begin
		    pen := en^.params^.first;
		    pn := proc^.procType^.paramList^.first;
		    while ok and (pn <> nil) do begin
			if TraceOptim then begin
			    write(output,pn^.kind,' ');
			    WriteExpr(output,pen);
			end;
			if pn^.kind in [PARAMVAR,PARAMARRAYVAR] then begin
			    if pen^.baseVar = nil then begin
				ok := true;
				if TraceOptim then begin
				    write(output,' baseVar=nil');
				end;
			    end else if pen^.baseVar^.address.kind in
				    [MEMNORMAL,MEMFAST]
			    then begin
				ok := proc <> pen^.baseVar^.address.proc;
				if TraceOptim then begin
				    write(output,' block=',ok);
				end;
			    end else if pen^.baseVar^.address.kind = MEMPARAM
			    then begin
				ok := pen^.baseVar^.indirect or (proc <>
					pen^.baseVar^.address.proc);
				if TraceOptim then begin
				    write(output,' param=',ok);
				end;
			    end;
			end;
			if pn^.kind in [PARAMARRAYVALUE,PARAMARRAYVAR]
			then begin
			    if not pn^.paramType^.nocount then begin
				pen := pen^.next;
				numParams := numParams + 1;
			    end;
			end;
			if TraceOptim then begin
			    writeln(output);
			end;
			pen := pen^.next;
			numParams := numParams + 1;
			pn := pn^.next;
		    end;
		end;
		if ok and (numParams <= MAXTAILPARAMS) then begin
		    on := ExprToOpt(en^.func);
		    on^.tailRecursion := true;
		    proc^.tailRecursion := true;
		end;
	    end;
	end;
    end;
end;

procedure OptRecursionProc{(proc : ProcNode; stl : StmtList)};
var
    stn : StmtNode;
    ok : boolean;
    pen : ExprNode;
    pn : ParamNode;
    on : OptNode;
    cn : CaseNode;
begin
    if OptNtail or (stl^.first = nil) then begin
    end else begin
	stn := stl^.last;
	if stn^.kind = STMTPROC then begin
	    if stn^.proc^.kind <> EXPRCONST then begin
		{ not a constant procedure name }
	    end else if stn^.proc^.exprConst^.kind <> DTPROC then begin
		{ not a procedure constant }
	    end else if proc <> stn^.proc^.exprConst^.procVal then begin
		{ not the right procedure }
	    end else begin
		if TraceOptim then begin
		    write(output,'OptRecursionProc ');
		    WriteString(output,proc^.name);
		    writeln(output);
		end;
		ok := true;
		if proc^.procType^.paramList <> nil then begin
		    pen := stn^.params^.first;
		    pn := proc^.procType^.paramList^.first;
		    while ok and (pen <> nil) do begin
			if TraceOptim then begin
			    write(output,pn^.kind,' ');
			    WriteExpr(output,pen);
			end;
			if pn^.kind in [PARAMVAR,PARAMARRAYVAR] then begin
			    if pen^.baseVar = nil then begin
				ok := true;
				if TraceOptim then begin
				    write(output,' baseVar=nil');
				end;
			    end else if pen^.baseVar^.address.kind in
				    [MEMNORMAL,MEMFAST]
			    then begin
				ok := proc <> pen^.baseVar^.address.proc;
				if TraceOptim then begin
				    write(output,' block=',ok);
				end;
			    end else if pen^.baseVar^.address.kind = MEMPARAM
			    then begin
				ok := pen^.baseVar^.indirect or (proc <>
					pen^.baseVar^.address.proc);
				if TraceOptim then begin
				    write(output,' param=',ok);
				end;
			    end;
			end;
			if pn^.kind in [PARAMARRAYVALUE,PARAMARRAYVAR]
			then begin
			    if not pn^.paramType^.nocount then begin
				pen := pen^.next;
			    end;
			end;
			if TraceOptim then begin
			    writeln(output);
			end;
			pen := pen^.next;
			pn := pn^.next;
		    end;
		end;
		if ok then begin
		    on := ExprToOpt(stn^.proc);
		    on^.tailRecursion := true;
		    proc^.tailRecursion := true;
		end;
	    end;
	end else if stn^.kind = STMTIF then begin
	    OptRecursionProc(proc,stn^.thenList);
	    OptRecursionProc(proc,stn^.elseList);
	end else if stn^.kind = STMTWITH then begin
	    OptRecursionProc(proc,stn^.withBody);
	end else if stn^.kind = STMTCASE then begin
	    cn := stn^.cases^.first;
	    while cn <> nil do begin
		OptRecursionProc(proc,cn^.stmts);
		cn := cn^.next;
	    end;
	end;
    end;
end;

procedure MarkIt(on : OptNode);
begin
    on^.marked := true;
    if (on^.markLevel > optBlockLevel) or (on^.markLevel = 0) then begin
	on^.markLevel := optBlockLevel;
    end;
    on^.rootCongruent^.defineTime := optTime;
    if TraceMark then begin
	write(output,'<',on^.uniqueId:1,'>');
	if on <> on^.rootEqual then begin
	    write(output,'$');
	end;
	markItCount := markItCount + 1;
	if markItCount > 20 then begin
	    writeln(output);
	    markItCount := 0;
	end;
    end;
end;

procedure MarkOptAll;
var
    con, pon, mon : OptNode;
    pen, men : ExprNode;
    active, marked : integer;
begin
    if TraceOptim then begin
	writeln(output,'MarkOptAll: start');
    end;
    optTime := optTime + 1;
    markItCount := 0;
    active := 0;
    marked := 0;
    con := cseRootExpr[EXPRVAL];
    if con <> nil then begin
	repeat
	    mon := con;
	    repeat
		men := mon^.expr;
		{ Experiment:
		if men^.dependVar = nil then begin
		end else if men^.dependVar^.name <> nil then begin
		}
		    MarkIt(mon);
		    pen := mon^.parent;
		    while pen <> nil do begin
			pon := ExprToOpt(pen);
			if pon <> nil then begin
			    MarkIt(pon);
			    pen := pon^.parent;
			end else begin
			    pen := nil;
			end;
		    end;
		{ Experiment
		end;
		}
		mon := mon^.nextCongruent;
	    until mon = con;
	    con := con^.nextClass;
	until con = cseRootExpr[EXPRVAL];
    end;
    if TraceOptim then begin
	writeln(output,'MarkOptAll: done ',marked:1,':',active:1);
    end;
end;

procedure MarkOptExpr{(en : ExprNode)};
var
    baseVar : VarNode;
    basePtrType : TypeNode;
    con, mon, pon, von : OptNode;
    men, pen : ExprNode;
begin
    if TraceMark then begin
	write(output,'MarkOptExpr:');
	WriteExpr(output,en);
	writeln(output);
    end;
    markItCount := 0;
    optTime := optTime + 1;
    if en^.baseVar <> nil then begin
	baseVar := en^.baseVar;
	baseVar^.markTime.proc := currOptProc;
	baseVar^.markTime.time := optTime;
	if cseRootExpr[EXPRVAR] <> nil then begin
	     von := cseRootExpr[EXPRVAR];
	     repeat
		if von^.expr^.exprVar = baseVar then begin
		    von^.rootCongruent^.defineTime := optTime;
		end;
		von := von^.nextClass;
	     until (von = cseRootExpr[EXPRVAR]);
	end;
	con := cseRootExpr[EXPRVAL];
	if con <> nil then begin
	    repeat
		mon := con;
		repeat
		    men := mon^.expr;
		    if men^.dependVar = baseVar then begin
			MarkIt(mon);
			pen := mon^.parent;
			while pen <> nil do begin
			    pon := ExprToOpt(pen);
			    if pon <> nil then begin
				MarkIt(pon);
				pen := pon^.parent;
			    end else begin
				pen := nil;
			    end;
			end;
		    end;
		    mon := mon^.nextCongruent;
		until mon = con;
		con := con^.nextClass;
	    until con = cseRootExpr[EXPRVAL];
	end;
    end else if en^.basePtrType = nil then begin
	if TraceOptim then begin
	    write(output,'MarkOptExpr: both nil ');
	    WriteExpr(output,en);
	    writeln(output);
	end;
    end;
    if en^.basePtrType <> nil then begin
	if en^.baseVar <> nil then begin
	    if TraceOptim then begin
		write(output,'MarkOptExpr: both not nil ');
		WriteExpr(output,en);
		writeln(output);
	    end;
	end;
	basePtrType := en^.basePtrType;
	basePtrType^.markTime.proc := currOptProc;
	basePtrType^.markTime.time := optTime;
	mon := cseRootExpr[EXPRVAL];
	if mon <> nil then begin