1module codad1; % Description of some procedures. 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, W.N. Borst. ; 7% ------------------------------------------------------------------- ; 8 9% Redistribution and use in source and binary forms, with or without 10% modification, are permitted provided that the following conditions are met: 11% 12% * Redistributions of source code must retain the relevant copyright 13% notice, this list of conditions and the following disclaimer. 14% * Redistributions in binary form must reproduce the above copyright 15% notice, this list of conditions and the following disclaimer in the 16% documentation and/or other materials provided with the distribution. 17% 18% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 19% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, 20% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 21% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR 22% CONTRIBUTORS 23% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 24% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 25% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 26% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 27% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 28% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 29% POSSIBILITY OF SUCH DAMAGE. 30% 31 32 33symbolic$ 34 35% ------------------------------------------------------------------- ; 36% The module CODAD1 contains the description of the procedures ; 37% IMPROVELAYOUT (part 1), TCHSCHEME (part 2) and CODFAC (part 3), ; 38% which are used in the procedure OPTIMIZELOOP (see the module CODCTL); 39% to complete the effect of an application of EXTBRSEA (see the module; 40% CODOPT). Application of each of these routines is completed by re- ; 41% turning a Boolean value, which is used to decide if further optimi- ; 42% zation is still profitable. ; 43% The Smacro's Find!+Var and Find!*Var form service facilities, needed; 44% at different places in this module. These Smacro's define an applic-; 45% ation of the procedure GetCind. ; 46% ------------------------------------------------------------------- ; 47 48% ------------------------------------------------------------------- ; 49% Global identifiers needed in this module are: ; 50% ------------------------------------------------------------------- ; 51 52global '(rowmin rowmax kvarlst codbexl!*); 53 54% ------------------------------------------------------------------- ; 55% The meaning of these globals is given in the module CODMAT. ; 56% ------------------------------------------------------------------- ; 57 58symbolic procedure getcind(var,varlst,op,fa,iv); 59% ------------------------------------------------------------------- ; 60% The purpose of the procedure GetCind is to create a column in CODMAT; 61% which will be associated with the variable Var if this variable does; 62% not yet belong to the set Varlst,i.e.does not yet play a role in the; 63% corresponding PLUS- or TIMES setting (known by the value of Op).Once; 64% the column exists (either created or already available), its Zstrt ; 65% is modified by inserting the Z-element (Fa,IV) in it. Finally the ; 66% corresponding Z-element for the father-scope_row, i.e. (Y,IV) is returned.; 67% ------------------------------------------------------------------- ; 68begin scalar y,z; 69 if null(y:=get(var,varlst)) 70 then 71 <<y:=rowmin:=rowmin-1; 72 put(var,varlst,y); 73 setrow(y,op,var,nil,nil) 74 >>; 75 scope_setzstrt(y,inszzzn(z:=mkzel(fa,iv),scope_zstrt y)); 76 return mkzel(y,val z) 77end; 78 79symbolic inline procedure find!+var(var,fa,iv); 80getcind(var,'varlst!+,'plus,fa,iv); 81 82symbolic inline procedure find!*var(var,fa,iv); 83getcind(var,'varlst!*,'times,fa,iv); 84 85% ------------------------------------------------------------------- ; 86% PART 1 : LAYOUT IMPROVEMENT ; 87% ------------------------------------------------------------------- ; 88 89symbolic procedure improvelayout; 90% ------------------------------------------------------------------- ; 91% During optimization, and thus during common subexpression generation; 92% it might happen that a (sub)expression is reduced to a single varia-; 93% ble, leading to output containing the assignment statements : ; 94% b:=b-thing; ; 95% ...... ; 96% a:=b; ; 97% This redundancy can be removed by replacing all occurrences of b by ; 98% a, by replacing b:=b-thing by a:=b=thing and by removing a:=b. Here ; 99% we assume a,b to be only cse-names. ; 100% ------------------------------------------------------------------- ; 101begin scalar var,b; 102 for x:=0:rowmax do 103 if not (numberp(var:=scope_farvar x) 104 or 105 pairp(var) 106 or 107 (member(x,codbexl!*) 108 and 109 (get(var,'nex) or 110 not(flagp(var, 'newsym)) or 111 get(var,'alias) 112 % or not(get(var,'alias)) % JB 10/3/94 113 % finds no cse in p.e. cos(e^s6),sin(e^s6) 114 ))) 115 and testononeel(var,x) then b:=t; 116 % ----------------------------------------------------------------- ; 117 % If B=T redundancy was removed from CODMAT, but not necessarily ; 118 % from Kvarlst, the list of pairs of kernels and names associated ; 119 % with them. ImproveKvarlst is applied to achieve this. ; 120 % ----------------------------------------------------------------- ; 121 if b then improvekvarlst(); 122 return b 123end; 124 125symbolic procedure testononeel(var,x); 126% ------------------------------------------------------------------- ; 127% Row X,having Var as its assigned variable, and defining some expres-; 128% sion, through its Zstrt, Chrow and ExpCof, is analysed. ; 129% If this scope_row defines a redundant assignment statement the above indi-; 130% cated actions are performed. ; 131% ------------------------------------------------------------------- ; 132begin 133 scalar scol,srow,el,signiv,signec,zz,ordrx,negcof,trow, 134 oldvar,b,el1,scof,bop!+,lhs; 135 if (zz:=scope_zstrt x) and null(cdr zz) and null(scope_chrow x) and 136 !:onep(dm!-abs(signiv:=ival(el:=car zz))) and 137 !:onep(signec:=scope_expcof(x)) 138 % !:onep(dm!-abs(signec:=scope_expcof(x))) 139 % This could mean a:=b^(-1), which is rather tricky to update 140 % when b is used in other plusrows. JB. 7-5-93. 141 then 142 << % ------------------------------------------------------------- ; 143 % Row(X) defines a Zstreet, consisting of one Z-element. The ; 144 % variable-name, associated with this element is stored in the ; 145 % FarVar-field of the column, whose index is in the Yind-part of; 146 % this Z-element,i.e. Oldvar:=FarVar(SCol),the b mentioned above; 147 % The IVal-value of this element, an exponent or a coefficient, ; 148 % is 1 or -1 and the ExpCof-value, a coefficient or an exponent,; 149 % is also 1 or -1. Realistic possibilities are of course only ; 150 % 1*Oldvar^1 or -1*Oldvar^1 (i.e. 1*b^1 or -1*b^1). ; 151 % ------------------------------------------------------------- ; 152 scol:=yind el; 153 oldvar:=scope_farvar(scol); 154 if srow:=get(oldvar,'rowindex) 155 then b:=t 156 else 157 if assoc(oldvar,kvarlst) and 158 !:onep(signiv) and !:onep(signec) and 159 not member(oldvar,codbexl!*) 160 then b:=t; 161 % ------------------------------------------------------------- ; 162 % So B=T if either Oldvar has its own defining scope_row, whose index ; 163 % is stored as value of the indicator Rowindex, i.e. if Oldvar ; 164 % defines a cse, or if Oldvar is the name of a kernel, stored in; 165 % Kvarlst, as cdr-part of the pair having Oldvar as its car-part; 166 % ------------------------------------------------------------- ; 167 if b 168 then 169 << % ------------------------------------------------------- ; 170 % We start replacing all occurrences of Oldvar by Var, in ; 171 % both the PLUS- and the TIMES-part of CODMAT, by applying; 172 % the function TShrinkCol. In addition all eventually exis; 173 % ting occurences of Oldvar in Kvarlst have to replaced as; 174 % well by Var(,the a mentioned above). ; 175 % ------------------------------------------------------- ; 176 scope_setzstrt(scol,delyzz(x,scope_zstrt scol)); 177 tshrinkcol(oldvar,var,'varlst!+); 178 tshrinkcol(oldvar,var,'varlst!*); 179 if ((scope_opval(x) eq 'plus) and !:onep(dm!-minus signiv)) 180 or 181 ((scope_opval(x) eq 'times) and !:onep(dm!-minus signec)) 182 then << var:=list('minus,var); 183 kvarlst:=subst(var,oldvar,kvarlst); 184 preprefixlist:=subst(var,oldvar,preprefixlist); 185 var:=cadr var; 186 negcof:=-1 187 >> 188 else << kvarlst:=subst(var,oldvar,kvarlst); 189 preprefixlist:=subst(var,oldvar,preprefixlist); 190 negcof:=1 191 >>; 192 if (lhs:=get(oldvar,'inlhs)) 193 then 194 << put(lhs,'nex,subst(var,oldvar,get(lhs,'nex))); 195 remprop(oldvar,'inlhs)>>; 196 if (lhs:=get(oldvar,'inalias)) 197 then 198 << updatealiases(oldvar,var); 199 %put(lhs,'alias,subst(var,oldvar,get(lhs,'alias))); 200 remprop(oldvar,'inalias)>>; 201 if srow 202 then 203 << % --------------------------------------------------- ; 204 % Oldvar is the name of a cse, defined through the scope_row; 205 % index Srow. So this cse-definition has to be assign-; 206 % ed to Var as new value and the Srow itself has to be; 207 % made redundant. The Ordr-field of Var has to be chan; 208 % ged to be able to remain guaranteeing a correct out-; 209 % put sequence. ; 210 % --------------------------------------------------- ; 211 ordrx:=ordr(x); 212 bop!+:=scope_opval(srow) eq 'plus; 213 if bop!+ then scof:=scope_expcof srow 214 else scof:=dm!-times(negcof,scope_expcof(srow)); 215 setrow(x,scope_opval srow,var,list(scope_chrow srow,scof), 216 scope_zstrt srow); 217 setordr(x,append(ordr srow,remordr(srow,ordrx))); 218 if !:onep(dm!-minus signiv) 219 then 220 <<foreach z in scope_zstrt(scol) do 221 setival(z,dm!-minus ival(z)); 222 foreach ch in scope_chrow(x) do 223 scope_setexpcof(ch,dm!-minus scope_expcof(ch)); 224 if trow:=get(var,'varlst!*) then 225 foreach el in scope_zstrt(trow) do 226 scope_setexpcof(xind el, dm!-minus scope_expcof(xind el)); 227 >>; 228 foreach ch in scope_chrow(srow) do scope_setfarvar(ch,x); 229 clearrow(srow); 230 setordr(srow,nil); 231 codbexl!*:=subst(x,srow,codbexl!*); 232 foreach z in scope_zstrt(x) do 233 <<if bop!+ then setival(z,dm!-times(signiv,ival(z))); 234 scope_setzstrt(yind z,inszzz(mkzel(x,val z), 235 delyzz(srow,scope_zstrt yind z))) 236 >>; 237 for sindex:=0:rowmax 238 do setordr(sindex,subst(x,srow,ordr sindex)); 239 testononeel(var,x) 240 >> 241 else 242 << % --------------------------------------------------- ; 243 % Oldvar is the system-generated name of a kernel. ; 244 % The internal administration is modified, as to pro- ; 245 % vide Var with its new role. ; 246 % As a side-effect the index X of the kernel defining ; 247 % scope_row is replaced in CodBexl!* by the name Var, if oc-; 248 % curring of course, i.e. if this function definition ; 249 % was given at toplevel on input. ; 250 % This information is used in ImproveKvarlst. ; 251 % --------------------------------------------------- ; 252 codbexl!*:=subst(var,x,codbexl!*); 253 ordrx:=remordr(oldvar,ordr x); 254 clearrow(x); 255 setordr(x,nil); 256 for sindex:=0:rowmax do 257 setordr(sindex, 258 updordr(ordr sindex,var,oldvar,ordrx,x)); 259 improvekvarlst() 260 >>; 261 >> 262 >>; 263 return b; 264end$ 265 266symbolic procedure remordr(x,olst); 267% ------------------------------------------------------------------- ; 268% Olst is the value of the Ordr-field of a scope_row of CODMAT. Olst defines; 269% in which order the cse's, occurring in the (sub)expression, whose ; 270% description starts in this scope_row, have to be printed ahead of this ; 271% (sub)expression. It is a list of kernelnames and/or indices of rows ; 272% where cse-descriptions start. ; 273% RemOrdr returns Olst after removal of X, if occcurring. ; 274% ------------------------------------------------------------------- ; 275if null(olst) 276then olst 277else 278 if car(olst)=x 279 then remordr(x,cdr olst) 280 else car(olst).remordr(x,cdr olst); 281 282symbolic procedure updordr(olst,var,oldvar,ordrx,x); 283% ------------------------------------------------------------------- ; 284% Olst is described in RemOrdr. OrdrX is the Olst of scope_row X after remo-; 285% val Oldvar from it. Row X defines Var:=Oldvar. Oldvar, a kernelname,; 286% is replaced by Var in Olst. If X is occurring in Olst OrdrX have to ; 287% be inserted in Olst. The thus modified version of Olst is returned. ; 288% ------------------------------------------------------------------- ; 289if null(olst) 290then olst 291else 292 if car(olst) eq oldvar 293 then var.updordr(cdr olst,var,oldvar,ordrx,x) 294 else 295 if car(olst)=x 296 then append(var.ordrx,updordr(cdr olst,var,oldvar,ordrx,x)) 297 else car(olst).updordr(cdr olst,var,oldvar,ordrx,x); 298 299symbolic procedure improvekvarlst; 300% ------------------------------------------------------------------- ; 301% Kvarlst, a list of pairs (name . function definition) is improved,if; 302% necessary. This is only required if in the list CodBexl!* occuring ; 303% names are not yet used in Kvarlst. Hence adequate rewriting of ; 304% b:=sin(x) ; 305% ........ ; 306% a:=b ; 307% into ; 308% a:=sin(x) is needed,i.e. replacement of (b . sin(x)) by (a . sin(x)); 309% in Kvarlst. ; 310% ------------------------------------------------------------------- ; 311begin scalar invkvl,newkvl,x,y,kv,lkvl,cd,cd1; 312 newkvl:=kvarlst; 313 repeat 314 <<lkvl:=kvarlst:=newkvl; 315 invkvl:=newkvl:=nil; 316 while lkvl do 317 <<kv:=car(lkvl); 318 lkvl:=cdr(lkvl); 319 cd1:=member(car kv,codbexl!*); 320 x:=assoc(cdr kv,invkvl); 321 if x 322 then cd:=(cd1 and member(cdr x,codbexl!*)); 323 if x and not cd 324 then 325 <<kv:=car(kv); 326 x:=cdr(x); 327 if cd1 328 then <<y:=x; 329 x:=kv; 330 kv:=y>>; 331 tshrinkcol(kv,x,'varlst!+); 332 tshrinkcol(kv,x,'varlst!*); 333 for rindx:=0:rowmax do 334 setordr(rindx,subst(x,kv,ordr rindx)); 335 newkvl:=subst(x,kv,newkvl); 336 invkvl:=subst(x,kv,invkvl); 337 lkvl:=subst(x,kv,lkvl) 338 >> 339 else 340 <<invkvl:=(cdr(kv).car(kv)).invkvl; 341 newkvl:=kv.newkvl 342 >> 343 >> 344 >> 345 until length(kvarlst)=length(newkvl); 346end; 347 348symbolic procedure tshrinkcol(oldvar,var,varlst); 349% ------------------------------------------------------------------- ; 350% All occurrences of Oldvar have to be replaced by Var. This is done ; 351% by replacing the PLUS and TIMES column-indices of Oldvar by the cor-; 352% responding indices of Var. Y1 and Y2 get the value of the Oldvar- ; 353% index and the Var-index, respectively. As a side-effect, all additi-; 354% onal information, stored in the property-list of Oldvar is removed. ; 355% ------------------------------------------------------------------- ; 356begin scalar y1,y2; 357 if get(oldvar,'inalias) 358 then updatealiases(oldvar, var); 359 if y1:=get(oldvar,varlst) 360 then 361 <<if y2:=get(var,varlst) 362 then 363 <<foreach z in scope_zstrt(y1) do 364 <<scope_setzstrt(y2,inszzzn(z,scope_zstrt y2)); 365 scope_setzstrt(xind z,inszzzr(mkzel(y2,val z), 366 delyzz(y1,scope_zstrt xind z))) 367 >>; 368 clearrow(y1) 369 >> 370 else 371 <<scope_setfarvar(y1,var); 372 put(var,varlst,y1) 373 >>; 374 remprop(oldvar,varlst) 375 >>; 376 remprop(oldvar,'npcdvar); 377 remprop(oldvar,'nvarlst); 378end; 379 380symbolic procedure updatealiases(old, new); 381% ----------------------------------------------------------------- ; 382% Variable old is going to be replaced by new. 383% We hav eto ensure that the alias-linking remains 384% consistent. This means that the following has to 385% be updated: 386% Occurrence-info of index-alias: 387% new.inalias <- old.inalias 388% The aliased vars have to be informed that the alias 389% is performed by a new variable: 390% alias <- new|old 391% original.finalalias <- new|old 392% where A|B means : replace B by A. 393% ----------------------------------------------------------------- ; 394begin scalar original; 395 put(new,'inalias,get(old,'inalias)); 396 flag(list new,'aliasnewsym); 397 foreach el in get(old,'inalias) do 398 <<put(el,'alias,subst(new,old,(original:=get(el,'alias)))); 399 if atom original 400 then put(original,'finalalias, 401 subst(new, old, get(original,'finalalias))) 402 else put(car original,'finalalias, 403 subst(new,old,get(car original,'finalalias))) 404 >>; 405end$ 406 407% ------------------------------------------------------------------- ; 408% PART 2 : INFORMATION MIGRATION ; 409% ------------------------------------------------------------------- ; 410symbolic procedure tchscheme; 411% ------------------------------------------------------------------- ; 412% A product(sum) -reduced to a single element- can eventually be remo-; 413% ved from the TIMES(PLUS)-part of CODMAT. If certain conditions are ; 414% fulfilled (defined by the function TransferRow) it is transferred to; 415% the Zstreet of its father PLUS(TIMES)-scope_row and its index is removed ; 416% from the ChRow of its father. ; 417% T is returned if atleast one such a migration event takes place. ; 418% NIL is returned otherwise. ; 419% ------------------------------------------------------------------- ; 420begin scalar zz,b; 421 for x:=0:rowmax do 422 if not(scope_farvar(x)=-1) 423 and (zz:=scope_zstrt x) and null(cdr zz) and transferrow(x,ival car zz) 424 then <<chscheme(x,car zz); b:=t>>; 425 return b; 426end; 427 428symbolic procedure chscheme(x,z); 429% ------------------------------------------------------------------- ; 430% The Z-element Z, the only element the Zstreet of scope_row(X) has, has to ; 431% be transferred from the PLUS(TIMES)-part to the TIMES(PLUS)-part of ; 432% CODMAT. ; 433% ------------------------------------------------------------------- ; 434begin scalar fa,opv,cof,exp; 435 scope_setzstrt(yind z,delyzz(x,scope_zstrt yind z)); 436 scope_setzstrt(x,nil); 437 if scope_opval(x) eq 'plus 438 then <<exp:=1; cof:=ival z>> 439 else <<exp:=ival z; cof:=1>>; 440 l1: fa:=scope_farvar(x); 441 opv:=scope_opval(x); 442 if opv eq 'plus 443 then 444 <<cof:=dm!-expt(cof,scope_expcof(x)); 445 exp:=dm!-times(scope_expcof(x),exp); 446 chdel(fa,x); 447 clearrow(x); 448 if null(scope_zstrt fa) and transferrow(fa,exp) 449 then <<x:=fa; goto l1>> 450 >> 451 else 452 << if opv eq 'times 453 then 454 <<cof:=dm!-times(cof,scope_expcof(x)); 455 chdel(fa,x); 456 clearrow(x); 457 if null(scope_zstrt fa) and transferrow(fa,cof) 458 then <<x:=fa; goto l1>> 459 >> 460 >>; 461 updfa(fa,exp,cof,z) 462end; 463 464symbolic procedure updfa(fa,exp,cof,z); 465% ------------------------------------------------------------------- ; 466% FA is the index of the father-scope_row of the Z-element Z,which has to ; 467% be incorporated in the Zstreet of this scope_row. Its exponent is Exp and ; 468% its coefficient is Cof, both computed in its calling function ; 469% ChScheme. ; 470% ------------------------------------------------------------------- ; 471if scope_opval(fa) eq 'plus 472then scope_setzstrt(fa,inszzzr(find!+var(scope_farvar yind z,fa,cof),scope_zstrt fa)) 473else 474<<scope_setzstrt(fa,inszzzr(find!*var(scope_farvar yind z,fa,exp),scope_zstrt fa)); 475 scope_setexpcof(fa,dm!-times(cof,scope_expcof(fa))) 476>>; 477 478symbolic procedure transferrow(x,iv); 479% ------------------------------------------------------------------- ; 480% IV is the Ivalue of the Z-element, oreming the Zstreet of scope_row X. ; 481% This element can possibly be transferred. ; 482% T is returned if this element can be transferred. NIL is returned ; 483% otherwise. ; 484% ------------------------------------------------------------------- ; 485if scope_opval(x) eq 'plus 486 then transferrow1(x) and scope_opval(scope_farvar x) eq 'times 487 else transferrow1(x) and transferrow2(x,iv); 488 489symbolic procedure transferrow1(x); 490% ------------------------------------------------------------------- ; 491% T is returned if scope_row(X) defines a primitive expression (no children); 492% which is part of a larger expression, i.e. scope_row(X) defines a child- ; 493% expression. ; 494% ------------------------------------------------------------------- ; 495null(scope_chrow x) and numberp(scope_farvar x); 496 497symbolic procedure transferrow2(x,iv); 498% ------------------------------------------------------------------- ; 499% Row(X) defines a product of the form ExpCof(X)*(a variable) ^ IV, ; 500% which is part of a sum. ; 501% X is temporarily removed from the list of its fathers children when ; 502% computing B, the return-value. ; 503% B=T if the father-scope_row defines a sum and if either the exponent IV=1 ; 504% or if the father-Zstreet is empty (no primitive terms) and the fa- ; 505% ther itself can be transferred, i.e. if ExpCof(X)*(a variable) ^ (IV; 506% *ExpCof(Fa)) can be incorporated in the Zstreet of the grandfather- ; 507% scope_row (,which again defines a product). ; 508% ------------------------------------------------------------------- ; 509begin scalar fa,b; 510 fa:=scope_farvar(x); 511 chdel(fa,x); 512 b:=scope_opval(fa) eq 'plus and (iv=1 or (null(scope_zstrt fa) and 513 transferrow(fa,iv*scope_expcof(fa)))); 514 scope_setchrow(fa,x.scope_chrow(fa)); 515 return b; 516end; 517 518% ------------------------------------------------------------------- ; 519% PART 3 : APPLICATION OF THE DISTRIBUTIVE LAW. ; 520% ------------------------------------------------------------------- ; 521% An expression of the form a*b + a*c + d is distributed over 3 rows ; 522% of CODMAT : One to store the sum structure, i.e. to store the pp of ; 523% the sum, being d, in a Zstrt and 2 others to store the composite ; 524% terms a*b and a*c as monomials. The indices of the latter rows are ; 525% also stored in the list Chrow, associated with the sum-scope_row. ; 526% In addition 4 columns are introduced. One to store the 2 occurrences; 527% of a and 3 others to store the information about b,c and d. The a,b ; 528% and c column belong to the set of TIMES-columns, i.e. a,b and c are ; 529% elements of the list Varlst!* (see the module CODMAT). Similarly the; 530% d belongs to Varlst!+. If this sum is remodelled to obtain a*(b + c); 531% + d changes have to be made in the CODMAT-structure: ; 532% Now 2 sum-rows are needed and only 1 product-scope_row. Hence the Chrow- ; 533% information of the original sum-scope_row has to be changed and the 2 pro-; 534% duct-rows have to be removed and replaced by one new scope_row, defining ; 535% the Zstrt for a and the Chrow to find the description of b + c back.; 536% In addition the column-information for all 4 columns has to be reset; 537% This is a simple example. In general more complicated situations can; 538% be expected. An expression like a*b + a*sin(c) + d requires 4 rows, ; 539% for instance . A CODFAC-application always follows a ExtBrsea-execu-; 540% tion. This implies that potential common factors, defined through *-; 541% col's always have an exponent-value = 1. A common factor like a^3 is; 542% always replaced by a cse (via an appl. of Expand- and Shrinkprod), ; 543% before the procedure CODFAC is applied. Hence atmost 1 exponent in a; 544% column is not equal 1. ; 545% ------------------------------------------------------------------- ; 546 547symbolic procedure codfac; 548% ------------------------------------------------------------------- ; 549% An application of the procedure CodFac results in an exhaustive all-; 550% level application of the distributive law on the present structure ; 551% of the set of input-expressions, as reflected by the present version; 552% of CODMAT. ; 553% If any application of the distributive law proves to be possible the; 554% value T is returned.This is an indication for the calling routine ; 555% OptimizeLoop that an additional application of ExtBrsea might be ; 556% profitable. ; 557% If such an application is not possible the value Nil is returned. ; 558% ------------------------------------------------------------------- ; 559begin scalar b,lxx; 560 for y:=rowmin:(-1) do 561 % ---------------------------------------------------------------- ; 562 % The Zstrts of all *-columns, which are usable (because their Far-; 563 % Var-field contains a Var-name), are examined by applying the pro-; 564 % cedure SameFar. If this application leads to a non empty list LXX; 565 % with information, needed to be able to apply the distributive law; 566 % the local variable B is set T, possibly the value to be returned.; 567 % B gets the initial value Nil, by declaration. ; 568 % ---------------------------------------------------------------- ; 569 if not (scope_farvar(y)=-1 or scope_farvar(y)=-2) and 570 scope_opval(y) eq 'times and (lxx:=samefar y) 571 then 572 <<b:=t; 573 foreach el in lxx do commonfac(y,el) 574 >>; 575 return b 576end; 577 578symbolic procedure samefar(y); 579% ------------------------------------------------------------------- ; 580% Y is the index of a TIMES-column. The procedure SameFar is designed ; 581% to allow to find and return a list Flst consisting of pairs, formed ; 582% by a father-index and a sub-Zstrt of the Zstrt(Y), consisting of Z's; 583% such that Farvar(Xind Z) = Car Flst, i.e. the Xind(Z)-rows define ; 584% (composite) productterms of the same sum, which contain the variable; 585% corresponding with column Y as factor in their primitive part. ; 586% ------------------------------------------------------------------- ; 587begin scalar flst,s,far; 588 foreach z in scope_zstrt(y) do 589 if numberp(far:=scope_farvar xind z) and scope_opval(far) eq 'plus 590 then 591 if s:=assoc(far,flst) 592 then rplacd(s,inszzz(z,cdr(s))) 593 else flst:=(far.inszzz(z,s)).flst; 594 return 595 foreach el in flst conc 596 if cddr(el) 597 then list(el) 598 else nil 599end; 600 601symbolic procedure commonfac(y,xx); 602% ------------------------------------------------------------------- ; 603% Y is the index of a TIMES-column and XX an element of LXX, made with; 604% SameFar(Y), i.e. a pair consisting of the index Far of a father-sum ; 605% scope_row and a sub-Zstrt,consisting of Z-elements, defining factors in ; 606% productterms of this father-sum. ; 607% These factors are defined by Z-elements (Y.exponent). Atmost one of ; 608% these exponents is greater than 1. ; 609% The purpose of CommonFac is to factor out this element,i.e. to remo-; 610% ve a Z-element (Y.1) from the Zstrts of the children and also its ; 611% corresponding occurrences from ZZ3 = Zstrt(Y), to combine the remai-; 612% ning sum-information in a new PLUS-scope_row, with index Nsum, and to cre-; 613% ate a TIMES-scope_row, with index Nprod, defining the product of the sum, ; 614% given by the scope_row Nsum, and the variable corresponding with column Y.; 615% ZZ2 and CH2 are used to (re)structure information, by allowing to ; 616% combine the remaining portions of the child-rows.The father (with ; 617% index Far) is defined by a Zstrt (its primitive part) and by CH1 = ; 618% Chrow (its composite part). ZZ4 and CH4 are used to identify the ; 619% Zstrts of the children after removal of a (Y.1)-element and the ; 620% Chrow's,respectively.If exponent>1 in (Y.exponent) the Zstrt has to ; 621% be modified to obtain ZZ4, instead of a simple removal of (Y.1) from; 622% from Zstrt X. ; 623% Alternatives for the structure of the such a child-scope_row are : ; 624% -1- A combination of a non-empty Zstrt and a non-empty list Chrow ; 625% of children. ; 626% -2- An empty Zstrt, but a non-empty Chrow. ; 627% -3- A non-empty Zstrt, but an empty Chrow. ; 628% Special attention is required when in case -3- the Zstrt consists of; 629% only 1 Z-element besides the element shared with column Y. ; 630% In case -2- similar care have to be taken when Chrow consists of 1 ; 631% scope_row index only. ; 632% Remark : Since the overall intention is optimization, i.e. reduction; 633% of the arithmetic complexity of a set of expressions, viewed as ru- ; 634% les to perform arithmetic operations, expression parts like a*b + a ; 635% are not changed into a*(b + 1). Hence a forth alternative, being an ; 636% empty Zstrt and an empty Chrow is irrelevant. ; 637% ------------------------------------------------------------------- ; 638begin scalar far,ch1,ch2,ch4,chindex,zel,zeli,zz2,zz3,zz4, 639 nsum,nprod,opv,y1,cof,x,ivalx; 640 far:=car(xx); 641 ch1:=scope_chrow(far); 642 zz3:=scope_zstrt(y); 643 nprod:=rowmax+1; 644 nsum:=rowmax:=rowmax+2; 645 % ----------------------------------------------------------------- ; 646 % After some initial settings all children,accessible via the Z-el.s; 647 % collected in Cdr(XX) are examined using a FOREACH_loop. ; 648 % ----------------------------------------------------------------- ; 649 foreach item in cdr(xx) do 650 <<x:=xind item; 651 if (ivalx:=ival item)=1 652 then zz4:=delyzz(y,scope_zstrt x) 653 else zz4:=inszzzr(zeli:=mkzel(y,ivalx-1),delyzz(y,scope_zstrt x)); 654 ch4:=scope_chrow(x); 655 cof:=scope_expcof(x); 656 % --------------------------------------------------------------- ; 657 % (Y.1) is removed from the child's Zstrt, defining a monomial, ; 658 % without the coefficient, stored in Cof. ; 659 % --------------------------------------------------------------- ; 660 if null(zz4) and (null(cdr ch4) and car(ch4)) 661 then 662 <<% ------------------------------------------------------------- ; 663 % This is the special case of possibility -2-. ZZ4 is empty and ; 664 % CH4 contains only 1 index. ; 665 % ------------------------------------------------------------- ; 666 if (opv:=scope_opval(ch4:=car ch4)) eq 'plus and scope_expcof(ch4)=1 667 then 668 <<% ----------------------------------------------------------- ; 669 % The child with scope_row-index CH4 has the form (..+..+..)^1 = ..+; 670 % ..+.. . Its definition has to be moved to the scope_row Nsum. ; 671 % The different terms can be either primitive or composite and; 672 % have all to be multiplied by Cof. Both Zstrt(CH4) - the pri-; 673 % mitives - and Chrow(CH4) - the composites - have to be exa- ; 674 % mined. ; 675 % ----------------------------------------------------------- ; 676 foreach z in scope_zstrt(ch4) do 677 <<% --------------------------------------------------------- ; 678 % A new Zstrt ZZ2 is made with the primitive elements of the; 679 % the different Zstrt(CH4)'s. InsZZZr guarantees summation ; 680 % of the Ival's if the Xind's are equal (see module CODMAT).; 681 % ZZ2 is build using the FOREACH X loop. The Zstrt's of the ; 682 % columns, which share an element with ZZ2,are also updated:; 683 % The CH4-indexed elements are removed and the Nsum-indexed ; 684 % elements are inserted. ; 685 % --------------------------------------------------------- ; 686 zel:=mkzel(xind z,dm!-times(ival(z),cof)); 687 zz2:=inszzzr(zel,zz2); 688 scope_setzstrt(yind z,inszzz(mkzel(nsum,ival zel), 689 delyzz(ch4,scope_zstrt yind z))) 690 >>; 691 foreach ch in scope_chrow(ch4) do 692 <<% --------------------------------------------------------- ; 693 % The scope_row CH defines a child directly if Cof = 1. In all ; 694 % other cases a multiplication with Cof has to be performed.; 695 % Either by changing the ExpCof field if the child is a pro-; 696 % duct or by introducing a new TIMES-scope_row. ; 697 % --------------------------------------------------------- ; 698 chindex:=ch; 699 if not(!:onep cof) 700 then 701 if scope_opval(ch) eq 'times 702 then 703 << scope_setexpcof(ch,dm!-times(cof,scope_expcof(ch))); 704 scope_setfarvar(ch,nsum) 705 >> 706 else 707 << chindex:=rowmax:=rowmax+1; 708 setrow(chindex,'times,nsum,(ch).cof,nil) 709 >> 710 else scope_setfarvar(ch,nsum); 711 ch2:=chindex.ch2 712 >>; 713 % ----------------------------------------------------------- ; 714 % The scope_row CH4 is not longer needed in CODMAT, because its ; 715 % content is distributed over other rows. ; 716 % ----------------------------------------------------------- ; 717 clearrow(ch4); 718 >> 719 else 720 <<% ----------------------------------------------------------- ; 721 % This is still the special case -2-. (CH4) contains 1 child ; 722 % index. The leading operator of this child is not PLUS. So ; 723 % CH4 is simply added to the list of children indices CH2 and ; 724 % the father index of scope_row CH4 is changed into Nsum. ; 725 % ----------------------------------------------------------- ; 726 scope_setfarvar(ch4,nsum); 727 ch2:=ch4.ch2 728 >>; 729 % ------------------------------------------------------------- ; 730 % The scope_row X is not longer needed in CODMAT, because its content ; 731 % is distributed over other rows. ; 732 % ------------------------------------------------------------- ; 733 clearrow(x) 734 >> 735 else 736 if null(ch4) and (null(cdr zz4) and car(zz4)) 737 then 738 <<% ----------------------------------------------------------- ; 739 % This is the special case of possibility -3-: A Zstrt ZZ4 ; 740 % consisting of only one Z-element. ; 741 % This Z-element defines just a variable if IVal(Car ZZ4) =1. ; 742 % It is a power of a variable in case IVal-value > 1 holds. ; 743 % In the latter situation Nsum ought to become the new father ; 744 % index of the scope_row with index Xind Car ZZ4.In the former case ; 745 % the single variable is added to the Zstrt ZZ2, before scope_row X ; 746 % can be cleared. ; 747 % ----------------------------------------------------------- ; 748 if not(!:onep ival(car(zz4))) 749 then 750 << scope_setfarvar(x,nsum); 751 scope_setzstrt(x,zz4); 752 ch2:=x.ch2 753 >> 754 else 755 << zz2:=inszzzr(find!+var(scope_farvar(y1:=yind car zz4),nsum, 756 cof),zz2); 757 scope_setzstrt(y1,delyzz(x,scope_zstrt y1)); 758 clearrow(x) 759 >> 760 >> 761 else 762 <<% ----------------------------------------------------------- ; 763 % Now the general form of one of the 3 alternatives holds. ; 764 % Row index X is added to the list of children indices CH2 ; 765 % and the new father index for scope_row X becomes Nsum. The Zstrt ; 766 % of X is also reset. It becomes ZZ4, i.e. the previous Zstrt ; 767 % after removal of (Y.1). ; 768 % ----------------------------------------------------------- ; 769 ch2:=x.ch2; 770 scope_setfarvar(x,nsum); 771 scope_setzstrt(x,zz4) 772 >>; 773 % --------------------------------------------------------------- ; 774 % The previous "life" of X is skipped by removing its impact from ; 775 % the "history book" CODMAT. ; 776 % --------------------------------------------------------------- ; 777 ch1:=delete(x,ch1); 778 zz3:=delyzz(x,zz3); 779 if ivalx>2 then zz3:=inszzz(mkzel(x,val(zeli)),zz3) 780 >>; 781 % ----------------------------------------------------------------- ; 782 % Some final bookkeeping is needed : ; 783 % -1- (Y.1) was deleted from the ZZ4's. Its new role, factor in the ; 784 % product,defined via the scope_row Nprod, has still to be establish- ; 785 % ed by inserting this information in Y's Zstrt. ; 786 % ----------------------------------------------------------------- ; 787 scope_setzstrt(y,(zel:=mkzel(nprod,1)).zz3); 788 % ----------------------------------------------------------------- ; 789 % -2- The list of indices of children of the scope_row with index Far ; 790 % ought to be extended with Nprod. ; 791 % ----------------------------------------------------------------- ; 792 scope_setchrow(far,nprod.ch1); 793 % ----------------------------------------------------------------- ; 794 % -3- Finally the new rows Nprod and Nsum have to be filled. How- ; 795 % ever the :=: assignment-option might cause - otherwise non- ; 796 % existing - problems, because simplification is skipped before ; 797 % parsing input and storing the relevant information in CODMAT. ; 798 % An input expression of the form x*(a + t) + x*(a - t) can thus be ; 799 % transformed - by an application of CODFAC - into the form ; 800 % x*(2*a + 0). Its Zstrt can contain an element (index . 0), like ; 801 % the Zstrt associated with t. The latter is due to the coefficient ; 802 % addition, implied by insert-operations, like InsZZZ or InsZZZr. ; 803 % Hence a test is made to discover if a Z-element Zel exists, such ; 804 % that IVal(Zel)=0. If so, its occurrence is removed from both ZZ2 ; 805 % and the Zstrt of the t-column. ; 806 % If now Null(CH2) and Null(Cdr ZZ2) holds the PLUS-scope_row Nsum is ; 807 % superfluous. Only 2*a*x has to be stored in Nprod. The scope_row Nsum ; 808 % is removed when it is easily detectable, because this index is ; 809 % not used anymore and anywhere, when the above limitations are ; 810 % valid. ; 811 % ----------------------------------------------------------------- ; 812 foreach z in zz2 do if zeropp(ival(z)) 813 then << zz2:=delyzz(y1:=xind z,zz2); 814 scope_setzstrt(y1,delyzz(nsum,scope_zstrt y1)) 815 >>; 816 % ----------------------------------------------------------------- ; 817 % Expressions like x(a-w)+x(a+w) lead to printable, but not yet to ; 818 % completely satisfactory prefixlist-representations. This problem ; 819 % is solved in the module CODPRI in the function ConstrExp. ; 820 % ----------------------------------------------------------------- ; 821 setrow(nprod,'times,far,list list nsum,list mkzel(y,val zel)); 822 setrow(nsum,'plus,nprod,list ch2,zz2) 823 end; 824 825endmodule; 826 827end; 828