Artifact 6832f0cd0e2ed06a4daf9a8d629477d3e0ab3853af933644c0a90b7a385142b2:
- Executable file
r38/lisp/csl/util/build38.lsp
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 49510) [annotate] [blame] [check-ins using] [more...]
% "build38.lsp" % % Build a CSL REDUCE. % % Depending on how this file is used it will EITHER create a bootstrap % version of REDUCE or a full and optimised one. % % The behaviour is determined by whether the version of CSL used to % run it has a full complement of functions in the modules u01.c to u12.c. % % % slowr38 -z build38.lsp -D@srcdir=<DIR> -- log/boot38.log % % Builds a system "slowr38.img" that does not depend on any % custom C code. The main use of this slow system is for profiling % REDUCE and then compiling the hot-spots into C. Once that has been % done this image is logically unnecessary. % % % r38 -z build38.lsp -D@srcdir=<DIR> -l log/full38.log % % Here the files u01.c to u12.c and u01.lsp to u12.lsp must already % have been created, and that the r38 executable has them compiled in. % The REDUCE source files that are compiled *MUST* be the same as those used % to create this C code. % Author: Anthony C. Hearn, Stanley L. Kameny and Arthur Norman (verbos 3) (window!-heading "basic CSL") (setq !*savedef (lessp (cdr (assoc 'c!-code lispsystem!*)) 20)) (make!-special '!*native_code) (setq !*native_code nil) (cond ((null !*savedef) (progn (de c!:install (name env c!-version !&optional c1) (cond (c1 (check!-c!-code name env c!-version c1)) (t (progn (put name 'c!-version c!-version) (cond (env (prog (v n) (setq v (mkvect (sub1 (length env)))) (setq n 0) top (cond ((null env) (progn (put name 'funarg v) (return (symbol!-set!-env name v))))) (putv v n (car env)) (setq n (add1 n)) (setq env (cdr env)) (go top)))) name)))) (rdf "$srcdir/../csl-c/u01.lsp") (rdf "$srcdir/../csl-c/u02.lsp") (rdf "$srcdir/../csl-c/u03.lsp") (rdf "$srcdir/../csl-c/u04.lsp") (rdf "$srcdir/../csl-c/u05.lsp") (rdf "$srcdir/../csl-c/u06.lsp") (rdf "$srcdir/../csl-c/u07.lsp") (rdf "$srcdir/../csl-c/u08.lsp") (rdf "$srcdir/../csl-c/u09.lsp") (rdf "$srcdir/../csl-c/u10.lsp") (rdf "$srcdir/../csl-c/u11.lsp") (rdf "$srcdir/../csl-c/u12.lsp") ))) (rdf "$srcdir/../util/fastgets.lsp") (rdf "$srcdir/../cslbase/compat.lsp") (rdf "$srcdir/../cslbase/extras.lsp") (rdf "$srcdir/../cslbase/compiler.lsp") % (rdf "$srcdir/../cslbase/ccomp.lsp") (compile!-all) (setq !*comp t) % It's faster if we compile the boot file. % Tidy up be deleting any modules that are left over in this image (dolist (a (library!-members)) (delete!-module a)) % Build fasl files for the compatibility code and the two % versions of the compiler. (faslout 'cslcompat) (rdf "$srcdir/../util/fastgets.lsp") (rdf "$srcdir/../cslbase/compat.lsp") (rdf "$srcdir/../cslbase/extras.lsp") (faslend) (faslout 'compiler) (rdf "$srcdir/../cslbase/compiler.lsp") (faslend) %(faslout 'ccomp) %(rdf "$srcdir/../cslbase/ccomp.lsp") %(faslend) (setq !*comp t) (de concat (u v) (compress (cons '!" (append (explode2 u) (nconc (explode2 v) (list '!")))))) (global '(oldchan!*)) (setq prolog_file 'cslprolo) (setq rend_file 'cslrend) (setq !*argnochk t) (setq !*int nil) % Prevents input buffer being saved. (setq !*msg nil) (window!-heading "bootstrap RLISP") (rdf "$srcdir/../../../packages/support/boot.sl") (begin2) !@reduce := concat(!@srcdir, "/../../.."); rds(xxx := open("$reduce/packages/support/build.red",'input)); (close xxx) (load!-package!-sources prolog_file 'support) (load!-package!-sources 'rlisp 'rlisp) (load!-package!-sources rend_file 'support) (load!-package!-sources 'poly 'poly) (load!-package!-sources 'alg 'alg) (load!-package!-sources 'arith 'arith) % Needed by roots, specfn*, (psl). (load!-package!-sources 'entry 'support) (load!-package!-sources 'remake 'support) (setq !*comp nil) (begin) symbolic; !#if (not !*savedef) faslout 'user; % % The "user" module is only useful when building a full system, since % in the bootstrap the files u01.lsp to u12.lsp will probably not exist % and it is CERTAIN that they are not useful. % symbolic procedure c!:install(name, env, c!-version, !&optional, c1); begin scalar v, n; if c1 then return check!-c!-code(name, env, c!-version, c1); put(name, 'c!-version, c!-version); if null env then return name; v := mkvect sub1 length env; n := 0; while env do << putv(v, n, car env); n := n + 1; env := cdr env >>; % I only instate the environment if there is nothing useful there at % present. Actually this is even stronger. When a built-in function is % set up it gets NIL in its environment cell by default. Things that are % not defined at all have themselves there. if symbol!-env name = nil then symbol!-set!-env(name, v); put(name, 'funarg, v); return name; end; rdf "$srcdir/../csl-c/u01.lsp"$ rdf "$srcdir/../csl-c/u02.lsp"$ rdf "$srcdir/../csl-c/u03.lsp"$ rdf "$srcdir/../csl-c/u04.lsp"$ rdf "$srcdir/../csl-c/u05.lsp"$ rdf "$srcdir/../csl-c/u06.lsp"$ rdf "$srcdir/../csl-c/u07.lsp"$ rdf "$srcdir/../csl-c/u08.lsp"$ rdf "$srcdir/../csl-c/u09.lsp"$ rdf "$srcdir/../csl-c/u10.lsp"$ rdf "$srcdir/../csl-c/u11.lsp"$ rdf "$srcdir/../csl-c/u12.lsp"$ faslend; !#endif faslout 'remake; !#if (not !*savedef) load!-module "user"; !#endif !@reduce := concat(!@srcdir, "/../../.."); in "$reduce/packages/support/remake.red"$ global '(r38_base_modules r38_extra_modules r38_test_cases); % Master configuration data is stored in two DOS batch files. % This function extracts the information and puts it where I want it! symbolic procedure make_conf_file(); begin scalar a, p1, p2, p3, w; % upackage.bat may look like % set upackages=(support rlisp alg poly polydiv arith ...) % set upackages2=(odesolve pf cvit noncom2 physop crack liepde ...) % set upackages3=(specfn2 specfaux specbess sfgamma tps limits ...) % where the first list is of CORE packages needed for bootstrapping and all % subsequent ones are independent of each other (at least ideally). % % Well as I understand it at present in the development tree this file is % called vpackage.bat... if filep "$srcdir/../../../getred.pl" then a := open("$srcdir/../../../vpackage.bat", 'input) else a := open("$srcdir/../../../upackage.bat", 'input); p1 := nil; while atom p1 and p1 neq !$eof!$ do << a := rds a; p1 := read(); a := rds a >>; p2 := w := nil; while w neq !$eof!$ do << w := nil; while atom w and w neq !$eof!$ do << a := rds a; w := read(); a := rds a >>; if not atom w then p2 := append(p2, w) >>; close a; % xpackage.bat must be a list of test scripts, similar to this: % set xpackages=(alg poly polydiv arith factor int matrix solve ...) % set xpackages2=(odesolve pf cvit physop crack liepde applysym ...) % set xpackages3=(tps limits defint fps trigint ratint mathml ...) a := open("$srcdir/../../../xpackage.bat", 'input); p3 := w := nil; while w neq !$eof!$ do << w := nil; while atom w and w neq !$eof!$ do << a := rds a; w := read(); a := rds a >>; if not atom w then p3 := append(p3, w) >>; close a; if filep "$srcdir/../../../getred.pl" then a := "$srcdir/../util/devconfig.lsp" else a := "$srcdir/../util/config.lsp"; a := open(a, 'output); << a := wrs a; linelength 72; terpri(); printc "% These are packages that get built into the base system that"; printc "% is used to compile what follows..."; terpri(); prettyprint p1; terpri(); terpri(); printc "% The next set of modules are all built using a system that"; printc "% has the above set available. The key issue here is that the"; printc "% packages in this list of ""extensions"" can all be built"; printc "% independently of each other."; terpri(); % The v3tools module depends on the groebner code already being built, and so % it must appear late in the list. As I introduce this script the package.bat % file may not reflect that so FUDGE it here. if memq('v3tools, p2) then p2 := append(delete('v3tools, p2), '(v3tools)); % rltools must occur before redlog. This is also a pretty shameless FUDGE % here. if memq('rltools, p2) then p2 := 'rltools . delete('rltools, p2); prettyprint p2; terpri(); terpri(); printc "% Finally we have a list of all the test scripts that REDUCE"; printc "% is shipped with."; % As a special HACK I will remove gnuplot (if present) since at least as % of the time of working on this its level of interactivity causes the % profiling job to fail. r3 := delete('gnuplot, p3); terpri(); prettyprint p3; terpri(); terpri(); printc "% End of configuration file"; close wrs a >> end; symbolic procedure get_configuration_data full_version; % Read data from a configuration file that lists the modules that must % be processed. NOTE that this and the next few funtions will ONLY % work properly if REDUCE had been started up with the correct % working directory. This is (just about) acceptable because these are % system maintainance functions rather than generally flexible things % for arbitrary use. begin scalar i, j; % Configuration information is held in a file called something like % "config.lsp", but the exact details differ in a number of cases. For % the Development Version (not for general public use) this file will % be $srcdir/../util/devconfig.lsp. For a personal version it will be % util/config.lsp and in the case of a "professional" package it is % $srcdir/../util/config.lsp. The code here tries to detect which case % applies. If a file "$srcdir/../../../getred.pl" exists it will believe % it is the development tree! if filep "$srcdir/../../../getred.pl" then << i := "$srcdir/../util/devconfig.lsp"; j := "$srcdir/../../../vpackage.bat" >> else if full_version then << i := "$srcdir/../util/config.lsp"; j := "$srcdir/../../../vpackage.bat" >> else i := "util/config.lsp"; % I now try to ensure that the configuration file exists and is up to date. % Note that this is only done on a full build of Reduce. The [dev]config.lsp % is updated if either upackage.bat or xpackage.bat is newer than it... if not filep i or (j and filep j and datelessp(filedate i, filedate j)) or (filep "$srcdir/../../../xpackage.bat" and datelessp(filedate i, filedate "$srcdir/../../../xpackage.bat")) then make_conf_file(); i := open(i, 'input); i := rds i; r38_base_modules := read(); r38_extra_modules := read(); r38_test_cases := read(); i := rds i; close i end; symbolic procedure build_reduce_modules names; begin scalar w; !#if !*savedef !*savedef := t; !#else !*savedef := nil; !#endif make!-special '!*native_code; !*native_code := nil; load!-latest!-patches(); !@reduce := concat(!@srcdir, "/../../.."); in "$reduce/package.red"$ window!-heading list!-to!-string explodec car names; !#if !*savedef % When building the bootstrap version I want to record what switches % get declared... if not getd 'original!-switch then << w := getd 'switch; putd('original!-switch, car w, cdr w); putd('switch, 'expr, '(lambda (x) (dolist (y x) (princ "+++ Declaring a switch: ") (print y)) (original!-switch x))) >>; !#endif package!-remake car names; if null (names := cdr names) then printc "Recompilation complete"; !#if !*savedef if null names then restart!-csl 'begin !#else if null names then restart!-csl '(user begin) !#endif else restart!-csl('(remake build_reduce_modules), names) end; symbolic procedure test_a_package names; begin scalar packge, logname, logtmp, logfile, start_time, start_gctime, gt; scalar redef, quitfn, oll; princ "TESTING: "; print car names; window!-heading list!-to!-string explodec car names; !*backtrace := nil; !*errcont := t; !*extraecho := t; % Ensure standard environment for the test... !*int := nil; % ... so that results are predictable. packge := car names; verbos nil; load!-latest!-patches(); if boundp '!@log and stringp symbol!-value '!@log then logname := symbol!-value '!@log else logname := "log"; logname := concat("$srcdir/../../../", concat(logname, "/")); logtmp := concat(logname, concat(car names, ".tmp")); logname := concat(logname, concat(car names,".rlg")); logfile := open(logtmp, 'output); in_list1("$srcdir/../../../package.red", nil); begin scalar !*terminal!-io!*, !*standard!-output!*, !*error!-output!*, !*trace!-output!*, !*debug!-io!*, !*query!-io!*, !*errcont, outputhandler!*; !*terminal!-io!* := !*standard!-output!* := !*error!-output!* := logfile; !*trace!-output!* := !*debug!-io!* := !*query!-io!* := logfile; oll := linelength 80; princ date(); princ " run on "; printc cdr assoc('name, lispsystem!*); load!-package packge; if get(packge,'folder) then packge := get(packge,'folder); packge := concat("$srcdir/../../../packages/", concat(packge, concat("/", concat(car names,".tst")))); redef := !*redefmsg; !*redefmsg := nil; quitfn := getd 'quit; % At least at one stage at least one test file ends in "quit;" rather than % "end;" and the normal effect would be that this leads it to cancel % all execution instantly. To avoid that I will undefine the function % "quit", but restore it after the test. I reset !*redefmsg to avoid getting % messages about this. I redefined quit to something (specifically "posn") % that does not need an argument and that is "harmless". remd 'quit; putd('quit, 'expr, 'posn); start_time := time(); start_gctime := gctime(); !*mode := 'algebraic; !*extraecho := t; % Ensure standard environment for the test... !*int := nil; % ... so that results are predictable. !*errcont := t; in_list1(packge, t); erfg!* := nil; terpri(); putd('quit, car quitfn, cdr quitfn); !*redefmsg := redef; terpri(); prin2 "Time for test: "; gt := time() - start_time; % I ensure that the reported time is at least 1 millisecond. if gt = 0 then gt := 1; prin2 gt; prin2 " ms"; if (gt := gctime() - start_gctime) > 0 then << prin2 ", plus GC time: "; prin2 gt; prin2 " ms" >>; terpri(); linelength oll end; close logfile; delete!-file logname; rename!-file(logtmp, logname); names := cdr names; if null names then restart!-csl t else restart!-csl('(remake test_a_package), names) end; symbolic procedure personal_test_a_package names; % This version is only used with the personal version of REDUCE and uses % different paths to access files. begin scalar packge, logname, logtmp, logfile, start_time, start_gctime, gt; scalar redef, quitfn, oll; princ "TESTING: "; print car names; window!-heading list!-to!-string explodec car names; !*backtrace := nil; !*errcont := t; !*extraecho := t; % Ensure standard environment for the test... !*int := nil; % ... so that results are predictable. packge := car names; verbos nil; load!-latest!-patches(); if boundp '!@log and stringp symbol!-value '!@log then logname := symbol!-value '!@log else logname := "log"; logname := concat(logname, "/"); logtmp := concat(logname, concat(car names, ".tmp")); logname := concat(logname, concat(car names,".rlg")); logfile := open(logtmp, 'output); begin scalar !*terminal!-io!*, !*standard!-output!*, !*error!-output!*, !*trace!-output!*, !*debug!-io!*, !*query!-io!*, !*errcont, outputhandler!*; !*terminal!-io!* := !*standard!-output!* := !*error!-output!* := logfile; !*trace!-output!* := !*debug!-io!* := !*query!-io!* := logfile; oll := linelength 80; princ date(); princ " run on "; printc cdr assoc('name, lispsystem!*); load!-package packge; packge := concat("tests/", concat(car names,".tst")); redef := !*redefmsg; !*redefmsg := nil; quitfn := getd 'quit; % At least at one stage at least one test file ends in "quit;" rather than % "end;" and the normal effect would be that this leads it to cancel % all execution instantly. To avoid that I will undefine the function % "quit", but restore it after the test. I reset !*redefmsg to avoid getting % messages about this. I redefined quit to something (specifically "posn") % that does not need an argument and that is "harmless". remd 'quit; putd('quit, 'expr, 'posn); start_time := time(); start_gctime := gctime(); !*mode := 'algebraic; !*extraecho := t; % Ensure standard environment for the test... !*int := nil; % ... so that results are predictable. !*errcont := t; in_list1(packge, t); erfg!* := nil; terpri(); putd('quit, car quitfn, cdr quitfn); !*redefmsg := redef; terpri(); prin2 "Time for test: "; gt := time() - start_time; % I ensure that the reported time is at least 1 millisecond. if gt = 0 then gt := 1; prin2 gt; prin2 " ms"; if (gt := gctime() - start_gctime) > 0 then << prin2 ", plus GC time: "; prin2 gt; prin2 " ms" >>; terpri(); linelength oll end; close logfile; delete!-file logname; rename!-file(logtmp, logname); names := cdr names; if null names then restart!-csl t else restart!-csl('(remake personal_test_a_package), names) end; symbolic procedure report_incomplete_tests names; begin % Displays information about what "complete_tests" would do scalar packge, tfile, logname; scalar date1, date2, date3; in_list1("$srcdir/../../../package.red", nil); for each packge in names do << tfile := packge; if get(packge,'folder) then tfile := get(packge,'folder); tfile := concat("$srcdir/../../../packages/", concat(tfile, concat("/", concat(packge,".tst")))); if boundp '!@log and stringp symbol!-value '!@log then logname := symbol!-value '!@log else logname := "log"; logname := concat("$srcdir/../../../", concat(logname, "/")); logname := concat(logname, concat(packge,".rlg")); date1 := filedate "r38.img"; date2 := filedate tfile; date3 := filedate logname; if null date1 then date1 := date(); if null date2 then date2 := date(); if null date3 or datelessp(date3, date1) or datelessp(date3, date2) then << princ "NEED TO TEST: "; print packge >> >> end; symbolic procedure complete_tests names; begin % Just like the previous testing code except that logs that are already up % to date are not re-generated. scalar packge, tfile, logname, logfile, logtmp, start_time, start_gctime, gt; scalar date1, date2, date3, oll; !*backtrace := nil; !*errcont := t; !*extraecho := t; % Ensure standard environment for the test... !*int := nil; % ... so that results are predictable. verbos nil; load!-latest!-patches(); in_list1("$srcdir/../../../package.red", nil); top: tfile := packge := car names; if get(tfile,'folder) then tfile := get(tfile,'folder); tfile := concat("$srcdir/../../../packages/", concat(tfile, concat("/", concat(packge,".tst")))); if boundp '!@log and stringp symbol!-value '!@log then logname := symbol!-value '!@log else logname := "log"; logname := concat("$srcdir/../../../", concat(logname, "/")); logtmp := concat(logname, concat(packge, ".tmp")); logname := concat(logname, concat(packge, ".rlg")); date1 := filedate "r38.img"; date2 := filedate tfile; date3 := filedate logname; if null date1 then date1 := date(); if null date2 then date2 := date(); if null date3 or datelessp(date3, date1) or datelessp(date3, date2) then << princ "TESTING: "; print packge; window!-heading list!-to!-string explodec packge; logfile := open(logtmp, 'output); start_time := time(); start_gctime := gctime(); begin scalar !*terminal!-io!*, !*standard!-output!*, !*error!-output!*, !*trace!-output!*, !*debug!-io!*, !*query!-io!*, !*errcont, outputhandler!*, redef, quitfn; !*terminal!-io!* := !*standard!-output!* := !*error!-output!* := logfile; !*trace!-output!* := !*debug!-io!* := !*query!-io!* := logfile; oll := linelength 80; princ date(); princ " run on "; printc cdr assoc('name, lispsystem!*); load!-package packge; !*mode := 'algebraic; !*extraecho := t; % Ensure standard environment for the test... !*int := nil; % ... so that results are predictable. redef := !*redefmsg; !*redefmsg := nil; quitfn := getd 'quit; remd 'quit; putd('quit, 'expr, 'posn); !*errcont := t; in_list1(tfile, t); erfg!* := nil; terpri(); putd('quit, car quitfn, cdr quitfn); !*redefmsg := redef; terpri(); prin2 "Time for test: "; gt := time() - start_time; if gt = 0 then gt := 1; prin2 gt; prin2 " ms"; if (gt := gctime() - start_gctime) > 0 then << prin2 ", plus GC time: "; prin2 gt; prin2 " ms" >>; terpri(); linelength oll end; close logfile; delete!-file logname; rename!-file(logtmp, logname) >> else if cdr names then << names := cdr names; go to top >>; names := cdr names; if null names then restart!-csl t else restart!-csl('(remake complete_tests), names) end; symbolic procedure profile_compare_fn(p, q); (float caddr p/float cadr p) < (float caddr q/float cadr q); % % This function runs a test file and sorts out what the top 350 % functions in it. It appends their names to "profile.dat". % % I need to talk a little about the interaction between profiling and % patching. Well firstly I arrange that whenever I run a profiling job % I rebuild REDUCE with the latest paches. This may involve re-compiling % the patches.red source. Thus when a test is run the current patches % will be in place. Patched functions are first defined with funny names % (including a hash based on their definition) and then copied into place % when a package is loaded. However MAPSTORE and the CSL instrumentation % attributes their cost to the hash-extended name even though the % functions may have been called via the simple one. Thus in the face % of patches one can expect the profile data to refer to some names that % are long and curious looking. Throughout all this I assume that there will % never be embarassing collisions in my hash functions. symbolic procedure profile_a_package names; begin scalar packge, oll, w, w1, w2, quitfn, !*errcont; princ "PROFILING: "; print car names; !*backtrace := nil; !*errcont := t; !*int := nil; packge := car names; verbos nil; load!-latest!-patches(); load!-package packge; in_list1("$srcdir/../../../package.red", nil); if get(packge,'folder) then packge := get(packge,'folder); packge := concat("$srcdir/../../../packages/", concat(packge, concat("/", concat(car names,".tst")))); oll := linelength 80; !*mode := 'algebraic; window!-heading list!-to!-string explodec car names; quitfn := getd 'quit; remd 'quit; putd('quit, 'expr, 'posn); mapstore 4; % reset counts; !*errcont := t; % I try hard to arrange that even if the test fails I can continue and that % input & output file selection is not messed up for me. w := wrs nil; w1 := rds nil; wrs w; rds w1; errorset(list('in_list1, mkquote packge, t), nil, nil); wrs w; rds w1; erfg!* := nil; terpri(); putd('quit, car quitfn, cdr quitfn); w := sort(mapstore 2, function profile_compare_fn); w1 := nil; while w do << w2 := get(caar w, '!*savedef); % if eqcar(w2, 'lambda) then << % princ "md60: "; print (caar w . cdr w2); % princ "= "; print md60 (caar w . cdr w2) >>; if eqcar(w2, 'lambda) then w1 := (caar w . md60 (caar w . cdr w2) . cadar w . caddar w) . w1; w := cdr w >>; w := w1; % I collect the top 350 functions as used by each test, not because all % that many will be wanted but because I might as well record plenty % of information here and discard unwanted parts later on. for i := 1:349 do if w1 then w1 := cdr w1; if w1 then rplacd(w1, nil); % princ "MODULE "; prin car names; princ " suggests "; % print for each z in w collect car z; w1 := open("profile.dat", 'append); w1 := wrs w1; linelength 80; princ "("; prin car names; terpri(); for each n in w do << princ " ("; prin car n; princ " "; if posn() > 30 then << terpri(); ttab 30 >>; prin cadr n; % I also display the counts just to help me debug & for interest. princ " "; prin caddr n; princ " "; princ cdddr n; printc ")" >>; printc " )"; terpri(); close wrs w1; linelength oll; names := cdr names; if null names then restart!-csl t else restart!-csl('(remake profile_a_package), names) end; symbolic procedure trim_prefix(a, b); begin while a and b and car a = car b do << a := cdr a; b := cdr b >>; if null a then return b else return nil end; fluid '(time_info); symbolic procedure read_file f1; begin % I take the view that I can afford to read the whole of a file into % memory at the start of processing. This makes life easier for me % and the REDUCE log files are small compared with current main memory sizes. scalar r, w, w1, n, x; scalar p1, p2, p3, p4, p5, p6, p7; % To make comparisons between my CSL logs and some of the Hearn "reference % logs", which are created using a different script, I will discard % lines that match certain patterns! Note that if the reference logs change % the particular tests I perform here could become out of date! Also if any % legitimate test output happened to match one of the following strings % I would lose out slightly. p1 := explodec "REDUCE 3.8,"; p2 := explodec "1: 1:"; p3 := explodec "2: 2: 2:"; p4 := explodec "3: 3: "; % a prefix to first real line of output. p5 := explodec "4: 4: 4:"; p6 := explodec "5: 5:"; p7 := explodec "Quittin"; % nb left so that the "g" remains! % this is so that the match is detected. r := nil; n := 0; while not ((w := readline f1) = !$eof!$) do << w1 := explodec w; if x := trim_prefix(p4, w1) then r := ((n := n + 1) . list!-to!-string x) . r else if trim_prefix(p1, w1) or trim_prefix(p2, w1) or trim_prefix(p3, w1) or trim_prefix(p5, w1) or trim_prefix(p6, w1) or trim_prefix(p7, w1) then nil else r := ((n := n + 1) . w) . r >>; w := r; % The text scanned for here is expected to match that generated by the % test script. I locate the last match in a file, extract the numbers % and eventually write them to log/times.log n := explodec "Time for test:"; while w and null (x := trim_prefix(n, explodec cdar w)) do w := cdr w; if null w then << time_info := nil; return reversip r >>; while eqcar(x, '! ) do x := cdr x; w := n := nil; while digit car x do << w := car x . w; x := cdr x >>; while eqcar(x, '! ) do x := cdr x; if x := trim_prefix(explodec "ms, plus GC time:", x) then << while eqcar(x, '! ) do x := cdr x; while digit car x do << n := car x . n; x := cdr x >> >>; if null w then w := '(!0); if null n then n := '(!0); time_info := compress reverse w . compress reverse n; return reversip r; end; symbolic procedure roughly_equal(a, b); begin % a and b are strings repesenting lines of text. I want to test if they % match subject to some floating point slop. scalar wa, wb, adot, bdot; if a = b then return t; a := explodec a; b := explodec b; top: % First deal with end of line matters. if null a and null b then return t else if null a or null b then return nil; % next split off any bits of a and b up to a digit wa := wb := nil; while a and not digit car a do << wa := car a . wa; a := cdr a >>; while b and not digit car b do << wb := car b . wb; b := cdr b >>; if not (wa = wb) then return nil; % now both a and b start with digits. I will seek a chunk of the % form nnn.mmmE+xxx where E<sign>xxx is optional... % Note that any leading sign on the float has been checked already! wa := wb := nil; adot := bdot := nil; while a and digit car a do << wa := car a . wa; a := cdr a >>; if eqcar(a, '!.) then << adot := t; wa := car a . wa; a := cdr a >>; while a and digit car a do << wa := car a . wa; a := cdr a >>; if eqcar(a, '!e) or eqcar(a, '!E) then << adot := t; wa := car a . wa; a := cdr a; if eqcar(a, '!+) or eqcar(a, '!-) then << wa := car a . wa; a := cdr a >>; while a and digit car a do << wa := car a . wa; a := cdr a >> >>; % Now all the same to grab a float from b while b and digit car b do << wb := car b . wb; b := cdr b >>; if eqcar(b, '!.) then << bdot := t; wb := car b . wb; b := cdr b >>; while b and digit car b do << wb := car b . wb; b := cdr b >>; if eqcar(b, '!e) or eqcar(b, '!E) then << bdot := t; wb := car b . wb; b := cdr b; if eqcar(b, '!+) or eqcar(b, '!-) then << wb := car b . wb; b := cdr b >>; while b and digit car b do << wb := car b . wb; b := cdr b >> >>; % Now one possibility is that I had an integer not a float, % and in that case I want an exact match if not adot or not bdot then << if wa = wb then goto top else return nil >>; if wa = wb then goto top; % textual match on floating point values wa := compress reversip wa; wb := compress reversip wb; if fixp wa then wa := float wa; if fixp wb then wb := float wb; if not (floatp wa and floatp wb) then return nil; % messed up somehow! if wa = wb then goto top; % now the crucial approximate floating point test - note that both numbers % are positive, but that they may be extreme in range. % As a cop-out I am going to insist that if values are either very very big % or very very small that they match as text. if wa > 1.0e100 or wb > 1.0e100 then return nil; if wa < 1.0e-100 or wb < 1.0e-100 then return nil; wa := (wa - wb)/(wa + wb); if wa < 0 then wa := -wa; if wa > 0.0001 then return nil; % pretty crude! goto top end; symbolic procedure in_sync(d1, n1, d2, n2); begin for i := 1:n1 do if d1 then << % skip n1 lines from d1 d1 := cdr d1 >>; for i := 1:n2 do if d2 then << % skip n2 lines from d2 d2 := cdr d2 >>; % If one is ended but the other is not then we do not have a match. If % both are ended we do have one. if null d1 then return null d2 else if null d2 then return nil; % Here I insist on 3 lines that agree before I count a match as % having been re-established. if not roughly_equal(cdar d1, cdar d2) then return nil; d1 := cdr d1; d2 := cdr d2; if null d1 then return null d2 else if null d2 then return nil; if not roughly_equal(cdar d1, cdar d2) then return nil; d1 := cdr d1; d2 := cdr d2; if null d1 then return null d2 else if null d2 then return nil; if not roughly_equal(cdar d1, cdar d2) then return nil; d1 := cdr d1; d2 := cdr d2; if null d1 then return null d2 else if null d2 then return nil else return t end; fluid '(time_data time_ratio gc_time_ratio log_count); symbolic procedure file_compare(f1, f2, name); begin scalar i, j, d1, d2, t1, gt1, t2, gt2, time_info; d1 := read_file f1; if null time_info then t1 := gt1 := 0 else << t1 := car time_info; gt1 := cdr time_info >>; d2 := read_file f2; if null time_info then t2 := gt2 := 0 else << t2 := car time_info; gt2 := cdr time_info >>; i := wrs time_data; j := set!-print!-precision 3; prin name; ttab 20; if zerop t1 then princ "---" else << prin t1; ttab 30; prin gt1 >>; ttab 40; if zerop t2 then princ "---" else << prin t2; ttab 50; prin gt2 >>; ttab 60; if zerop t1 or zerop t2 then princ "*** ***" else begin scalar r1, gr1; r1 := float t1 / float t2; gr1 := float (t1+gt1)/float (t2+gt2); % I will only use tests where the time taken was over 200ms in my eventual % composite summary of timings, since measurement accuracy can leave the % really short tests pretty meaningless. if t1 > 200 and t2 > 200 then << time_ratio := time_ratio * r1; gc_time_ratio := gc_time_ratio * gr1; log_count := log_count + 1 >>; prin r1; ttab 70; prin gr1 end; terpri(); set!-print!-precision j; wrs i; % The next segment of code is a version of "diff" to report ways in which % reference and recent log files match or diverge. % I can not see a neat way to get a "structured" control structure % here easily. Ah well, drop back to GOTO statements! top: if null d1 then << % end of one file if d2 then terpri(); i := 0; while d2 and i < 20 do << princ "REF "; princ caar d2; princ ":"; ttab 10; printc cdar d2; d2 := cdr d2; i := i + 1 >>; if d2 then printc "..."; return >>; if null d2 then << % end of other file i := 0; while d1 and i < 20 do << princ "NEW "; princ caar d1; princ ":"; ttab 10; printc cdar d1; d1 := cdr d1; i := i + 1 >>; if d1 then printc "..."; return >>; % The test "roughly_equal" compares allowing some tolerance on floating % point values. This is because REDUCE uses platform libraries for % floating point elementary functions and printing, so small differences % are expected. This is perhaps uncomfortable, but is part of reality, and % the test here makes comparison output much more useful in that the % differences shown up are better limited towards "real" ones. if roughly_equal(cdar d1, cdar d2) then << d1 := cdr d1; d2 := cdr d2; go to top >>; % I will first see if there are just a few blank lines inserted into % one or other file. This special case is addressed here because it % appears more common a possibility than I had expected. if cdar d1 = "" and cdr d1 and roughly_equal(cdadr d1, cdar d2) then << princ "NEW "; princ caar d1; princ ":"; ttab 10; printc cdar d1; d1 := cdr d1; go to top >> else if cdar d1 = "" and cdr d1 and cdadr d1 = "" and cddr d1 and roughly_equal(cdaddr d1, cdar d2) then << princ "NEW "; princ caar d1; princ ":"; ttab 10; printc cdar d1; d1 := cdr d1; princ "NEW "; princ caar d1; princ ":"; ttab 10; printc cdar d1; d1 := cdr d1; go to top >> else if cdar d2 = "" and cdr d2 and roughly_equal(cdadr d2, cdar d1) then << princ "REF "; princ caar d2; princ ":"; ttab 10; printc cdar d2; d2 := cdr d2; go to top >> else if cdar d2 = "" and cdr d2 and cdadr d2 = "" and cddr d2 and roughly_equal(cdaddr d2, cdar d1) then << princ "REF "; princ caar d2; princ ":"; ttab 10; printc cdar d2; d2 := cdr d2; princ "REF "; princ caar d2; princ ":"; ttab 10; printc cdar d2; d2 := cdr d2; go to top >>; i := 1; seek_rematch: j := 0; inner: if in_sync(d1, i, d2, j) then << terpri(); for k := 1:i do << princ "NEW "; princ caar d1; princ ":"; ttab 10; printc cdar d1; d1 := cdr d1 >>; for k := 1:j do << princ "REF "; princ caar d2; princ ":"; ttab 10; printc cdar d2; d2 := cdr d2 >>; % Should be in step again here. if null d1 then return else go to top >>; j := j + 1; i := i - 1; if i >= 0 then go to inner; i := j; % I am prepared to seek 80 lines ahead on each side before I give up. % The number 80 is pretty much arbitrary. if i < 80 then goto seek_rematch; terpri(); i := 0; while d2 and i < 20 do << princ "REF "; princ caar d2; princ ":"; ttab 10; printc cdar d2; d2 := cdr d2; i := i+1 >>; if d2 then printc "..."; i := 0; while d1 and i < 20 do << princ "NEW "; princ caar d1; princ ":"; ttab 10; printc cdar d1; d1 := cdr d1; i := i+1 >>; if d1 then printc "..."; printc "Comparison failed." end; fluid '(which_module); symbolic procedure check_a_package; begin scalar oll, names, p1, logname, mylogname, mylog, reflogname, reflog, time_data, time_ratio, gc_time_ratio, log_count; get_configuration_data t; if boundp 'which_module and symbol!-value 'which_module and not (symbol!-value 'which_module = "") then << names := compress explodec symbol!-value 'which_module; if member(names, r38_test_cases) then names := list names else error(0, list("unknown module to check", which_module)) >> else names := r38_test_cases; in_list1("$srcdir/../../../package.red", nil); % I write a summary of timing information into log/times.log time_data := open("log/times.log", 'output); p1 := wrs time_data; princ "MODULE"; ttab 20; princ "Local"; ttab 30; princ "(GC)"; ttab 40; princ "Reference"; ttab 50; princ "(GC)"; ttab 60; princ "Ratio"; ttab 70; printc "inc GC"; wrs p1; terpri(); oll := linelength 100; printc "=== Comparison results ==="; time_ratio := gc_time_ratio := 1.0; log_count := 0; for each packge in names do << terpri(); princ "CHECKING: "; print packge; if boundp '!@log and stringp symbol!-value '!@log then logname := symbol!-value '!@log else logname := "log"; logname := concat("$srcdir/../../../", concat(logname, "/")); mylogname := concat(logname, concat(packge, ".rlg")); if get(packge,'folder) then p1 := get(packge,'folder) else p1 := packge; reflogname := concat("$srcdir/../../../packages/", concat(p1, concat("/", concat(packge,".rlg")))); mylog := errorset(list('open, mkquote mylogname, ''input), nil, nil); reflog := errorset(list('open, mkquote reflogname, ''input), nil, nil); if errorp mylog then << if not errorp reflog then close car reflog; princ "No current log in "; print mylogname >> else if errorp reflog then << close car mylog; princ "No reference log in "; print reflogname >> else << princ "LOGS: "; princ mylogname; princ " "; printc reflogname; mylog := car mylog; reflog := car reflog; file_compare(mylog, reflog, packge); close mylog; close reflog >> >>; time_data := wrs time_data; if not zerop log_count then << time_ratio := expt(time_ratio, 1.0/log_count); gc_time_ratio := expt(gc_time_ratio, 1.0/log_count); terpri(); p1 := set!-print!-precision 3; princ "Over "; prin log_count; princ " tests the speed ratio was "; print time_ratio; princ " (or "; prin gc_time_ratio; printc " is garbage collection costs are included)"; set!-print!-precision p1 >>; close wrs time_data; linelength oll; end; symbolic procedure personal_check_a_package; begin scalar oll, names, p1, logname, mylogname, mylog, reflogname, reflog, time_data, time_ratio, gc_time_ratio, log_count; get_configuration_data nil; if boundp 'which_module and symbol!-value 'which_module and not (symbol!-value 'which_module = "") then << names := compress explodec symbol!-value 'which_module; if member(names, r38_test_cases) then names := list names else error(0, list("unknown module to check", which_module)) >> else names := r38_test_cases; % I write a summary of timing information into log/times.log time_data := open("log/times.log", 'output); p1 := wrs time_data; princ "MODULE"; ttab 20; princ "Local"; ttab 30; princ "(GC)"; ttab 40; princ "Reference"; ttab 50; princ "(GC)"; ttab 60; princ "Ratio"; ttab 70; printc "inc GC"; wrs p1; terpri(); oll := linelength 100; printc "=== Comparison results ==="; time_ratio := gc_time_ratio := 1.0; log_count := 0; for each packge in names do << terpri(); princ "CHECKING: "; print packge; mylogname := concat("log/", concat(packge, ".rlg")); reflogname := concat("tests/", concat(packge,".rlg")); mylog := errorset(list('open, mkquote mylogname, ''input), nil, nil); reflog := errorset(list('open, mkquote reflogname, ''input), nil, nil); if errorp mylog then << if not errorp reflog then close car reflog; princ "No current log in "; print mylogname >> else if errorp reflog then << close car mylog; princ "No reference log in "; print reflogname >> else << princ "LOGS: "; princ mylogname; princ " "; printc reflogname; mylog := car mylog; reflog := car reflog; file_compare(mylog, reflog, packge); close mylog; close reflog >> >>; time_data := wrs time_data; if not zerop log_count then << time_ratio := expt(time_ratio, 1.0/log_count); gc_time_ratio := expt(gc_time_ratio, 1.0/log_count); terpri(); p1 := set!-print!-precision 3; princ "Over "; prin log_count; princ " tests the speed ratio was "; print time_ratio; princ " (or "; prin gc_time_ratio; printc " is garbage collection costs are included)"; set!-print!-precision p1 >>; close wrs time_data; linelength oll; end; faslend; % faslout 'cslhelp; % % module cslhelp; % % global '(!*force); % % flag('(force),'switch); % flag('(on),'eval); % % on force; % % symbolic procedure formhelp(u,vars,mode); % list('help, 'list . for each x in cdr u collect mkquote x); % % if member('help, lispsystem!*) then << % put('help, 'stat, 'rlis); % flag('(help), 'go); % put('help, 'formfn, 'formhelp) >>; % % off force; % remflag('(on),'eval); % % endmodule; % % faslend; load!-module 'remake; << initreduce(); date!* := "Bootstrap version"; !@reduce := symbol!-value gensym(); checkpoint('begin, "REDUCE 3.8") >>; !#if (not !*savedef) load!-module 'user; !#endif !@reduce := concat(!@srcdir, "/../../.."); in "$reduce/package.red"$ package!-remake2(prolog_file,'support); package!-remake2(rend_file,'support); package!-remake2('entry,'support); package!-remake2('remake,'support); % The next lines have LOTS of hidden depth! They restart CSL repeatedly % so that each of the modules that has to be processed gets dealt with in % a fresh uncluttered environment. The list of modules is fetched from % a configuration file which must have 3 s-expressions in it. The first % is a list of basic modules that must be built to get a core version of % REDUCE. The second list identifies modules that can be built one the core % is ready for use, while the last list indicates which modules have % associated test scripts. % % when the modules have been rebuild the system does a restart that % kicks it back into REDUCE by calling begin(). This then continues % reading from the stream that had been the standard input when this % job started. Thus this script MUST be invoked as % ./csl -oslowr38.img -z build38.lsp -l log/build38.log % with the file build38.lsp specified on the command line in the call. It % will not work if you start csl manually and then do a (rdf ..) [say] % on build38.lsp. I told you that it was a little delicate. !#if !*savedef % Some switches may be in the utter core and not introduced via the % "switch" declaration... for each y in oblist() do if flagp(y, 'switch) then << princ "+++ Declaring a switch: "; print y >>; !#endif get_configuration_data t; build_reduce_modules r38_base_modules; % Now I want to do a cold-start so that I can create a sensible % image for use in the subsequent build steps. This image should not % contain ANYTHING extraneous. symbolic restart!-csl nil; (setq !*savedef (lessp (cdr (assoc 'c!-code lispsystem!*)) 20)) (make!-special '!*native_code) (setq !*native_code nil) (setq !*backtrace t) (cond ((null !*savedef) (load!-module 'user))) (load!-module 'cslcompat) (setq !*comp nil) (load!-module 'module) % Definition of load_package, etc. (load!-module 'cslprolo) % CSL specific code. (setq loaded!-packages!* '(cslcompat user cslprolo)) % NB I will re-load the "patches" module when REDUCE is started % if there is a version newer than the one I load up here. Note that % if there had not been a "patches.red" file I will not have a module to load % here. (cond ((modulep 'patches) (load!-module 'patches))) (load!-package 'rlisp) (load!-package 'cslrend) (load!-package 'poly) (load!-package 'arith) (load!-package 'alg) (load!-package 'mathpr) (cond ((modulep 'tmprint) (load!-package 'tmprint))) (load!-package 'entry) % (write!-help!-module "$srcdir/../util/r38.inf" nil) % % (load!-module 'cslhelp) (setq version!* "REDUCE 3.8") (setq !*backtrace nil) (initreduce) (setq date!* "15-Apr-04") (setq no_init_file nil) (setq !@csl (setq !@reduce (symbol!-value (gensym)))) % If the user compiles a new FASL module then I will let it % generate native code by default. I build the bulk of REDUCE % without that since I have statically-selected hot-spot compilation % that gives me what I believe to be a better speed/space tradeoff. (fluid '(!*native_code)) (setq !*native_code t) (checkpoint 'begin (bldmsg "%w, %w ..." version!* date!*)) (setq no_init_file t) (begin) % % See the fairly length comments given a bit earlier about the % delicacy of the next few lines! % symbolic; load!-module 'remake; get_configuration_data t; build_reduce_modules r38_extra_modules; % At this stage I have a complete workable REDUCE. If built using a % basic CSL (I call it "slowr38" here) nothing has been compiled into C % (everything is bytecoded), and it is big because it has retained all % Lisp source code in the image file. If however I built using a version % of CSL ("r38") that did have things compiled into C then these will % be exploited and the original Lisp source will be omitted from the % image, leaving a production version. bye;