module codctl; % Facilities for controlling the overall optimization.
% ------------------------------------------------------------------- ;
% Copyright : J.A. van Hulzen, Twente University, Dept. of Computer ;
% Science, P.O.Box 217, 7500 AE Enschede, the Netherlands.;
% Authors : J.A. van Hulzen, B.J.A. Hulshof, M.C. van Heerwaarden, ;
% J.B. van Veelen, B.L. Gates. ;
% ------------------------------------------------------------------- ;
% The file CODCTL.RED contains the functions defining the interface ;
% between SCOPE and REDUCE. ;
% Besides, CODCTL consists of facilities for controlling the ;
% overall optimization process( making use of a number of global ;
% variables and switches) and for the creation of an initial operating;
% environment for the optimization process. ;
% ------------------------------------------------------------------- ;
% ------------------------------------------------------------------- ;
% The optimization process is initialized by applying the function ;
% INIT, designed to create the initial state of the data structures, ;
% used to store the input, which will be subjected to a heuristic ;
% search for common sub-expressions (cse's). INIT serves also to ;
% restore initial settings when an unexpected termination occurs. ;
% ARESULTS can be used to obtain the output in an algebraic list, once;
% the optimization itself is finished and only when relevant, i.e. if ;
% !*SIDREL=T, !*AGAIN or Optlang!* is NIL. ;
% During input translation the incidence matrix(CODMAT) is partly ;
% made, by creating its row structure via FFVAR!!, given in the module;
% CODMAT. Once input is processed the optimization activities are ;
% activated by applying the function CALC.The kernel of the body of ;
% this function is the procedure OPTIMIZELOOP. However, first the ;
% function SSETVSARS (see CODMAT module) is applied to complete the ;
% matrix CODMAT (column creation). The optimize-loop is a repeated ;
% search for cse's, using facilities, defined in the modules CODOPT ;
% and CODAD1. During these searches different cse-names for identical;
% cse's might be created,for instance due to EXPAND- and SHRINK- ;
% activities (see CODOPT), an inefficiency repaired via IMPROVELAYOUT ;
% (see the module CODAD1). When !*AGAIN is T output is created ;
% without performing the finishing touch (see CODAD2). Output is ;
% created through the functions MAKEPREFIXL and PRIRESULT. Finally the;
% REDUCE environment, which existed before the optimization activities;
% is restored as last activity of CALC. ;
% ------------------------------------------------------------------- ;
symbolic$
global '(codmat endmat !*acinfo prevlst !*sidrel maxvar malst
rowmax rowmin !*priall !*primat codbexl!* !*prefix !*again
ops kvarlst cname!* cindex!* optlang!* gentranlang!*
varlst!* varlst!+ !*outstk!* !*optdecs !*inputc !*vectorc
!*intern min!-expr!-length!*)$
fluid '(!*gentranopt !*double !*period !*noequiv );
switch acinfo,sidrel,priall,primat,prefix,optdecs,again,inputc,vectorc,
intern$
% ------------------------------------------------------------------- ;
% Initial settings for the globals. ;
% ------------------------------------------------------------------- ;
codmat:=!*priall:=!*primat:=!*sidrel:=!*optdecs:=optlang!*:=nil;
!*again:=!*prefix:=!*acinfo:=!*inputc:=!*intern:=!*vectorc:=nil;
min!-expr!-length!*:=nil;
rowmin:=0; rowmax:=-1;
% ------------------------------------------------------------------- ;
% Description of global variables and switches. ;
% ------------------------------------------------------------------- ;
% MATRIX ACCESS: ;
% ;
% CODMAT : is a vector used to store the +,* matrices,merged in CODMAT;
% MAXVAR : The size of this merged matrix is 2*MAXVAR. ;
% ROWMAX : Largest actual row index. ;
% ROWMIN : Smallest actual column index. ;
% ENDMAT : Value of MAXVAR when cse-search starts. ;
% ;
% Remark - The storage strategy can be vizualized as follows: ;
% ;
% MAXVAR + MAXVAR ;
% -------|------------------------------------------------| ;
% | Storage left for cse's | ;
% -------|------------------------------------------------| ;
% MAXVAR + ROWMAX (ENDMAT when input processing completed)| ;
% -------|------------------------------------------------| ;
% | Matrix Rows:Input decomposition | ;
% -------|------------------------------------------------| ;
% MAXVAR + 0 | ;
% -------|------------------------------------------------| ;
% | Matrix columns:Variable occurrence information | ;
% -------|------------------------------------------------| ;
% MAXVAR - ROWMIN | ;
% -------|------------------------------------------------| ;
% | Storage left for cse-occurrence information | ;
% -------|------------------------------------------------| ;
% MAXVAR - MAXVAR | ;
% ;
% ;
% CSE-NAME SELECTION ;
% ;
% Cname!* : Created in INAME and exploded representation of letter- ;
% part of current cse-name. ;
% Cindex!*: Current cse-number. If cindex!*:=Nil then GENSYM() is use;
% Bnlst : List of initial cse-names. When !*AGAIN=T used to save ;
% these names via CSES:=('PLUS.Bnlst).If necessary extended;
% with last GENSYM-generation(see MAKEPREFIXLIST). This ;
% assignment statement preceeds other output and is used in;
% FFVAR!! (see module CODMAT) to flag all old cse-names ;
% with NEWSYM when continuing with next set of input files.;
% ;
% The cse-name generation process is organized by the procedures ;
% INAME,NEWSYM1 and FNEWSYM. The procedure DIGITPART is needed in ;
% FFVAR!! (via RestoreCseInfo) to restore the cse-name flags NEWSYM.;
% This information is saved by SaveCseInfo (see MAKEPREFIXLST). ;
% ;
% SWITCHES : THE ON-EFFECT IS DESCRIBED ;
% ;
% ACinfo : (Evaluated) input and Operation counts displayed with-;
% out disturbing Outfile declarations. ;
% Primat : Initial and final state of matrix CODMAT is printed. ;
% Priall : Turns !*ACinfo,!*Primat on. ;
% Prefix : Output in pretty printed prefixform. ;
% Again : Optimization of partioned input will be continued a ;
% next time. Cse's added to prefixlist and finishing ;
% touch delayed. ;
% SidRel : The Optimizer output, collected in Prefixlist, is re- ;
% written, using the procedure EvalPart, defined in this;
% module, resulting in a list of (common sub)expressions;
% with PLUS or DIFFERENCE as their leading operator, ;
% when ever possible. ;
% Optdecs : The output is preceded by a list of declarations. ;
% ;
% REMAINING GLOBALS ;
% ;
% Prefixlist : Association list defining output. Built in CODPRI-part;
% 2 and used either via ASSGNPRI (ON FORT or ON/OFF NAT);
% or via PRETTYPRINT (ON PREFIX). ;
% Pre- ;
% Prefixlist : Rational exponentiations require special provisions ;
% during parsing, such as the production of this list of;
% special assignments, made as side-effect of the appli-;
% cation of the function PrepMultMat in SSetVars (see ;
% the module CODMAT). This list is put in front of the ;
% list Prefixlist. ;
% Prevlst : Used in FFVAR!! to store information about expression ;
% hierarchy when translating input. ;
% Later used (initialized in SSETVARS) to obtain correct;
% (sub)expression ordering. ;
% Kvarlst : Used for storing information about kernels. ;
% Optlang!* : Its value ('FORTRAN, 'C, for instance) denotes the ;
% target language selection for the output production. ;
% CodBexl!* : List consisting of expression recognizers. It guaran- ;
% tees a correct output sequence. Its initial structure ;
% is built in FFVAR!! and modified in IMPROVELAYOUT,for ;
% instance, when superfluous intermediate cse-names are ;
% removed. ;
% ------------------------------------------------------------------- ;
% ------------------------------------------------------------------- ;
% Some GENTRAN modules are required to obtain a correct interface. ;
% The file names are installation dependent. ;
% ------------------------------------------------------------------- ;
%IN "$gentranutil/sun-gentran-load"$
load!-package 'gentran$ % Moet worden gentran90 !!
% Load and initialize rounded-package
if not !*rounded then << on 'rounded; off 'rounded >>;
% ------------------------------------------------------------------- ;
% PART 1 : Interface between Scope and Reduce. ;
% ------------------------------------------------------------------- ;
% ------------------------------------------------------------------- ;
% ALGEBRAIC MODE COMMAND PARSER ;
% ------------------------------------------------------------------- ;
put('optimize, 'stat, 'optimizestat);
global '(optlang!* avarlst known rhsaliases);
fluid '(!*fort preprefixlist prefixlist);
symbolic expr procedure optimizestat;
% --------------------------------------------------------------- ;
% OPTIMIZE command parser. ;
% --------------------------------------------------------------- ;
begin scalar forms, vname, infiles, outfile, x, decs, kwds, delims;
symtabrem('!*main!*,'!*decs!*);
kwds := '(iname in out declare);
delims := append(kwds, '(!*semicol!* !*rsqb!* end));
flag(kwds, 'delim);
while not memq(cursym!*, delims) do
if (x := xreadforms()) then
forms := append(forms, x);
while memq(cursym!*, kwds) do
if eq(cursym!*, 'iname) then
vname := xread t
else if eq(cursym!*, 'in) then
if atom (x := xread nil) then
infiles := list x
else if eqcar(x, '!*comma!*) then
infiles := cdr x
else
infiles := x
else if eq(cursym!*, 'out) then
outfile:=xread t
else if eq(cursym!*, 'declare) then
decs := append(decs, cdr declarestat());
remflag(kwds, 'delim);
return list('symoptimize, mkquote forms,
mkquote infiles,
mkquote outfile,
mkquote vname,
mkquote decs)
end;
% ------------------------------------------------------------------- ;
% ALGEBRAIC MODE OPERATOR ALGOPT ;
% ------------------------------------------------------------------- ;
symbolic procedure algopteval u;
% ------------------------------------------------------------------- ;
% Algebraic mode interface in the form of a function-application. The ;
% procedure algresults1 is used for result production. ;
% u = list of the form : (forms, filesnames, csename). The arguments ;
% are optional. ;
% forms is a list of eq's, defining pairs (lhs-name,rhs-value), ;
% filenames is a list of filenames, containing symtactically correct ;
% input and the csename, optional too, is the initial cse-name part, ;
% a scalar. ;
% --------------------------------------------------------------------;
begin
scalar su,res,intern!*; integer nargs;
intern!*:=!*intern; !*intern:='t;
nargs := length u;
u:=foreach el in u collect
if listp(el) and eqcar(el,'list) and allstring(cadr el)
then cdr(el) else el;
if listp(car u) and not(allstring car u) and not(eqcar(car u,'list))
then u:=list('list,car u).cdr u;
res :=
if nargs = 1
then if su:=allstring(car u)
then symoptimize(nil,su,nil,nil,nil)
else symoptimize(car u,nil,nil,nil,nil)
else if nargs = 2
then if su:=allstring(cadr u)
then symoptimize(car u,su,nil,nil,nil)
else if (su:=allstring(car u)) and atom cadr u
then symoptimize(nil,su,nil,cadr u,nil)
else if atom cadr u
then symoptimize(car u,nil,nil,cadr u,nil)
else '!*!*error!*!*
else if nargs = 3 and (su:=allstring cadr u)
then symoptimize(car u,su, nil, caddr u,nil)
else '!*!*error!*!*;
!*intern:=intern!*;
if eq(res,'!*!*error!*!*)
then rederr("SYNTAX ERROR IN ARGUMENTS ALGOPT")
else return algresults1(foreach el in res
collect cons(cadr el,caddr el))
end;
put ('algopt,'psopfn,'algopteval);
symbolic procedure allstring s;
% ------------------------------------------------------------------- ;
% Consists s of one are more filenames? ;
% ------------------------------------------------------------------- ;
if atom s
then if stringp s then list(s)
else nil
else if not(nil member foreach el in s collect stringp el) then s
else nil;
% ------------------------------------------------------------------- ;
% SYMBOLIC MODE PROCEDURE ;
% ------------------------------------------------------------------- ;
global '(!*algpri !*optdecs)$
switch algpri,optdecs$
!*optdecs:=nil$
symbolic expr procedure symoptimize(forms,infiles,outfile,vname,decs);
% --------------------------------------------------------------- ;
% Symbolic mode function. ;
% --------------------------------------------------------------- ;
begin scalar algpri,echo,fn,forms1,optdecs, comdecs;
echo:=!*echo;
eval list('off, mkquote list 'echo);
if infiles then
forms := append(forms, files2forms infiles);
algpri := !*algpri;
!*echo:=echo;
if decs
then << optdecs:=!*optdecs; !*optdecs:=t;
% JB 31/3/94 Fixed to deal with complex input:
if (comdecs:=assoc('complex, decs)) or
(comdecs:=assoc('complex!*16, decs))
then <<if not freeof(comdecs,'i)
then forms:= '(setq i (sqrt (minus 1)))
. forms;
>>
>>;
eval list('off, mkquote list 'algpri);
if vname then iname vname;
forms := analyse_forms(forms);
!*algpri := algpri;
preproc1 ('declare . decs);
% prefixlist:=segmentation_if_needed(forms,outfile,vname);
prefixlist:=
eval formoptimize(list('optimizeforms,forms,outfile,vname),
!*vars!*,
!*mode);
if decs then !*optdecs:=optdecs;
if !*intern
then return (foreach el in prefixlist
collect list('setq,car el,cdr el))
end$
symbolic expr procedure symoptimize(forms,infiles,outfile,vname,decs);
% --------------------------------------------------------------- ;
% Symbolic mode function. ;
% --------------------------------------------------------------- ;
begin scalar algpri,echo,fn,forms1,optdecs,comdecs;
echo:=!*echo;
eval list('off, mkquote list 'echo);
if infiles then
forms := append(forms, files2forms infiles);
algpri := !*algpri;
!*echo:=echo;
if decs
then <<optdecs:=!*optdecs; !*optdecs:=t; >>;
eval list('off, mkquote list 'algpri);
if vname then iname vname;
forms := analyse_forms(forms);
!*algpri := algpri;
preproc1 ('declare . decs);
prefixlist:=
eval formoptimize(list('optimizeforms,forms,outfile,vname),
!*vars!*,
!*mode);
if decs then !*optdecs:=optdecs;
%else !*gendecs:=optdecs;
if !*intern
then return (foreach el in prefixlist
collect list('setq,car el,cdr el))
end$
symbolic procedure analyse_forms(forms);
% --------------------------------------------------------------------;
% forms is recursively analysed and replaced by a flattened list of ;
% items, which are either of the form ('setq lhs rhs) or have the ;
% structure ('equal lhs rhs).
% Here lhs can be a scalar, a matrix or an array identifier. ;
% The rhs is a REDUCE expression in prefix form. During the analysis ;
% scalar, matrix or array identifier elements of the list forms are ;
% replaced by the prefix equivalent of their algebraic value, which is;
% assumed to be a list of equations of the form ;
% {lhs1=rhs1,...,lhsn=rhsn}. ;
% Similarly elements of forms, being function-applications (either ;
% symbolic operators or psopfn facilities), evaluable to lists of the ;
% above mentioned structure, are replaced by their evaluations. ;
% ------------------------------------------------------------------- ;
begin scalar fn,res,forms1;
if atom(forms) then forms:=list(forms)
else if (listp(forms) and get(car forms,'avalue)
and car(get(car forms,'avalue)) member '(array matrix))
then forms:=list(forms)
else if listp forms and eqcar(forms,'list) then forms:=cdr forms;
res:=
foreach f in forms conc
if atom(f) and car(get(f,'avalue))='list then cdr reval f
else if listp(f) and get(car f,'avalue) and
car(get(car f,'avalue)) member '(array matrix)
then cdr reval f
else if listp(f) and eqcar(f,'list) then list f
else if listp(f) and eqcar(f,'equal) and eqcar(caddr f,'!*sq)
then list list('equal,cadr f,sq2pre caddr f)
else if listp(f) and
not member(car f,'(equal lsetq lrsetq rsetq setq))
then <<forms1:=
apply(if fn:=get(car f,'psopfn) then fn else car f,
if get(car f,'psopfn)
then list(foreach x in cdr f collect x)
else foreach x in cdr f collect x);
if pairp(forms1) and eqcar(forms1,'list)
then cdr forms1 else forms1
>>
else list f;
return foreach f in res conc
if listp(f) and eqcar(f,'list) then analyse_forms(cdr f) else list f
end;
symbolic expr procedure xreadforms;
begin scalar x;
x := xread t;
if listp x and eqcar(x, 'list) then
return flattenlist x
else if x then
return list x
else
return x
end;
symbolic expr procedure flattenlist x;
if atom(x) or constp(x) then
x
else
<< if eqcar(x, 'list) then
foreach y in cdr x collect flattenlist y
else
x
>>;
symbolic expr procedure files2forms flist;
begin scalar ch, holdch, x, forms;
holdch := rds nil;
forms := nil;
foreach f in flist do
<<
ch := open(mkfil f, 'input);
rds ch;
while (x := xreadforms()) do
forms := append(forms, x);
rds holdch;
close ch
>>;
return forms
end;
symbolic expr procedure formoptimize(u, vars, mode);
car u . foreach arg in cdr u
collect formoptimize1(arg, vars, mode);
symbolic procedure chopchop rep;
% rep : m . e;
% no trailing zeros in m; e < 0.
% rep is the cdr-part of a (!:rd!: !:cr!: !:crn!: !:dn!:)-notation.
if length(explode abs car rep)> !!rdprec
then begin
scalar sgn,restlist,lastchop,exppart;
restlist:=reverse explode abs(car rep);
sgn:=(car rep < 0);
exppart:= cdr rep;
while length(restlist) > !!rdprec
do << lastchop:=car restlist;
restlist:=cdr restlist;
exppart:=exppart+1 >>;
restlist:= compress reverse restlist;
if compress list lastchop >= 5
then restlist:=restlist + 1;
return (if sgn then -1*restlist else restlist) . exppart;
end
else rep;
symbolic expr procedure formoptimize1(u, vars, mode);
if constp u
then mkquote u % JB 30/3/94.
% Constants are not neccesarily atoms.
else
if atom u
then mkquote u
else if member(car u,'(!:rd!: !:cr!: !:crn!: !:dn!:))
then % JB 31/3/94 This seems to work. Honestly
% stolen from formgentran.
mkquote <<%precmsg length explode abs car(u := cdr u);
u:=chopchop cdr u;
decimal2internal(car u,cdr u)>>
else if eq(car u,'!:int!:)
then mkquote cadr u
else if eqcar(u, 'eval) then
list('sq2pre, list('aeval, form1(cadr u, vars, mode)))
else if car u memq '(lsetq rsetq lrsetq) then
begin scalar op, lhs, rhs;
op := car u;
lhs := cadr u;
rhs := caddr u;
if op memq '(lsetq lrsetq) and listp lhs then
lhs := car lhs . foreach s in cdr lhs
collect list('eval, s);
if op memq '(rsetq lrsetq) then
rhs := list('eval, rhs);
return formoptimize1(list('setq, lhs, rhs), vars, mode)
end
else
('list . foreach elt in u
collect formoptimize1(elt, vars, mode));
symbolic expr procedure sq2pre f;
if atom f then
f
else if listp f and eqcar(f, '!*sq) then
prepsq cadr f
else
prepsq f;
% ------------------------------------------------------------------- ;
% CALL CODE OPTIMIZER ;
% ------------------------------------------------------------------- ;
symbolic procedure optimizeforms(forms,outfile,vname);
begin
scalar noequiv,double,period,ch,fort,holdch,optlang,primat,
acinfo,inputc;
period:=!*period; !*period:=nil; % No periods in subscripts please.
noequiv:=!*noequiv; !*noequiv:=t; % No equivalence check, see coddom
double:=!*double;
put('!:rd!:,'zerop,'rd!:zerop!:); % New zerop which respects
% precision-setting, onep is o.k.
if vname and not(getd('newsym)) then iname vname;
if !*fort then << fort:=t;!*fort:=nil;
optlang:=optlang!*; optlang!*:='fortran>>;
if outfile then
<< if not(optlang!*)
then << holdch:=wrs nil; % get old output channel
if ch:=assoc(intern outfile,!*outstk!*)
then ch:=cdr ch
else ch:=open(mkfil outfile,'output);
wrs ch % set output channel to ch
>>
else eval list('gentranoutpush,list('quote,list(outfile)))
>>;
if !*priall % Save previous flag configuration.
then << primat:=!*primat; acinfo:=!*acinfo; inputc:=!*inputc;
!*primat:=!*acinfo:=!*inputc:=t >>;
prefixlist:=calc forms;
if !*priall then % Restore original flag configuration.
<< !*primat:=primat; !*acinfo:=acinfo; !*inputc:=inputc >>;
if outfile then
<< if not(optlang!*)
then
<< if (not(!*nat) or !*again) then write ";end;";
% Restore output channel
if assoc(intern outfile,!*outstk!*)
then <<terpri(); wrs holdch>> else <<wrs holdch; close ch>>
>>
else eval '(gentranpop '(nil))
>>;
if fort then << !*fort:=t; optlang!*:=optlang>>;
put('!:rd!:,'zerop,'rd!:zerop);
!*double:=double; !*noequiv:=noequiv; !*period := period;
return prefixlist;
end;
symbolic procedure opt forms;
% --------------------------------------------------------------- ;
% Replace each sequence of one or more assignment(s) by its ;
% optimized equivalent sequence. ;
% --------------------------------------------------------------- ;
begin scalar seq, res, fort, optlang;
fort:=!*fort;
!*fort:=nil;
optlang:=optlang!*;
optlang!*:=gentranlang!*;
if atom forms then
res := forms
else if eqcar(forms, 'setq) then
<<
res := foreach pr in optimizeforms(list forms, nil, nil)
collect list('setq, car pr, cdr pr);
if onep length res
then res := car res
else res := mkstmtgp(0, res)
>>
else if atom car forms then
res := (car forms . opt cdr forms)
else
<<
seq := nil;
while forms and listp car forms and eqcar(car forms, 'setq)
do <<seq := (car forms . seq); forms := cdr forms>>;
if seq then
<<seq := foreach pr in optimizeforms(reverse seq, nil, nil)
collect list('setq, car pr, cdr pr);
if length seq > 1 then
seq := list mkstmtgp(0, seq);
res := append(seq, opt forms)
>>
else
res := (opt car forms . opt cdr forms);
>>;
optlang!*:=optlang;
!*fort:=fort;
return res;
end;
% ------------------------------------------------------------------- ;
% PART 2 : Control of overall optimization process. ;
% ------------------------------------------------------------------- ;
symbolic procedure init n;
% ------------------------------------------------------------------- ;
% arg: Size of the matrix N. ;
% eff: Initial state (re)created by (re)initializing the matrix CODMAT;
% and some related identifiers. ;
% ------------------------------------------------------------------- ;
begin scalar var;
for y:=rowmin:rowmax do
if row(y) and not numberp(var:=farvar y)
then
<<remprop(var,'npcdvar); remprop(var,'nvarlst);
remprop(var,'varlst!+); remprop(var,'varlst!*);
remprop(var,'rowindex);
remprop(var,'nex);
remprop(var,'inlhs);
remprop(var,'rowocc);
remprop(var,'kvarlst);
remprop(var,'alias);remprop(var,'finalalias);
remprop(var,'aliaslist);remprop(var,'inalias);
>>;
if maxvar=n
then for x:=0:2*n do putv(codmat,x,nil)
else codmat:=mkvect(2*n);
if kvarlst then foreach item in kvarlst do
<< remprop(cadr item,'kvarlst);
remprop(cadr item,'nex)
>>;
foreach item in '(plus minus difference times expt sqrt) do
remprop(item,'kvarlst);
%-------------------------------------------------------------------
% If not all algresults were reversed by the user, by means of
% `restorall', or `arestore', they become irreversible commited
% after the following resetting of `avarlst'.
%-------------------------------------------------------------------
%bnlst:=
varlst!*:=varlst!+:=prevlst:=kvarlst:=codbexl!*:=avarlst:=nil;
malst:=preprefixlist:=nil; prefixlist:=nil;
rowmax:=-1; maxvar:=n;
rowmin:=0;
ops:=list(0,0,0,0)
end;
symbolic procedure calc forms;
% ------------------------------------------------------------------- ;
% CALC produces,via OPTIMIZELOOP, the association list PREFIXLIST. ;
% This list is used for output production by apllying PRIRESULT. ;
% ------------------------------------------------------------------- ;
begin scalar fil;
init 200;
prefixlist:=rhsaliases:=nil;
forms := preremdep forms;
foreach item in forms do
prefixlist:=ffvar!!(cadr item, caddr item, prefixlist);
preprefixlist:=ssetvars(preprefixlist); % Complete parsing.
fil:=wrs(nil); % Save name output file,which has to be ;
% used for storing the final results ;
if !*primat then primat();
if !*acinfo then countnop(reverse prefixlist,'input);
optimizeloop();
terpri();
wrs(fil);
prefixlist:=makeprefixl(preprefixlist,nil);
if !*gentranopt
then typeall(prefixlist)
else if not !*intern
then priresult(prefixlist);
fil:=wrs(nil);
if getd('newsym) then remd('newsym); %bnlst:=nil;
if !*acinfo then << countnop(reverse prefixlist,'output); terpri()>>;
if !*primat
then << for x:=rowmin:rowmax do if farvar(x)=-1 or farvar(x)=-2
then setoccup(x) else setfree(x);
primat();
>>;
wrs(fil);
return prefixlist
end$
% ------------------------------------------------------------------- ;
% Reduce interface for CALC, allowing the command CALC instead of ;
% CALC(). ;
% ------------------------------------------------------------------- ;
% put('calc,'stat,'endstat);
symbolic procedure pprintf(ex,nex);
% --------------------------------------------------------------------;
% arg : The name Nex of an expression Ex. ;
% eff : Nex:=Ex is printed using assgnpri on the output medium without;
% disturbing the current file management and output flagsettings;
% --------------------------------------------------------------------;
begin scalar s,fil,nat;
terpri();
fil:=wrs(nil);
if not(!*nat) then << nat:=!*nat; s:=!*nat:=t>>;
assgnpri(ex,list nex,'last);
wrs(fil);
if s then !*nat:=nat
end;
symbolic procedure optimizeloop;
% ------------------------------------------------------------------- ;
% Iterative cse-search. ;
% ------------------------------------------------------------------- ;
begin scalar b1,b2,b3,b4;
repeat
<< extbrsea();
% --------------------------------------------------------------- ;
% Extended Breuer search (see module CODOPT): ;
% Common linear expressions or power products are heuristically ;
% searched for using methods which are partly based on Breuer's ;
% grow factor algorithm. ;
% --------------------------------------------------------------- ;
b1:=improvelayout();
% --------------------------------------------------------------- ;
% Due to search strategy, employed in EXTBRSEA, identical cse's ;
% can have different names. IMPROVELAYOUT (see module CODAD1 is ;
% used to detect such situations and to remove double names. ;
% --------------------------------------------------------------- ;
b2:=tchscheme();
% --------------------------------------------------------------- ;
% Migration of information, i.e. the newly generated cse-names for;
% linear expressions occuring as factor in a product are transfer-;
% red from the + to the * scheme. Similar operations are performed;
% for power products acting as terms. File CODAD1.RED contains ;
% TCHSCHEME. ;
% --------------------------------------------------------------- ;
b3:=codfac();
% --------------------------------------------------------------- ;
% Application of the distributive law,i.e. a*b + a*c is changed in;
% a*(b + c) and expression storage in CODMAT is modified according;
% ly. File CODAD1.RED contains CODFAC. ;
% --------------------------------------------------------------- ;
b4:=searchcsequotients();
>>
until not(b1 or b2 or b3 or b4);
end;
symbolic procedure countnop(prefixlst,io);
% ------------------------------------------------------------------- ;
% The number of +/-, unary -, *, integer ^, / and function applica- ;
% tions is counted in prefixlist, consisting of pairs (lhs.rhs). Array;
% references are seen as function applications if the array name is ;
% not contained in the symbol table. The content of the symbol table ;
% is prescribed through the declare-option of the optimize-command, ;
% i.e. when io='input, and posibly modified after optimization, i.e. ;
% when io='output. ;
% ------------------------------------------------------------------- ;
begin scalar totcts;
totcts:='(0 0 0 0 0 0);
foreach item in prefixlst do
<< if pairp(car item) then totcts:=counts(car item,totcts,nil);
totcts:=counts(cdr item,totcts,nil)
>>;
terpri();
if io eq 'input
then write "Number of operations in the input is: "
else write "Number of operations after optimization is:";
terpri(); terpri();
write "Number of (+/-) operations : ",car totcts; terpri();
write "Number of unary - operations : ",cadr totcts; terpri();
write "Number of * operations : ",caddr totcts; terpri();
write "Number of integer ^ operations : ",cadddr totcts; terpri();
write "Number of / operations : ",car cddddr totcts;terpri();
write "Number of function applications : ",car reverse totcts;terpri()
end;
symbolic procedure counts(expression,locs,root);
% ------------------------------------------------------------------- ;
% The actual counts are recursively done with the function counts by ;
% modifying the value of the 6 elements of locs. The elements of locs;
% define the present number of the 6 possible categories of operators,;
% which we distinguish. ;
% ------------------------------------------------------------------- ;
begin scalar n!+,n!-,n!*,n!^,n!/,n!f,tlocs,loper,operands;
if idp(expression) or constp(expression)
then tlocs:=locs
else
<< n!+:=car locs; n!-:=cadr locs; n!*:=caddr locs; n!^:=cadddr locs;
n!/:=car cddddr locs; n!f:= car reverse locs;
loper:=car expression; operands:=cdr expression;
if loper memq '(plus difference)
then n!+:=(length(operands)-1)+n!+
else
if loper eq 'minus
then (if root neq 'plus then n!-:=1+n!-)
else
if loper eq 'times
then n!*:=(length(operands)-1)+n!*
else
if loper eq 'expt
then (if integerp(cadr operands)
then n!^:=1+n!^ else n!f:=1+n!f)
else
if loper eq 'quotient
then n!/:=1+n!/
else
if not(subscriptedvarp(loper))
then n!f:=1+n!f;
tlocs:=list(n!+,n!-,n!*,n!^,n!/,n!f);
foreach op in operands do tlocs:=counts(op,tlocs,loper)
>>;
return(tlocs)
end;
symbolic procedure complex!-i!-init!-statement st;
%
% See if we need to initialize i.
%
begin scalar tl, res;
tl:=formtypelists symtabget('!*main!*,'!*decs!*);
foreach el in tl do
<<if member(car el,
'(complex implicit! complex implicit! complex!*16))
and member('i, el)
then res :=
if !*double
then if st then "i=(0.0D0, 1.0D0)"
else '((literal tab!* "I=(0.0D0, 1.0D0)" cr!*))
else if st then "i=(0.0, 1.0)"
else '((literal tab!* "I=(0.0, 1.0)" cr!*))
>>;
return res;
end;
symbolic procedure priresult(prefixlist);
% ------------------------------------------------------------------- ;
% Besides flag settings and the like the essential action is printing.;
% ------------------------------------------------------------------- ;
begin scalar pfl,nat,istat;
if !*optdecs then typeall prefixlist;
if optlang!*
then << if null(assoc('e,prefixlist)) then symtabrem(nil,'e);
pfl := foreach pr in prefixlist collect
list('setq, car pr,lispcodeexp(cdr pr,!*period));
if (istat:=complex!-i!-init!-statement(nil))
then pfl := append(istat, pfl);
pfl := list mkstmtgp(0, pfl);
apply1(get(optlang!*, 'formatter),
apply1(get(optlang!*, 'codegen), pfl));
>>
else if !*prefix
then << write "Prefixlist:=";
terpri();
prettyprint(prefixlist)
>>
else << if !*optdecs then printdecs();
if (istat:=complex!-i!-init!-statement('t))
then <<write caddar istat;terpri()>>;
if not !*again
then
foreach item in prefixlist do
assgnpri(cdr item,list car item,'last)
else
<< nat:=!*nat; !*nat:=nil;
assgnpri(append(list('list),
for each item in prefixlist
collect list('setq,car item,cdr item)),
nil,'last);
!*nat:=nat;
terpri();%write ";end;"; % done by nat being off.
% JB 15/3/94
>>
>>
end;
symbolic procedure printdecs;
% ------------------------------------------------------------------- ;
% A list of declarations is printed. ;
% ------------------------------------------------------------------- ;
begin
scalar typ;
terpri!* t;
for each typelist in formtypelists symtabget('!*main!*, '!*decs!*)
do << if !*double then
<< typ:=assoc(car typelist,
'((real . double! precision) (complex . complex!*16)
(implicit! real . implicit! double! precision)
(implicit! complex . implicit! complex!*16)));
typ:=if null typ then car typelist else cdr typ
>>
else
typ:=car typelist;
prin2!* typ;
prin2!* " ";
inprint('!*comma!*, 0, cdr typelist);
terpri!* t
>>
end;
global '(!*ftch);
switch ftch;
!*ftch:='t;
symbolic procedure makeprefixl(pp,prefixlist);
% ------------------------------------------------------------------- ;
% If the finishing touch is appropriate, i.e. if OFF AGAIN holds ;
% PREPFINALPLST is called before producing PREFIXLIST using a FOREACH ;
% statement. If the optimization attempts have to be continued during ;
% another session(i.e. ON AGAIN) SAVECSEINFO is called to guarantee ;
% all relevant cse-information to be saved. ;
% ------------------------------------------------------------------- ;
begin scalar b,kvl,nex,xx;
if not(!*again)
then prepfinalplst();
for x:=0:rowmax do setfree(x);
kvl:=kvarlst;
foreach bex in reverse(codbexl!*) do
<<if numberp(bex) % --------------------- ;
then prefixlist:=prfexp(bex,prefixlist) % Leading operator is ;
% ^,*,+ or - . ;
else prefixlist:=prfkvar(bex,prefixlist); % Another leading ;
% operator. ;
>>; % --------------------- ;
% ----------------------------------------------------------------- ;
% Possibly, information about primitive factors of the form ;
% ('EXPT <identifier> <rational exponent>) as given in the list ;
% PrePrefixlist is put in front of Prefixlist. ;
% ----------------------------------------------------------------- ;
kvarlst:=kvl;
prefixlist:=reverse prefixlist;
if !*optdecs or !*gentranopt then
prefixlist:=removearraysubstitutes(prefixlist);
prefixlist:=cleanupprefixlist(prefixlist);
if !*sidrel then prefixlist:=evalpartprefixlist(prefixlist);
if !*again then prefixlist:=savecseinfo(prefixlist);
return prefixlist
end$
global '(!*min!-expr!-length!*)$
!*min!-expr!-length!*:=nil$
symbolic procedure prepfinalplst;
% ------------------------------------------------------------------- ;
% The refinements defined by this procedure - the socalled finishing ;
% touch - are only applied directly before producing the final version;
% of the output, i.e. the optimized version of the input. ;
% These refinements are: ;
% - POWEROFSUMS (see module CODAD2): Replace (a+b+...)^intpower by ;
% cse1=(a+b+...),cse1^intpower. ;
% - CODGCD (see module CODAD2): Replace 4.a+2.b+2.c+4.d by ;
% 2.(2.(a+d)+b+c),where a,b,c,d can ;
% be composite as well. ;
% - REMREPMULTVARS (see CODAD2) : Replace 3.a+b,3.a+c by ;
% cse3=3.a,cse3+b,cse3+c. ;
% - UPDATEMONOMIALS (see CODAD2) : Replace 3.a.b, 3.a.c., 6.a.d, ;
% 6.a.f by ;
% cse4=3.a, cse4.b, cse4.c, cse5=6.a;
% cse5.d, cse5.f. ;
% ------------------------------------------------------------------- ;
begin scalar n;
if (!*vectorc or !*sidrel or not !*ftch
or not null(min!-expr!-length!*)) % HvH 8/11/94
then codgcd()
else << repeat
<< n:=rowmax;
powerofsums();
remrepmultvars();
updatemonomials();
codgcd();
if not(n=rowmax) then optimizeloop()
>> until n=rowmax;
preppowls()
>>;
if not !*ftch and optlang!*='c then preppowls()
% ----------------------------------------------------------------- ;
% PREPPOWLS (see module CODPRI, part 2) serves to create addition ;
% chains for integer powers, such as cse1^intpower (due to ;
% POWEROFSUMS) and cse4=a^3 (produced by UPDATEMONOMIALS). ;
% ----------------------------------------------------------------- ;
end;
symbolic procedure savecseinfo(prefixlist);
% ------------------------------------------------------------------- ;
% If ON AGAIN then cse-information have to be saved. This is done by ;
% extending PREFIXLIST resulting in: ;
% ((CSES.cses) (GSYM.gsym) PREFIXLIST) or ;
% ((CSES.cses) (BINF.binf) PREFIXLIST). ;
% Here ;
% CSES=first cse nsme[+...+ last cse name], ;
% GSYM=GENSYM(), if GENSYM has been used for cse-name generation, ;
% because we do not want to generate identical cse-names during a;
% next run when using GENSYM. ;
% If GENSYM is not used then we create ;
% BINF=first initial cse-name[+...+ last initial cse-name],thus saving;
% the Bnlst. ;
% ------------------------------------------------------------------- ;
begin scalar cses,gsym,binf;
foreach item in prefixlist do
if pairp(item) and flagp( car(item),'newsym)
then cses:=car(item).cses;
if pairp(cses) then if cdr(cses) then cses:='plus.cses
else cses:=car cses;
prefixlist:=('cses.cses).prefixlist;
return if cses
then ('gsym . fnewsym()) . prefixlist
else ('gsym . gensym()) . prefixlist
end;
symbolic operator iname;
symbolic procedure iname(nm);
% ------------------------------------------------------------------- ;
% Construction of initial cse-name, extension of Bnlst and creation of;
% NEWSYM procedure via MOVD and using NEWSYM1. ;
% If, for instance, the initial name is aa55 then NEWSYM1 generates ;
% aa55, aa56 , aa57, etc. ;
% ------------------------------------------------------------------- ;
begin scalar digitl,dlst,nb,dg,initname;
digitl:='((!1 . 1) (!2 . 2) (!3 . 3) (!4 . 4) (!5 . 5)
(!6 . 6) (!7 . 7) (!8 . 8) (!9 . 9) (!0 . 0));
cname!*:=nil;
dlst:=reverse explode nm;
repeat
<<if (dg:=(assoc(car dlst,digitl))) and numberp (dg:=cdr dg)
then << dlst:=cdr dlst;
nb:= dg.nb >>
else << cname!*:=reverse dlst;
cindex!*:=0;
dg:=length(nb);
for i:=1:dg do
<<cindex!*:=10*cindex!*+car(nb);
nb:=cdr(nb)>> >>
>>
until cname!* or null(dlst);
if not getd('newsym) then movd('newsym,'newsym1);
% ------------------------------------------------------------- ;
% Bnlst is empty if INAME is used for the first time, i.e. if ;
% NEWSYM has to be identified with NEWSYM1. ;
% ------------------------------------------------------------- ;
initname:=newsym();
cindex!*:=cindex!*-1;
% bnlst:=initname.bnlst
end;
symbolic procedure movd(tod,fromd);
% ------------------------------------------------------------------- ;
% Transfer of a procedure description from Fromd to Tod. ;
% ------------------------------------------------------------------- ;
begin scalar s;
s:=getd(fromd);
putd(tod,car s,cdr s);
end;
symbolic procedure newsym1();
% ------------------------------------------------------------------- ;
% Global variables: ;
% cname!* is exploded letterpart of current cse-name. ;
% cindex!* is current cse-index. ;
% ------------------------------------------------------------------- ;
begin scalar x;
x:=explode cindex!*;
cindex!*:=cindex!*+1;
return compress append(cname!*,x)
end;
symbolic procedure fnewsym;
begin scalar x;
if getd('newsym)
then x:=newsym()
else << x:=gensym();
x:=compress(append(explode(letterpart(x)),
explode(digitpart(x))))
>>;
x:=intern(x); % May be necessary for some REDUCE systems;
flag(list x,'newsym);
return x;
end;
symbolic procedure letterpart(name);
% ------------------------------------------------------------------- ;
% Eff: Letterpart of Name returned,i.e. aa of aa55. ;
% ------------------------------------------------------------------- ;
begin scalar digitl,letters,el;
digitl:='((!1 . 1) (!2 . 2) (!3 . 3) (!4 . 4) (!5 . 5)
(!6 . 6) (!7 . 7) (!8 . 8) (!9 . 9) (!0 . 0));
letters:=reverse explode name;
while (el := assoc(car letters,digitl)) and numberp cdr el do
<< letters:=cdr letters >>;
return intern compress reverse letters;
end;
symbolic procedure digitpart(name);
% ------------------------------------------------------------------- ;
% Eff: Digitpart of Name returned,i.e. 55 of aa55. ;
% ------------------------------------------------------------------- ;
begin scalar digitl,nb,dg,dlst;
digitl:='((!1 . 1) (!2 . 2) (!3 . 3) (!4 . 4) (!5 . 5)
(!6 . 6) (!7 . 7) (!8 . 8) (!9 . 9) (!0 . 0));
dlst:= reverse explode name;
nb:=nil;
while (dg:=assoc(car dlst,digitl)) and numberp(dg := cdr dg) do
<< dlst:=cdr dlst; nb:=dg.nb >>;
dg:=0;
foreach digit in nb do dg:=10*dg+digit;
return dg;
end;
endmodule;
end;