1module codctl; % Facilities for controlling the overall optimization. 2 3% ------------------------------------------------------------------- ; 4% Copyright : J.A. van Hulzen, Twente University, Dept. of Computer ; 5% Science, P.O.Box 217, 7500 AE Enschede, the Netherlands.; 6% Authors : J.A. van Hulzen, B.J.A. Hulshof, M.C. van Heerwaarden, ; 7% J.B. van Veelen, B.L. Gates. ; 8% ------------------------------------------------------------------- ; 9% The file CODCTL.RED contains the functions defining the interface ; 10% between SCOPE and REDUCE. ; 11% Besides, CODCTL consists of facilities for controlling the ; 12% overall optimization process( making use of a number of global ; 13% variables and switches) and for the creation of an initial operating; 14% environment for the optimization process. ; 15% ------------------------------------------------------------------- ; 16 17% Redistribution and use in source and binary forms, with or without 18% modification, are permitted provided that the following conditions are met: 19% 20% * Redistributions of source code must retain the relevant copyright 21% notice, this list of conditions and the following disclaimer. 22% * Redistributions in binary form must reproduce the above copyright 23% notice, this list of conditions and the following disclaimer in the 24% documentation and/or other materials provided with the distribution. 25% 26% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 27% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, 28% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 29% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR 30% CONTRIBUTORS 31% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 32% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 33% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 34% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 35% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 36% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 37% POSSIBILITY OF SUCH DAMAGE. 38% 39 40 41% ------------------------------------------------------------------- ; 42% The optimization process is initialized by applying the function ; 43% INIT, designed to create the initial state of the data structures, ; 44% used to store the input, which will be subjected to a heuristic ; 45% search for common sub-expressions (cse's). INIT serves also to ; 46% restore initial settings when an unexpected termination occurs. ; 47% ARESULTS can be used to obtain the output in an algebraic list, once; 48% the optimization itself is finished and only when relevant, i.e. if ; 49% !*SIDREL=T, !*AGAIN or Optlang!* is NIL. ; 50% During input translation the incidence matrix(CODMAT) is partly ; 51% made, by creating its scope_row structure via FFVAR!!, given in the module; 52% CODMAT. Once input is processed the optimization activities are ; 53% activated by applying the function CALC.The kernel of the body of ; 54% this function is the procedure OPTIMIZELOOP. However, first the ; 55% function SSETVSARS (see CODMAT module) is applied to complete the ; 56% matrix CODMAT (column creation). The optimize-loop is a repeated ; 57% search for cse's, using facilities, defined in the modules CODOPT ; 58% and CODAD1. During these searches different cse-names for identical; 59% cse's might be created,for instance due to EXPAND- and SHRINK- ; 60% activities (see CODOPT), an inefficiency repaired via IMPROVELAYOUT ; 61% (see the module CODAD1). When !*AGAIN is T output is created ; 62% without performing the finishing touch (see CODAD2). Output is ; 63% created through the functions MAKEPREFIXL and PRIRESULT. Finally the; 64% REDUCE environment, which existed before the optimization activities; 65% is restored as last activity of CALC. ; 66% ------------------------------------------------------------------- ; 67 68symbolic$ 69 70global '(codmat endmat !*acinfo prevlst !*sidrel maxvar malst 71 rowmax rowmin !*priall !*primat codbexl!* !*prefix !*again 72 ops kvarlst cname!* cindex!* optlang!* gentranlang!* 73 varlst!* varlst!+ !*outstk!* !*optdecs !*inputc !*vectorc 74 !*intern min!-expr!-length!*)$ 75 76fluid '(!*gentranopt !*double !*period !*noequiv ); 77 78switch acinfo,sidrel,priall,primat,prefix,optdecs,again,inputc,vectorc, 79 intern$ 80 81% ------------------------------------------------------------------- ; 82% Initial settings for the globals. ; 83% ------------------------------------------------------------------- ; 84codmat:=!*priall:=!*primat:=!*sidrel:=!*optdecs:=optlang!*:=nil; 85!*again:=!*prefix:=!*acinfo:=!*inputc:=!*intern:=!*vectorc:=nil; 86min!-expr!-length!*:=nil; 87rowmin:=0; rowmax:=-1; 88 89% ------------------------------------------------------------------- ; 90% Description of global variables and switches. ; 91% ------------------------------------------------------------------- ; 92% MATRIX ACCESS: ; 93% ; 94% CODMAT : is a vector used to store the +,* matrices,merged in CODMAT; 95% MAXVAR : The size of this merged matrix is 2*MAXVAR. ; 96% ROWMAX : Largest actual scope_row index. ; 97% ROWMIN : Smallest actual column index. ; 98% ENDMAT : Value of MAXVAR when cse-search starts. ; 99% ; 100% Remark - The storage strategy can be vizualized as follows: ; 101% ; 102% MAXVAR + MAXVAR ; 103% -------|------------------------------------------------| ; 104% | Storage left for cse's | ; 105% -------|------------------------------------------------| ; 106% MAXVAR + ROWMAX (ENDMAT when input processing completed)| ; 107% -------|------------------------------------------------| ; 108% | Matrix Rows:Input decomposition | ; 109% -------|------------------------------------------------| ; 110% MAXVAR + 0 | ; 111% -------|------------------------------------------------| ; 112% | Matrix columns:Variable occurrence information | ; 113% -------|------------------------------------------------| ; 114% MAXVAR - ROWMIN | ; 115% -------|------------------------------------------------| ; 116% | Storage left for cse-occurrence information | ; 117% -------|------------------------------------------------| ; 118% MAXVAR - MAXVAR | ; 119% ; 120% ; 121% CSE-NAME SELECTION ; 122% ; 123% Cname!* : Created in INAME and exploded representation of letter- ; 124% part of current cse-name. ; 125% Cindex!*: Current cse-number. If cindex!*:=Nil then GENSYM() is use; 126% Bnlst : List of initial cse-names. When !*AGAIN=T used to save ; 127% these names via CSES:=('PLUS.Bnlst).If necessary extended; 128% with last GENSYM-generation(see MAKEPREFIXLIST). This ; 129% assignment statement preceeds other output and is used in; 130% FFVAR!! (see module CODMAT) to flag all old cse-names ; 131% with NEWSYM when continuing with next set of input files.; 132% ; 133% The cse-name generation process is organized by the procedures ; 134% INAME,NEWSYM1 and FNEWSYM. The procedure DIGITPART is needed in ; 135% FFVAR!! (via RestoreCseInfo) to restore the cse-name flags NEWSYM.; 136% This information is saved by SaveCseInfo (see MAKEPREFIXLST). ; 137% ; 138% SWITCHES : THE ON-EFFECT IS DESCRIBED ; 139% ; 140% ACinfo : (Evaluated) input and Operation counts displayed with-; 141% out disturbing Outfile declarations. ; 142% Primat : Initial and final state of matrix CODMAT is printed. ; 143% Priall : Turns !*ACinfo,!*Primat on. ; 144% Prefix : Output in pretty printed prefixform. ; 145% Again : Optimization of partioned input will be continued a ; 146% next time. Cse's added to prefixlist and finishing ; 147% touch delayed. ; 148% SidRel : The Optimizer output, collected in Prefixlist, is re- ; 149% written, using the procedure EvalPart, defined in this; 150% module, resulting in a list of (common sub)expressions; 151% with PLUS or DIFFERENCE as their leading operator, ; 152% when ever possible. ; 153% Optdecs : The output is preceded by a list of declarations. ; 154% ; 155% REMAINING GLOBALS ; 156% ; 157% Prefixlist : Association list defining output. Built in CODPRI-part; 158% 2 and used either via ASSGNPRI (ON FORT or ON/OFF NAT); 159% or via PRETTYPRINT (ON PREFIX). ; 160% Pre- ; 161% Prefixlist : Rational exponentiations require special provisions ; 162% during parsing, such as the production of this list of; 163% special assignments, made as side-effect of the appli-; 164% cation of the function PrepMultMat in SSetVars (see ; 165% the module CODMAT). This list is put in front of the ; 166% list Prefixlist. ; 167% Prevlst : Used in FFVAR!! to store information about expression ; 168% hierarchy when translating input. ; 169% Later used (initialized in SSETVARS) to obtain correct; 170% (sub)expression ordering. ; 171% Kvarlst : Used for storing information about kernels. ; 172% Optlang!* : Its value ('FORTRAN, 'C, for instance) denotes the ; 173% target language selection for the output production. ; 174% CodBexl!* : List consisting of expression recognizers. It guaran- ; 175% tees a correct output sequence. Its initial structure ; 176% is built in FFVAR!! and modified in IMPROVELAYOUT,for ; 177% instance, when superfluous intermediate cse-names are ; 178% removed. ; 179% ------------------------------------------------------------------- ; 180 181% ------------------------------------------------------------------- ; 182% Some GENTRAN modules are required to obtain a correct interface. ; 183% The file names are installation dependent. ; 184% ------------------------------------------------------------------- ; 185 186%IN "$gentranutil/sun-gentran-load"$ 187 load!-package 'gentran$ % Moet worden gentran90 !! 188 189% Load and initialize rounded-package 190if not !*rounded then << on 'rounded; off 'rounded >>; 191 192 193% ------------------------------------------------------------------- ; 194% PART 1 : Interface between Scope and Reduce. ; 195% ------------------------------------------------------------------- ; 196 197% ------------------------------------------------------------------- ; 198% ALGEBRAIC MODE COMMAND PARSER ; 199% ------------------------------------------------------------------- ; 200 201put('optimize, 'stat, 'optimizestat); 202 203 204global '(optlang!* avarlst known rhsaliases); 205fluid '(!*fort preprefixlist prefixlist); 206 207symbolic expr procedure optimizestat; 208 % --------------------------------------------------------------- ; 209 % OPTIMIZE command parser. ; 210 % --------------------------------------------------------------- ; 211 begin scalar forms, vname, infiles, outfile, x, decs, kwds, delims; 212 symtabrem('!*main!*,'!*decs!*); 213 kwds := '(iname in out declare); 214 delims := append(kwds, '(!*semicol!* !*rsqb!* end)); 215 flag(kwds, 'delim); 216 while not memq(cursym!*, delims) do 217 if (x := xreadforms()) then 218 forms := append(forms, x); 219 while memq(cursym!*, kwds) do 220 if eq(cursym!*, 'iname) then 221 vname := xread t 222 else if eq(cursym!*, 'in) then 223 if atom (x := xread nil) then 224 infiles := list x 225 else if eqcar(x, '!*comma!*) then 226 infiles := cdr x 227 else 228 infiles := x 229 else if eq(cursym!*, 'out) then 230 outfile:=xread t 231 else if eq(cursym!*, 'declare) then 232 decs := append(decs, cdr declarestat()); 233 remflag(kwds, 'delim); 234 return list('symoptimize, mkquote forms, 235 mkquote infiles, 236 mkquote outfile, 237 mkquote vname, 238 mkquote decs) 239 end; 240 241% ------------------------------------------------------------------- ; 242% ALGEBRAIC MODE OPERATOR ALGOPT ; 243% ------------------------------------------------------------------- ; 244 245symbolic procedure algopteval u; 246% ------------------------------------------------------------------- ; 247% Algebraic mode interface in the form of a function-application. The ; 248% procedure algresults1 is used for result production. ; 249% u = list of the form : (forms, filesnames, csename). The arguments ; 250% are optional. ; 251% forms is a list of eq's, defining pairs (lhs-name,rhs-value), ; 252% filenames is a list of filenames, containing symtactically correct ; 253% input and the csename, optional too, is the initial cse-name part, ; 254% a scalar. ; 255% --------------------------------------------------------------------; 256begin 257 scalar su,res,intern!*; integer nargs; 258 intern!*:=!*intern; !*intern:='t; 259 nargs := length u; 260 u:=foreach el in u collect 261 if listp(el) and eqcar(el,'list) and allstring(cadr el) 262 then cdr(el) else el; 263 if listp(car u) and not(allstring car u) and not(eqcar(car u,'list)) 264 then u:=list('list,car u).cdr u; 265 res := 266 if nargs = 1 267 then if su:=allstring(car u) 268 then symoptimize(nil,su,nil,nil,nil) 269 else symoptimize(car u,nil,nil,nil,nil) 270 else if nargs = 2 271 then if su:=allstring(cadr u) 272 then symoptimize(car u,su,nil,nil,nil) 273 else if (su:=allstring(car u)) and atom cadr u 274 then symoptimize(nil,su,nil,cadr u,nil) 275 else if atom cadr u 276 then symoptimize(car u,nil,nil,cadr u,nil) 277 else '!*!*error!*!* 278 else if nargs = 3 and (su:=allstring cadr u) 279 then symoptimize(car u,su, nil, caddr u,nil) 280 else '!*!*error!*!*; 281 !*intern:=intern!*; 282 if eq(res,'!*!*error!*!*) 283 then rederr("SYNTAX ERROR IN ARGUMENTS ALGOPT") 284 else return algresults1(foreach el in res 285 collect cons(cadr el,caddr el)) 286 end; 287 288put ('algopt,'psopfn,'algopteval); 289 290symbolic procedure allstring s; 291% ------------------------------------------------------------------- ; 292% Consists s of one are more filenames? ; 293% ------------------------------------------------------------------- ; 294if atom s 295 then if stringp s then list(s) 296 else nil 297else if not(nil member foreach el in s collect stringp el) then s 298 else nil; 299 300 301% ------------------------------------------------------------------- ; 302% SYMBOLIC MODE PROCEDURE ; 303% ------------------------------------------------------------------- ; 304 305global '(!*algpri !*optdecs)$ 306switch algpri,optdecs$ 307!*optdecs:=nil$ 308 309symbolic expr procedure symoptimize(forms,infiles,outfile,vname,decs); 310 % --------------------------------------------------------------- ; 311 % Symbolic mode function. ; 312 % --------------------------------------------------------------- ; 313 begin scalar algpri,echo,fn,forms1,optdecs, comdecs; 314 echo:=!*echo; 315 eval list('off, mkquote list 'echo); 316 if infiles then 317 forms := append(forms, files2forms infiles); 318 algpri := !*algpri; 319 !*echo:=echo; 320 if decs 321 then << optdecs:=!*optdecs; !*optdecs:=t; 322 % JB 31/3/94 Fixed to deal with complex input: 323 if (comdecs:=assoc('complex, decs)) or 324 (comdecs:=assoc('complex!*16, decs)) 325 then <<if not freeof(comdecs,'i) 326 then forms:= '(setq i (sqrt (minus 1))) 327 . forms; 328 329 >> 330 >>; 331 eval list('off, mkquote list 'algpri); 332 if vname then iname vname; 333 forms := analyse_forms(forms); 334 !*algpri := algpri; 335 preproc1 ('declare . decs); 336% prefixlist:=segmentation_if_needed(forms,outfile,vname); 337 prefixlist:= 338 eval formoptimize(list('optimizeforms,forms,outfile,vname), 339 !*vars!*, 340 !*mode); 341 if decs then !*optdecs:=optdecs; 342 343 if !*intern 344 then return (foreach el in prefixlist 345 collect list('setq,car el,cdr el)) 346 end$ 347 348symbolic expr procedure symoptimize(forms,infiles,outfile,vname,decs); 349 % --------------------------------------------------------------- ; 350 % Symbolic mode function. ; 351 % --------------------------------------------------------------- ; 352 begin scalar algpri,echo,fn,forms1,optdecs,comdecs; 353 354 echo:=!*echo; 355 eval list('off, mkquote list 'echo); 356 if infiles then 357 forms := append(forms, files2forms infiles); 358 algpri := !*algpri; 359 !*echo:=echo; 360 if decs 361 then <<optdecs:=!*optdecs; !*optdecs:=t; >>; 362 eval list('off, mkquote list 'algpri); 363 if vname then iname vname; 364 forms := analyse_forms(forms); 365 !*algpri := algpri; 366 preproc1 ('declare . decs); 367 prefixlist:= 368 eval formoptimize(list('optimizeforms,forms,outfile,vname), 369 !*vars!*, 370 !*mode); 371 if decs then !*optdecs:=optdecs; 372 %else !*gendecs:=optdecs; 373 374 if !*intern 375 then return (foreach el in prefixlist 376 collect list('setq,car el,cdr el)) 377 end$ 378 379 380symbolic procedure analyse_forms(forms); 381% --------------------------------------------------------------------; 382% forms is recursively analysed and replaced by a flattened list of ; 383% items, which are either of the form ('setq lhs rhs) or have the ; 384% structure ('equal lhs rhs). 385% Here lhs can be a scalar, a matrix or an array identifier. ; 386% The rhs is a REDUCE expression in prefix form. During the analysis ; 387% scalar, matrix or array identifier elements of the list forms are ; 388% replaced by the prefix equivalent of their algebraic value, which is; 389% assumed to be a list of equations of the form ; 390% {lhs1=rhs1,...,lhsn=rhsn}. ; 391% Similarly elements of forms, being function-applications (either ; 392% symbolic operators or psopfn facilities), evaluable to lists of the ; 393% above mentioned structure, are replaced by their evaluations. ; 394% ------------------------------------------------------------------- ; 395begin scalar fn,res,forms1; 396if atom(forms) then forms:=list(forms) 397else if (listp(forms) and get(car forms,'avalue) 398 and car(get(car forms,'avalue)) member '(array matrix)) 399 then forms:=list(forms) 400else if listp forms and eqcar(forms,'list) then forms:=cdr forms; 401res:= 402 foreach f in forms conc 403 if atom(f) and car(get(f,'avalue))='list then cdr reval f 404 else if listp(f) and get(car f,'avalue) and 405 car(get(car f,'avalue)) member '(array matrix) 406 then cdr reval f 407 else if listp(f) and eqcar(f,'list) then list f 408 else if listp(f) and eqcar(f,'equal) and eqcar(caddr f,'!*sq) 409 then list list('equal,cadr f,sq2pre caddr f) 410 else if listp(f) and 411 not member(car f,'(equal lsetq lrsetq rsetq setq)) 412 then <<forms1:= 413 apply(if fn:=get(car f,'psopfn) then fn else car f, 414 if get(car f,'psopfn) 415 then list(foreach x in cdr f collect x) 416 else foreach x in cdr f collect x); 417 if pairp(forms1) and eqcar(forms1,'list) 418 then cdr forms1 else forms1 419 >> 420 else list f; 421return foreach f in res conc 422 if listp(f) and eqcar(f,'list) then analyse_forms(cdr f) else list f 423end; 424 425symbolic expr procedure xreadforms; 426 begin scalar x; 427 x := xread t; 428 if listp x and eqcar(x, 'list) then 429 return flattenlist x 430 else if x then 431 return list x 432 else 433 return x 434 end; 435 436symbolic expr procedure flattenlist x; 437 if atom(x) or constp(x) then 438 x 439 else 440 << if eqcar(x, 'list) then 441 foreach y in cdr x collect flattenlist y 442 else 443 x 444 >>; 445 446symbolic expr procedure files2forms flist; 447 begin scalar ch, holdch, x, forms; 448 holdch := rds nil; 449 forms := nil; 450 foreach f in flist do 451 << 452 ch := open(mkfil f, 'input); 453 rds ch; 454 while (x := xreadforms()) do 455 forms := append(forms, x); 456 rds holdch; 457 close ch 458 >>; 459 return forms 460 end; 461 462 463symbolic expr procedure formoptimize(u, vars, mode); 464 car u . foreach arg in cdr u 465 collect formoptimize1(arg, vars, mode); 466 467symbolic procedure chopchop rep; 468% rep : m . e; 469% no trailing zeros in m; e < 0. 470% rep is the cdr-part of a (!:rd!: !:cr!: !:crn!: !:dn!:)-notation. 471if length(explode abs car rep)> !!rdprec 472 then begin 473 scalar sgn,restlist,lastchop,exppart; 474 restlist:=reverse explode abs(car rep); 475 sgn:=(car rep < 0); 476 exppart:= cdr rep; 477 while length(restlist) > !!rdprec 478 do << lastchop:=car restlist; 479 restlist:=cdr restlist; 480 exppart:=exppart+1 >>; 481 restlist:= compress reverse restlist; 482 if compress list lastchop >= 5 483 then restlist:=restlist + 1; 484 return (if sgn then -1*restlist else restlist) . exppart; 485 end 486 else rep; 487 488symbolic expr procedure formoptimize1(u, vars, mode); 489 if constp u 490 then mkquote u % JB 30/3/94. 491 % Constants are not neccesarily atoms. 492 else 493 if atom u 494 then mkquote u 495 else if member(car u,'(!:rd!: !:cr!: !:crn!: !:dn!:)) 496 then % JB 31/3/94 This seems to work. Honestly 497 % stolen from formgentran. 498 mkquote <<%precmsg length explode abs car(u := cdr u); 499 u:=chopchop cdr u; 500 decimal2internal(car u,cdr u)>> 501 else if eq(car u,'!:int!:) 502 then mkquote cadr u 503 else if eqcar(u, 'eval) then 504 list('sq2pre, list('aeval, form1(cadr u, vars, mode))) 505 else if car u memq '(lsetq rsetq lrsetq) then 506 begin scalar op, lhs, rhs; 507 op := car u; 508 lhs := cadr u; 509 rhs := caddr u; 510 if op memq '(lsetq lrsetq) and listp lhs then 511 lhs := car lhs . foreach s in cdr lhs 512 collect list('eval, s); 513 if op memq '(rsetq lrsetq) then 514 rhs := list('eval, rhs); 515 return formoptimize1(list('setq, lhs, rhs), vars, mode) 516 end 517 else 518 ('list . foreach elt in u 519 collect formoptimize1(elt, vars, mode)); 520 521symbolic expr procedure sq2pre f; 522 if atom f then 523 f 524 else if listp f and eqcar(f, '!*sq) then 525 prepsq cadr f 526 else 527 prepsq f; 528 529% ------------------------------------------------------------------- ; 530% CALL CODE OPTIMIZER ; 531% ------------------------------------------------------------------- ; 532 533symbolic procedure optimizeforms(forms,outfile,vname); 534begin 535 scalar noequiv,double,period,ch,fort,holdch,optlang,primat, 536 acinfo,inputc; 537 period:=!*period; !*period:=nil; % No periods in subscripts please. 538 noequiv:=!*noequiv; !*noequiv:=t; % No equivalence check, see coddom 539 double:=!*double; 540 put('!:rd!:,'zerop,'rd!:zerop!:); % New zerop which respects 541 % precision-setting, onep is o.k. 542 if vname and not(getd('newsym)) then iname vname; 543 if !*fort then << fort:=t;!*fort:=nil; 544 optlang:=optlang!*; optlang!*:='fortran>>; 545 if outfile then 546 << if not(optlang!*) 547 then << holdch:=wrs nil; % get old output channel 548 if ch:=assoc(intern outfile,!*outstk!*) 549 then ch:=cdr ch 550 else ch:=open(mkfil outfile,'output); 551 wrs ch % set output channel to ch 552 >> 553 else eval list('gentranoutpush,list('quote,list(outfile))) 554 >>; 555 if !*priall % Save previous flag configuration. 556 then << primat:=!*primat; acinfo:=!*acinfo; inputc:=!*inputc; 557 !*primat:=!*acinfo:=!*inputc:=t >>; 558 559 prefixlist:=calc forms; 560 561 if !*priall then % Restore original flag configuration. 562 << !*primat:=primat; !*acinfo:=acinfo; !*inputc:=inputc >>; 563 if outfile then 564 << if not(optlang!*) 565 then 566 << if (not(!*nat) or !*again) then write ";end;"; 567 % Restore output channel 568 if assoc(intern outfile,!*outstk!*) 569 then <<terpri(); wrs holdch>> else <<wrs holdch; close ch>> 570 >> 571 else eval '(gentranpop '(nil)) 572 >>; 573 if fort then << !*fort:=t; optlang!*:=optlang>>; 574 put('!:rd!:,'zerop,'rd!:zerop); 575 !*double:=double; !*noequiv:=noequiv; !*period := period; 576 return prefixlist; 577end; 578 579symbolic procedure opt forms; 580 % --------------------------------------------------------------- ; 581 % Replace each sequence of one or more assignment(s) by its ; 582 % optimized equivalent sequence. ; 583 % --------------------------------------------------------------- ; 584 begin scalar seq, res, fort, optlang; 585 fort:=!*fort; 586 !*fort:=nil; 587 optlang:=optlang!*; 588 optlang!*:=gentranlang!*; 589 if atom forms then 590 res := forms 591 else if eqcar(forms, 'setq) then 592 << 593 res := foreach pr in optimizeforms(list forms, nil, nil) 594 collect list('setq, car pr, cdr pr); 595 if onep length res 596 then res := car res 597 else res := mkstmtgp(0, res) 598 >> 599 else if atom car forms then 600 res := (car forms . opt cdr forms) 601 else 602 << 603 seq := nil; 604 while forms and listp car forms and eqcar(car forms, 'setq) 605 do <<seq := (car forms . seq); forms := cdr forms>>; 606 if seq then 607 <<seq := foreach pr in optimizeforms(reverse seq, nil, nil) 608 collect list('setq, car pr, cdr pr); 609 if length seq > 1 then 610 seq := list mkstmtgp(0, seq); 611 res := append(seq, opt forms) 612 >> 613 else 614 res := (opt car forms . opt cdr forms); 615 >>; 616 optlang!*:=optlang; 617 !*fort:=fort; 618 return res; 619 end; 620 621 622% ------------------------------------------------------------------- ; 623% PART 2 : Control of overall optimization process. ; 624% ------------------------------------------------------------------- ; 625 626symbolic procedure init n; 627% ------------------------------------------------------------------- ; 628% arg: Size of the matrix N. ; 629% eff: Initial state (re)created by (re)initializing the matrix CODMAT; 630% and some related identifiers. ; 631% ------------------------------------------------------------------- ; 632begin scalar var; 633 for y:=rowmin:rowmax do 634 if scope_row(y) and not numberp(var:=scope_farvar y) 635 then 636 <<remprop(var,'npcdvar); remprop(var,'nvarlst); 637 remprop(var,'varlst!+); remprop(var,'varlst!*); 638 remprop(var,'rowindex); 639 remprop(var,'nex); 640 remprop(var,'inlhs); 641 remprop(var,'rowocc); 642 remprop(var,'kvarlst); 643 remprop(var,'alias);remprop(var,'finalalias); 644 remprop(var,'aliaslist);remprop(var,'inalias); 645 >>; 646 if maxvar=n 647 then for x:=0:2*n do putv(codmat,x,nil) 648 else codmat:=mkvect(2*n); 649 if kvarlst then foreach item in kvarlst do 650 << remprop(cadr item,'kvarlst); 651 remprop(cadr item,'nex) 652 >>; 653 foreach item in '(plus minus difference times expt sqrt) do 654 remprop(item,'kvarlst); 655 %------------------------------------------------------------------- 656 % If not all algresults were reversed by the user, by means of 657 % `restorall', or `arestore', they become irreversible commited 658 % after the following resetting of `avarlst'. 659 %------------------------------------------------------------------- 660 %bnlst:= 661 varlst!*:=varlst!+:=prevlst:=kvarlst:=codbexl!*:=avarlst:=nil; 662 malst:=preprefixlist:=nil; prefixlist:=nil; 663 rowmax:=-1; maxvar:=n; 664 rowmin:=0; 665 ops:=list(0,0,0,0) 666end; 667 668 669symbolic procedure calc forms; 670% ------------------------------------------------------------------- ; 671% CALC produces,via OPTIMIZELOOP, the association list PREFIXLIST. ; 672% This list is used for output production by apllying PRIRESULT. ; 673% ------------------------------------------------------------------- ; 674begin scalar fil; 675 init 200; 676 prefixlist:=rhsaliases:=nil; 677 forms := preremdep forms; 678 foreach item in forms do 679 prefixlist:=ffvar!!(cadr item, caddr item, prefixlist); 680 preprefixlist:=ssetvars(preprefixlist); % Complete parsing. 681 fil:=wrs(nil); % Save name output file,which has to be ; 682 % used for storing the final results ; 683 if !*primat then primat(); 684 if !*acinfo then countnop(reverse prefixlist,'input); 685 optimizeloop(); 686 terpri(); 687 wrs(fil); 688 prefixlist:=makeprefixl(preprefixlist,nil); 689 if !*gentranopt 690 then typeall(prefixlist) 691 else if not !*intern 692 then priresult(prefixlist); 693 fil:=wrs(nil); 694 if getd('newsym) then remd('newsym); %bnlst:=nil; 695 if !*acinfo then << countnop(reverse prefixlist,'output); terpri()>>; 696 if !*primat 697 then << for x:=rowmin:rowmax do if scope_farvar(x)=-1 or scope_farvar(x)=-2 698 then scope_setoccup(x) else scope_setfree(x); 699 primat(); 700 >>; 701 wrs(fil); 702 return prefixlist 703end$ 704 705 706% ------------------------------------------------------------------- ; 707% Reduce interface for CALC, allowing the command CALC instead of ; 708% CALC(). ; 709% ------------------------------------------------------------------- ; 710 711% put('calc,'stat,'endstat); 712 713 714symbolic procedure pprintf(ex,nex); 715% --------------------------------------------------------------------; 716% arg : The name Nex of an expression Ex. ; 717% eff : Nex:=Ex is printed using assgnpri on the output medium without; 718% disturbing the current file management and output flagsettings; 719% --------------------------------------------------------------------; 720begin scalar s,fil,nat; 721 terpri(); 722 fil:=wrs(nil); 723 if not(!*nat) then << nat:=!*nat; s:=!*nat:=t>>; 724 assgnpri(ex,list nex,'last); 725 wrs(fil); 726 if s then !*nat:=nat 727end; 728 729symbolic procedure optimizeloop; 730% ------------------------------------------------------------------- ; 731% Iterative cse-search. ; 732% ------------------------------------------------------------------- ; 733begin scalar b1,b2,b3,b4; 734 repeat 735 << extbrsea(); 736 % --------------------------------------------------------------- ; 737 % Extended Breuer search (see module CODOPT): ; 738 % Common linear expressions or power products are heuristically ; 739 % searched for using methods which are partly based on Breuer's ; 740 % grow factor algorithm. ; 741 % --------------------------------------------------------------- ; 742 b1:=improvelayout(); 743 % --------------------------------------------------------------- ; 744 % Due to search strategy, employed in EXTBRSEA, identical cse's ; 745 % can have different names. IMPROVELAYOUT (see module CODAD1 is ; 746 % used to detect such situations and to remove double names. ; 747 % --------------------------------------------------------------- ; 748 b2:=tchscheme(); 749 % --------------------------------------------------------------- ; 750 % Migration of information, i.e. the newly generated cse-names for; 751 % linear expressions occuring as factor in a product are transfer-; 752 % red from the + to the * scheme. Similar operations are performed; 753 % for power products acting as terms. File CODAD1.RED contains ; 754 % TCHSCHEME. ; 755 % --------------------------------------------------------------- ; 756 b3:=codfac(); 757 % --------------------------------------------------------------- ; 758 % Application of the distributive law,i.e. a*b + a*c is changed in; 759 % a*(b + c) and expression storage in CODMAT is modified according; 760 % ly. File CODAD1.RED contains CODFAC. ; 761 % --------------------------------------------------------------- ; 762 b4:=searchcsequotients(); 763 >> 764 until not(b1 or b2 or b3 or b4); 765end; 766 767symbolic procedure countnop(prefixlst,io); 768% ------------------------------------------------------------------- ; 769% The number of +/-, unary -, *, integer ^, / and function applica- ; 770% tions is counted in prefixlist, consisting of pairs (lhs.rhs). Array; 771% references are seen as function applications if the array name is ; 772% not contained in the symbol table. The content of the symbol table ; 773% is prescribed through the declare-option of the optimize-command, ; 774% i.e. when io='input, and posibly modified after optimization, i.e. ; 775% when io='output. ; 776% ------------------------------------------------------------------- ; 777begin scalar totcts; 778 totcts:='(0 0 0 0 0 0); 779 foreach item in prefixlst do 780 << if pairp(car item) then totcts:=counts(car item,totcts,nil); 781 totcts:=counts(cdr item,totcts,nil) 782 >>; 783 terpri(); 784 if io eq 'input 785 then write "Number of operations in the input is: " 786 else write "Number of operations after optimization is:"; 787 terpri(); terpri(); 788 write "Number of (+/-) operations : ",car totcts; terpri(); 789 write "Number of unary - operations : ",cadr totcts; terpri(); 790 write "Number of * operations : ",caddr totcts; terpri(); 791 write "Number of integer ^ operations : ",cadddr totcts; terpri(); 792 write "Number of / operations : ",car cddddr totcts;terpri(); 793 write "Number of function applications : ",car reverse totcts;terpri() 794end; 795 796symbolic procedure counts(expression,locs,root); 797% ------------------------------------------------------------------- ; 798% The actual counts are recursively done with the function counts by ; 799% modifying the value of the 6 elements of locs. The elements of locs; 800% define the present number of the 6 possible categories of operators,; 801% which we distinguish. ; 802% ------------------------------------------------------------------- ; 803begin scalar n!+,n!-,n!*,n!^,n!/,n!f,tlocs,loper,operands; 804 if idp(expression) or constp(expression) 805 then tlocs:=locs 806 else 807 << n!+:=car locs; n!-:=cadr locs; n!*:=caddr locs; n!^:=cadddr locs; 808 n!/:=car cddddr locs; n!f:= car reverse locs; 809 loper:=car expression; operands:=cdr expression; 810 if loper memq '(plus difference) 811 then n!+:=(length(operands)-1)+n!+ 812 else 813 if loper eq 'minus 814 then (if root neq 'plus then n!-:=1+n!-) 815 else 816 if loper eq 'times 817 then n!*:=(length(operands)-1)+n!* 818 else 819 if loper eq 'expt 820 then (if integerp(cadr operands) 821 then n!^:=1+n!^ else n!f:=1+n!f) 822 else 823 if loper eq 'quotient 824 then n!/:=1+n!/ 825 else 826 if not(subscriptedvarp(loper)) 827 then n!f:=1+n!f; 828 tlocs:=list(n!+,n!-,n!*,n!^,n!/,n!f); 829 foreach op in operands do tlocs:=counts(op,tlocs,loper) 830 >>; 831 return(tlocs) 832end; 833 834symbolic procedure complex!-i!-init!-statement st; 835% 836% See if we need to initialize i. 837% 838begin scalar tl, res; 839 tl:=formtypelists symtabget('!*main!*,'!*decs!*); 840 foreach el in tl do 841 <<if member(car el, 842 '(complex implicit! complex implicit! complex!*16)) 843 and member('i, el) 844 then res := 845 if !*double 846 then if st then "i=(0.0D0, 1.0D0)" 847 else '((literal tab!* "I=(0.0D0, 1.0D0)" cr!*)) 848 else if st then "i=(0.0, 1.0)" 849 else '((literal tab!* "I=(0.0, 1.0)" cr!*)) 850 >>; 851 return res; 852 end; 853 854symbolic procedure priresult(prefixlist); 855% ------------------------------------------------------------------- ; 856% Besides flag settings and the like the essential action is printing.; 857% ------------------------------------------------------------------- ; 858begin scalar pfl,nat,istat; 859 if !*optdecs then typeall prefixlist; 860 861 if optlang!* 862 then << if null(assoc('e,prefixlist)) then symtabrem(nil,'e); 863 pfl := foreach pr in prefixlist collect 864 list('setq, car pr,lispcodeexp(cdr pr,!*period)); 865 if (istat:=complex!-i!-init!-statement(nil)) 866 then pfl := append(istat, pfl); 867 pfl := list mkstmtgp(0, pfl); 868 apply1(get(optlang!*, 'formatter), 869 apply1(get(optlang!*, 'codegen), pfl)); 870 >> 871 else if !*prefix 872 then << write "Prefixlist:="; 873 terpri(); 874 prettyprint(prefixlist) 875 >> 876 else << if !*optdecs then printdecs(); 877 if (istat:=complex!-i!-init!-statement('t)) 878 then <<write caddar istat;terpri()>>; 879 if not !*again 880 then 881 foreach item in prefixlist do 882 assgnpri(cdr item,list car item,'last) 883 else 884 << nat:=!*nat; !*nat:=nil; 885 assgnpri(append(list('list), 886 for each item in prefixlist 887 collect list('setq,car item,cdr item)), 888 nil,'last); 889 !*nat:=nat; 890 terpri();%write ";end;"; % done by nat being off. 891 % JB 15/3/94 892 >> 893 >> 894end; 895 896symbolic procedure printdecs; 897% ------------------------------------------------------------------- ; 898% A list of declarations is printed. ; 899% ------------------------------------------------------------------- ; 900begin 901 scalar typ; 902 terpri!* t; 903 for each typelist in formtypelists symtabget('!*main!*, '!*decs!*) 904 do << if !*double then 905 << typ:=assoc(car typelist, 906 '((real . double! precision) (complex . complex!*16) 907 (implicit! real . implicit! double! precision) 908 (implicit! complex . implicit! complex!*16))); 909 typ:=if null typ then car typelist else cdr typ 910 >> 911 else 912 typ:=car typelist; 913 prin2!* typ; 914 prin2!* " "; 915 inprint('!*comma!*, 0, cdr typelist); 916 terpri!* t 917 >> 918end; 919 920global '(!*ftch); 921switch ftch; 922!*ftch:='t; 923 924symbolic procedure makeprefixl(pp,prefixlist); 925% ------------------------------------------------------------------- ; 926% If the finishing touch is appropriate, i.e. if OFF AGAIN holds ; 927% PREPFINALPLST is called before producing PREFIXLIST using a FOREACH ; 928% statement. If the optimization attempts have to be continued during ; 929% another session(i.e. ON AGAIN) SAVECSEINFO is called to guarantee ; 930% all relevant cse-information to be saved. ; 931% ------------------------------------------------------------------- ; 932begin scalar b,kvl,nex,xx; 933 if not(!*again) 934 then prepfinalplst(); 935 for x:=0:rowmax do scope_setfree(x); 936 937 kvl:=kvarlst; 938 939 foreach bex in reverse(codbexl!*) do 940 <<if numberp(bex) % --------------------- ; 941 then prefixlist:=prfexp(bex,prefixlist) % Leading operator is ; 942 % ^,*,+ or - . ; 943 else prefixlist:=prfkvar(bex,prefixlist); % Another leading ; 944 % operator. ; 945 >>; % --------------------- ; 946 % ----------------------------------------------------------------- ; 947 % Possibly, information about primitive factors of the form ; 948 % ('EXPT <identifier> <rational exponent>) as given in the list ; 949 % PrePrefixlist is put in front of Prefixlist. ; 950 % ----------------------------------------------------------------- ; 951 kvarlst:=kvl; 952 prefixlist:=reverse prefixlist; 953 if !*optdecs or !*gentranopt then 954 prefixlist:=removearraysubstitutes(prefixlist); 955 prefixlist:=cleanupprefixlist(prefixlist); 956 if !*sidrel then prefixlist:=evalpartprefixlist(prefixlist); 957 if !*again then prefixlist:=savecseinfo(prefixlist); 958 return prefixlist 959end$ 960 961global '(!*min!-expr!-length!*)$ 962!*min!-expr!-length!*:=nil$ 963 964symbolic procedure prepfinalplst; 965% ------------------------------------------------------------------- ; 966% The refinements defined by this procedure - the socalled finishing ; 967% touch - are only applied directly before producing the final version; 968% of the output, i.e. the optimized version of the input. ; 969% These refinements are: ; 970% - POWEROFSUMS (see module CODAD2): Replace (a+b+...)^intpower by ; 971% cse1=(a+b+...),cse1^intpower. ; 972% - CODGCD (see module CODAD2): Replace 4.a+2.b+2.c+4.d by ; 973% 2.(2.(a+d)+b+c),where a,b,c,d can ; 974% be composite as well. ; 975% - REMREPMULTVARS (see CODAD2) : Replace 3.a+b,3.a+c by ; 976% cse3=3.a,cse3+b,cse3+c. ; 977% - UPDATEMONOMIALS (see CODAD2) : Replace 3.a.b, 3.a.c., 6.a.d, ; 978% 6.a.f by ; 979% cse4=3.a, cse4.b, cse4.c, cse5=6.a; 980% cse5.d, cse5.f. ; 981% ------------------------------------------------------------------- ; 982begin scalar n; 983 if (!*vectorc or !*sidrel or not !*ftch 984 or not null(min!-expr!-length!*)) % HvH 8/11/94 985 then codgcd() 986 else << repeat 987 << n:=rowmax; 988 powerofsums(); 989 remrepmultvars(); 990 updatemonomials(); 991 codgcd(); 992 if not(n=rowmax) then optimizeloop() 993 >> until n=rowmax; 994 preppowls() 995 >>; 996 if not !*ftch and optlang!*='c then preppowls() 997 % ----------------------------------------------------------------- ; 998 % PREPPOWLS (see module CODPRI, part 2) serves to create addition ; 999 % chains for integer powers, such as cse1^intpower (due to ; 1000 % POWEROFSUMS) and cse4=a^3 (produced by UPDATEMONOMIALS). ; 1001 % ----------------------------------------------------------------- ; 1002end; 1003 1004symbolic procedure savecseinfo(prefixlist); 1005% ------------------------------------------------------------------- ; 1006% If ON AGAIN then cse-information have to be saved. This is done by ; 1007% extending PREFIXLIST resulting in: ; 1008% ((CSES.cses) (GSYM.gsym) PREFIXLIST) or ; 1009% ((CSES.cses) (BINF.binf) PREFIXLIST). ; 1010% Here ; 1011% CSES=first cse nsme[+...+ last cse name], ; 1012% GSYM=GENSYM(), if GENSYM has been used for cse-name generation, ; 1013% because we do not want to generate identical cse-names during a; 1014% next run when using GENSYM. ; 1015% If GENSYM is not used then we create ; 1016% BINF=first initial cse-name[+...+ last initial cse-name],thus saving; 1017% the Bnlst. ; 1018% ------------------------------------------------------------------- ; 1019begin scalar cses,gsym,binf; 1020 foreach item in prefixlist do 1021 if pairp(item) and flagp( car(item),'newsym) 1022 then cses:=car(item).cses; 1023 if pairp(cses) then if cdr(cses) then cses:='plus.cses 1024 else cses:=car cses; 1025 prefixlist:=('cses.cses).prefixlist; 1026 return if cses 1027 then ('gsym . fnewsym()) . prefixlist 1028 else ('gsym . gensym()) . prefixlist 1029end; 1030 1031symbolic operator iname; 1032 1033symbolic procedure iname(nm); 1034% ------------------------------------------------------------------- ; 1035% Construction of initial cse-name, extension of Bnlst and creation of; 1036% NEWSYM procedure via MOVD and using NEWSYM1. ; 1037% If, for instance, the initial name is aa55 then NEWSYM1 generates ; 1038% aa55, aa56 , aa57, etc. ; 1039% ------------------------------------------------------------------- ; 1040 begin scalar digitl,dlst,nb,dg,initname; 1041 digitl:='((!1 . 1) (!2 . 2) (!3 . 3) (!4 . 4) (!5 . 5) 1042 (!6 . 6) (!7 . 7) (!8 . 8) (!9 . 9) (!0 . 0)); 1043 cname!*:=nil; 1044 dlst:=reverse explode nm; 1045 repeat 1046 <<if (dg:=(assoc(car dlst,digitl))) and numberp (dg:=cdr dg) 1047 then << dlst:=cdr dlst; 1048 nb:= dg.nb >> 1049 else << cname!*:=reverse dlst; 1050 cindex!*:=0; 1051 dg:=length(nb); 1052 for i:=1:dg do 1053 <<cindex!*:=10*cindex!*+car(nb); 1054 nb:=cdr(nb)>> >> 1055 >> 1056 until cname!* or null(dlst); 1057 if not getd('newsym) then movd('newsym,'newsym1); 1058 % ------------------------------------------------------------- ; 1059 % Bnlst is empty if INAME is used for the first time, i.e. if ; 1060 % NEWSYM has to be identified with NEWSYM1. ; 1061 % ------------------------------------------------------------- ; 1062 initname:=newsym(); 1063 cindex!*:=cindex!*-1; 1064% bnlst:=initname.bnlst 1065end; 1066 1067symbolic procedure movd(tod,fromd); 1068% ------------------------------------------------------------------- ; 1069% Transfer of a procedure description from Fromd to Tod. ; 1070% ------------------------------------------------------------------- ; 1071begin scalar s; 1072 s:=getd(fromd); 1073 putd(tod,car s,cdr s); 1074end; 1075 1076symbolic procedure newsym1(); 1077% ------------------------------------------------------------------- ; 1078% Global variables: ; 1079% cname!* is exploded letterpart of current cse-name. ; 1080% cindex!* is current cse-index. ; 1081% ------------------------------------------------------------------- ; 1082 begin scalar x; 1083 x:=explode cindex!*; 1084 cindex!*:=cindex!*+1; 1085 return compress append(cname!*,x) 1086 end; 1087 1088symbolic procedure fnewsym; 1089begin scalar x; 1090 if getd('newsym) 1091 then x:=newsym() 1092 else << x:=gensym(); 1093 x:=compress(append(explode(letterpart(x)), 1094 explode(digitpart(x)))) 1095 >>; 1096 x:=intern(x); % May be necessary for some REDUCE systems; 1097 flag(list x,'newsym); 1098 return x; 1099end; 1100 1101symbolic procedure letterpart(name); 1102% ------------------------------------------------------------------- ; 1103% Eff: Letterpart of Name returned,i.e. aa of aa55. ; 1104% ------------------------------------------------------------------- ; 1105begin scalar digitl,letters,el; 1106 digitl:='((!1 . 1) (!2 . 2) (!3 . 3) (!4 . 4) (!5 . 5) 1107 (!6 . 6) (!7 . 7) (!8 . 8) (!9 . 9) (!0 . 0)); 1108 letters:=reverse explode name; 1109 while (el := assoc(car letters,digitl)) and numberp cdr el do 1110 << letters:=cdr letters >>; 1111 return intern compress reverse letters; 1112end; 1113 1114symbolic procedure digitpart(name); 1115% ------------------------------------------------------------------- ; 1116% Eff: Digitpart of Name returned,i.e. 55 of aa55. ; 1117% ------------------------------------------------------------------- ; 1118begin scalar digitl,nb,dg,dlst; 1119 digitl:='((!1 . 1) (!2 . 2) (!3 . 3) (!4 . 4) (!5 . 5) 1120 (!6 . 6) (!7 . 7) (!8 . 8) (!9 . 9) (!0 . 0)); 1121 dlst:= reverse explode name; 1122 nb:=nil; 1123 while (dg:=assoc(car dlst,digitl)) and numberp(dg := cdr dg) do 1124 << dlst:=cdr dlst; nb:=dg.nb >>; 1125 dg:=0; 1126 foreach digit in nb do dg:=10*dg+digit; 1127 return dg; 1128 end; 1129 1130endmodule; 1131 1132end; 1133 1134