reduce-historical/r35/cslsrc/select.red

%
% Run using smallr35 to select code to compile into C.
% I run "reduce.tst" as the main test to tune against, but also
% use data collected (elsewhere) to ensure that the most heavily
% used functions in various other tests are catered for.
%

%
% I recompile the patches module in case it has changed since the main
% image file that I am using was created.
%

on comp, backtrace;
in "../cslsrc/patches.red"$

% It is a misery that the REDUCE test files do not tidy up after themselves,
% so if I want to run several in the same job I have to put well-judged
% CLEAR statements between.  If I miss out some of these almost any
% curious behaviour might arise.

on echo;
lisp verbos 3;

% Here I set up a list that documents what appear to be the most
% heavily used few functions in each of a number of the test files.
% I will force these to be compiled into C regardless of what is in the
% benchmark files that I process as well

lisp (force_these := '(
% Reduce.tst
    getel1 simpcar noncomp ordop delcp multd addf terminalp
    multf prin2!* !*ssave getrtypeor getrtype timesip getrtype2
    exchk simp ordad getel readch1
% Int.tst
    ordop reorder multd addf delall powers0 multf maxdeg
    noncomp rmultpf quotf1 quotf negf addd raddf degr
    !*n2f !*d2q minusf ordpp
% Factor.tst
    !*n2f adjoin!-term multiply!-by!-constant!-mod!-p plus!-mod!-p
    remainder!-in!-vector mksp getpower addf multd times!-term!-mod!-p
    multf listsum to noncomp times!-mod!-p fkern clear!-column addd
    minus!-mod!-p multdm
% Decompos.tst
    freeof freeofl !*n2f smember addf ordop multd multf
    to adjoin!-term noncomp addd multdm adddm mkspm sub2chk
    multiply!-by!-constant!-mod!-p plus!-mod!-p ordpp exchk
% Limits.tst
    ps!:getv ps!:last!-term ps!:order ps!:get!-term ps!:evaluate exchk
    multsq retimes1 prepf1 quotf addsq prepf ps!:times!-erule replus
    retimes ps!:putv !*d2q exchk1 prepsq prepd
% Matrix.tst
    addf multd !*n2f multf addd to c!:ordxp c!:ordexp noncomp
    adddm negf c!:extadd ordop quotf1 c!:extmult mkspm sub2chk
    c!:ordexn scprint multdm
% Groebner.tst
    evlexcomp vevzero!?1 vevmtest!? bcnumtimes evcomp bcint2op
    bcprod vevcan0 evsum quotf evzero!? diplength groebsearchinlist
    listsum exchk multd reorder retimes1 vevmaptozero1 ordop
% Roots.tst
    CSL_normbf CSL_timbf round!:mt round!:last plus!: divide!:
    conv!:mt ncoeffs gftimesn difference!: plubf terminalp
    lastpair abs!: gfplusn gfrsq cut!:mt gfdot readch1 gbfdot
% Solve.tst
    ordop freeof freeofl smember addf multd multf !*n2f noncomp
    negf to exchk ordpp vevmtest!? addd multdm retimes1 reorder
    adddm mkspm
% Compact.tst
    termsf addf !*n2f addd multd multf noncomp to
    adddm negf mkspm sub2chk multdm kernels1 red!-weight1
    !:minus nonzero!-length ordop mv!-pow!-!+ ordpp
% Gcd.tst
    !*n2f adjoin!-term multiply!-by!-constant!-mod!-p
    plus!-mod!-p mksp addf getpower multd addd
    times!-term!-mod!-p times!-mod!-p ordop multf
    fkern noncomp powers2 to adddm raddf reorder
% Excalc.tst
    ordop reorder delall maxdeg powers0 rmultpf raddf
    quotf to quotf1 lastpair reordop addf multf quotfm
    exchk ordpp noncomp negf multd
% Tps.tst
    ps!:getv ps!:last!-term ps!:order quotf exchk
    ps!:get!-term retimes1 prepf1 prepf minusf multsq
    ps!:evaluate replus revpr retimes gcdf lnc quotf1
    terminalp scprint
% Taylor.tst
    tayexp!-plus2 gcdfd1 quotf tayexp!-greaterp multd
    exceeds!-order lastpair tayexp!-difference addf
    gcdf minusf quotf1 multf multsq gcdf1 gcdfd add!-degrees
    lnc terminalp ordop
% Sum.tst
    addf noncomp multf multd to !*n2f addd ordop reorder
    adddm multdm mkspm sub2chk lastpair raddf ordpp exchk
    negf rmultpf quotf1
% Algint.tst
    addf multd ordop reorder multf noncomp delall
    powers0 to !*n2f addd quotf1 maxdeg rmultpf
    negf adddm subs2f1 depends ldepends raddf
% Scope.tst
    lastpair terminalp initbrsea testred initwght
    token prin2x readch1 numberofocc downwght1 pnthxzz
    lispeval smember inshisto delcp pprin2
    downwght toknump init
% Gentran.tst
    lastpair terminalp pprin2 readch1 token prin2x
    listp exchk prepf1 retimes1 delcp ordop nconc!*
    toknump mkvar lispeval exchk1 noncomp reversip!*
% Arnum.tst
    !*n2f multd addf adjoin!-term remainder!-in!-vector
    multf to addd rnzerop!: multdm noncomp rnequiv adddm
    rnonep!: int!-equiv!-chk times!-in!-vector mkrn
    plus!-mod!-p multiply!-by!-constant!-mod!-p mksp
% Elem.tst
    delcp terminalp readch1 exchk sinitl striptag
    s!:prinl1 CSL_normbf convprec!* prin2x token
    replus convchk prepf retimes1 errorset!* errorp round!:mt
% Complex.tst
    !*n2f CSL_normbf terminalp multd remainder!-in!-vector
    adjoin!-term round!:mt addf readch1 round!:last
    multiply!-by!-constant!-mod!-p scprint prin2!*
    gizerop!: mkgi times!-in!-vector addd striptag
% Rounded.tst
    terminalp smemql CSL_normbf readch1 s!:assoc
    round!:mt round!:last prin2!* !*ssave token
    prin2x exchk scprint convprec divide!: sinitl getrtype
    round!*
% Math.tst
    terminalp readch1 prin2x token delcp reversip!* mkvar
    token1 toknump convertmode scan formc arrayp
    eolcheck xread1 getrmacro macrochk form1
% Spde.tst
    ordop ldepends depends exchk prepf1 ordpp
    retimes1 multsq ordad addf difff nconc!* exchk1
    addsq !*d2q multd simpcar multf sqchk
% Avector.tst
    prin2!* negnumberchk update!-pline ordop maprint
    putpline noncomp multf layout!-formula scprint
    prepf1 addf quotf1 oprin exchk negf retimes1
    nconc!* to exptpri
% Orthovec.tst
    exchk prepf1 retimes1 nconc!* exchk1 prepf retimes
    getrtype getrtypeor reval replus simpcar prepd
    getrtype2 sqchk reval2 simp prepsqxx !*ssave
% Specfn.tst
    CSL_normbf round!:mt subs3f round!:last exchk
    revpr quotsq convprec!* !*ssave striptag subs3q
    divide!: simpcar subs3f1 getrtype2 getrtype multsq
    addsq convchk
      ))$

symbolic procedure cf(p, q);
   (float caddr p/float cadr p) > (float caddr q/float cadr q);

symbolic mapstore 4;  % reset counts;

in "../xmpl/reduce.tst";

symbolic (w_reduce := sort(mapstore 2, function cf))$

clear a, xx, yy, zz, k1, ki, kf, p1, pf,
      ei, ef, ki, kf, p1, pf, gp, ix, iy, iz,
      p2, p3, p4, qi, q2, ga, gb, w;


% The lines commented out thus "%---" are a prototype of how to
% include one or more further test files in this benchmark/tuning
% suite.

%--- symbolic mapstore 4;
%---
%--- in "../xmpl/int.tst";
%---
%--- symbolic (w_int := sort(mapstore 2, function cf))$
%---
%--- clear f1s, a, z, u, v;

symbolic;

fluid '(w);

w := w_reduce$

symbolic procedure top_twenty x;
  begin
    scalar y;
    for i := 1:20 do
       if x then << y := car x . y; x := cdr x >>;
    return y
  end;

symbolic procedure addin r;
  begin
    scalar v;
    v := assoc(car r, w);
    if not v then w := r . w
    else w := list(car r, cadr r + cadr v, caddr r + caddr v) . delete(v, w);
    return nil
  end;

%--- w_int      := top_twenty w_int$

for i := 1:20 do <<
%---    if w_int      then << addin car w_int;      w_int      := cdr w_int >>;
   nil >>;

z := w$ w := nil;
for each v in z do begin
   scalar name, name1;
   name := car v;
   name1 := symbol!-env name;
   if not atom name1 then <<
      name1 := cdr name1;
      if vectorp name1 then name := getv(name1, 0) >>;
   addin list(name, cadr v, caddr v) end;

w := sort(w, function cf)$

for each fn in force_these do begin
    scalar name1;
    name1 := symbol!-env fn;
    if not atom name1 and vectorp cdr name1 then fn := getv(cdr name1, 0);
    addin list(fn, 0, 0);
    force_these := cdr force_these end;

total_bytes_executed := 0;
for each v in w do total_bytes_executed := total_bytes_executed + caddr v;

symbolic procedure listsize(x, n);
   if null x then n
   else if atom x then n+1
   else listsize(cdr x, listsize(car x, n+1));

fnames := '("u01" "u02" "u03" "u04" "u05"
            "u06" "u07" "u08" "u09" "u10"
            "u11" "u12");

size_per_file := 4300;

symbolic procedure get!-saved m;
  << loaded!-packages!* := nil;
     load!-package m;
     for each x in oblist() do
        if not atsoc(x, w) then remprop(x, '!*savedef)
  >>;

% With !*savedef = '!*savedef when I load a module I do not load the
% executable code in it - just the saved function definitions on
% property lists (also I execute any code in the file that is not
% just defining a function).  Since some modules define functions
% that they then call, I need to define suitable placeholders here.

symbolic procedure set!-teeny!-primes(); nil;
symbolic procedure initio(); nil;
symbolic procedure find!!flim(); nil;
algebraic procedure get!-eulers!-constant n; 0;

% The taylor module defines and uses a macro (taylor!:) in a way that
% seems to make it hard for me to handle using the general mechanism
% I use below.

get!-saved 'taylor;

!*savedef := '!*savedef;

<<
% I load the files here with the largest module first. This is intended
% to ease memory pressure.  But I put the core system last so that
% definitions in it take precedense over those in optional modules.

get!-saved 'algint;
%     get!-saved 'int;
get!-saved 'scope;
%     get!-saved 'gentran;
get!-saved 'factor;
%     get!-saved 'ezgcd;
get!-saved 'roots;
get!-saved 'excalc;
get!-saved 'groebnr2;
%     get!-saved 'groebner;
%     get!-saved 'dipoly;
get!-saved 'solve;
get!-saved 'specfn2;
%     get!-saved 'specfn;
%     get!-saved 'specfaux;
get!-saved 'numeric;
get!-saved 'matrix;
% get!-saved 'spde;      Not loaded because of function clashes
get!-saved 'misc;
%     get!-saved 'tps;
get!-saved 'rlisp88;
get!-saved 'arnum;
get!-saved 'odesolve;
% get!-saved 'rcref;     Not loaded because I will not worry about speed here
% get!-saved 'avector;   Not loaded because of function clashes
get!-saved 'hephys;
% get!-saved 'orthovec;  Not loaded because of function clashes
get!-saved 'compact;
% get!-saved 'rprint;    Not loaded because I will not worry about speed here
% get!-saved 'cedit;     Not loaded because I will not worry about speed here
% get!-saved 'pretty;    Not loaded because I will not worry about speed here
get!-saved 'module;

% Now do some tidying up - to try to free up some memory

for each x in oblist() do
   for each y in '(simpfn dfn opmtch klist kvalue avalue) do
      remprop(x, y);

% I reload the most basic bits of REDUCE once again to ensure that the
% definitions that I will compile into C come from these modules even
% if some other package redefines something critical.

get!-saved 'rlisp;
get!-saved 'cslrend;
get!-saved 'poly;
get!-saved 'alg;
get!-saved 'arith;
get!-saved 'mathpr;

off echo;
in "../cslsrc/patches.red"$
on echo;

!*savedef := nil;

set!-print!-precision 4;
benefit := 0;

symbolic verbos nil;
global '(rprifn!*);

load_package ccomp;

on fastfor, fastvector, unsafecar;

while fnames do begin
   scalar bulk;
   princ "About to create "; printc car fnames;
   c!:ccompilestart car fnames;
   bulk := 0;
   while bulk < size_per_file and w do begin
      scalar name, defn, value;
      name := caar w;
      value := float caddar w/((1.0+sqrt float cadar w)*1000.0);
      defn := get(name, '!*savedef);
      remprop('name, '!*savedef);  % Save a little space.
      if null defn then <<
         princ "+++ "; prin name; printc ": no saved definition found";
         w := cdr w >>
      else <<
         bulk := listsize(defn, bulk);
         if bulk < size_per_file then <<
            benefit := benefit + caddar w;
            prin name; ttab 30; prin value;
            ttab 45; print (100.0*float benefit/float total_bytes_executed);
            c!:ccmpout1 ('de . name . cdr defn);
            w := cdr w >> >> end;
   eval '(c!-end);
   fnames := cdr fnames
   end;

terpri();
printc "*** End of compilation from REDUCE into C ***";
terpri();

bulk := 0;
% I list the next 50 functions that WOULD get selected - just for interest.
while bulk < 50 and w do
  begin
     name := caar w;
     value := float caddar w/((1.0+sqrt float cadar w)*1000.0);
     defn := get(name, '!*savedef);
     if null defn then <<
        princ "+++ "; prin name; printc ": no saved definition found";
        w := cdr w >>
     else <<
        bulk := bulk+1;
        benefit := benefit + caddar w;
        prin name; ttab 30; prin value;
        ttab 45; print (100.0*float benefit/float total_bytes_executed);
        w := cdr w >> end;

nil >>;

quit;