From: William Harold Newman Date: Fri, 22 Sep 2000 15:21:23 +0000 (+0000) Subject: primarily intending to integrate Colin Walter's O(N) map code and X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=e4eb979046e594444cf5972801ea5f4a5eb1a7c7;p=sbcl.git primarily intending to integrate Colin Walter's O(N) map code and fixing BUTLAST (but doing some other stuff too, since achieving the primary objective involved a lot of inspecting other code): another revision of MAP stuff, part I: * I switched over to code inspired by Colin Walters' O(N) MAP code (from the cmucl-imp mailing list 2000 Sep 02) for the general non-DEFTRANSFORM case. * HIGH-SECURITY-SUPPORT error checking logic goes away, pending part II * I made some miscellaneous cleanups of old arity-1 code too. * The old MAP-FOR-EFFECT, MAP-TO-LIST, and MAP-TO-SIMPLE macros, and the old functions MAP-WITHOUT-ERRORCHECKING, and GET-MINIMUM-LENGTH-SEQUENCES go away. * The old #+!HIGH-SECURITY length-checking logic goes away, to be replaced by stuff in part II. * New O(N) functions %MAP-FOR-EFFECT, %MAP-TO-LIST, and %MAP-TO-VECTOR are added, and MAP is redefined in terms of them. * Add a note pointing out that since MAP-INTO has not been rewritten to take advantage of all the new mapping technology, it's still slow. * Delete no-longer-used ELT-SLICE macro. another revision of MAP stuff, part II: Peter Van Eynde might go into a killing frenzy, or at least his ansi-test suite will gnaw SBCL to death, unless we raise type errors on length mismatches like (MAP '(SIMPLE-VECTOR 128) #'+ #(1 2) #(1 1)). How to do this without clobbering efficiency? More DEFTRANSFORMs, I think.. * MAP becomes a wrapper around %MAP. %MAP doesn't do this kind of length checking, MAP does. The old DEFUN MAP, DEFKNOWN MAP, and DEFTRANSFORM MAP stuff all turns into corresponding definitions for %MAP. The wrapper is implemented both as a DEFUN MAP and a DEFTRANSFORM MAP. * Now make DEFTRANSFORM MAP smarter: ** If necessary, check at runtime that ARRAY-DIMENSION matches what we pull out of SPECIFIER-TYPE. ** No test is done when SPEED > SAFETY. ** No test is needed when we can tell at compile time that the result type doesn't specify the length of the result. * Also add the same kind of ARRAY-DIMENSION/SPECIFIER-TYPE runtime check to DEFUN MAP. * While I'm at it, since DEFTRANSFORM MAP needs to think hard about the type of the result anyway, it might as well declare what it's figured out (TRULY-THE) to benefit any code downstream. Start playing with MAP regression tests. Add tests/assertoid.lisp to support future regression tests. Once I started using the QUIT :UNIX-CODE keyword argument in my test cases, I could see that it isn't very mnemonic. So I changed it to the more-descriptive name :UNIX-STATUS, leaving the old name supported but deprecated. Oops! The old DEFTRANSFORM MAP (now DEFTRANSFORM %MAP) should really only be done when (>= SPEED SPACE), but it wasn't declared that way. While looking for an example of a DEFTRANSFORM with &REST arguments to use as a model for the code in the new DEFTRANSFORM from MAP to %MAP, I noticed that the problem of taking a list of names and generating a corresponding list of gensyms is solved in many different places in the code, in several ways. Also, the related problem of just creating a list of N gensyms is solved in several places in in the code. This seems unnecessarily error-prone and wasteful, so I went looking for such cases and turned them into calls to MAKE-GENSYM-LIST. another revision of MAP stuff, part III: * Search for 'map' in the output from clocc ansi-tests/tests.lisp, to check that the new MAP code isn't too obviously broken. * Add some regression tests in test/map.impure.lisp. Oops! The various %MAP-..-ARITY-1 helper functions expect a function argument, but DEFTRANSFORM MAP can call them passing them a function name instead. * Change the helper functions so that they can handle function names as arguments. * Define %COERCE-CALLABLE-TO-FUNCTION to help with this. Note that this seems to be what %COERCE-NAME-TO-FUNCTION meant long ago, judging from DEFTRANSFORM %COERCE-NAME-TO-FUNCTION; so appropriate that DEFTRANSFORM for %COERCE-CALLABLE-TO-FUNCTION. * Use %COERCE-CALLABLE-TO-FUNCTION elsewhere that expressions involving %COERCE-NAME-TO-FUNCTION were used previously. deleted the old commented-out version of DEFMACRO HANDLER-CASE (since it was marked "Delete this when the system is stable.":-) deleted the old commented-out version of GEN-FORMAT-DEF-FORM, since it was supposed to be safe to do so after sbcl-0.6.4 I removed the apology for not using PRINT-OBJECT everywhere in the printer from the bugs list in the man page, since it seems to be rather tricky to construct a test case which exposes the system's non-PRINT-OBJECT-ness without the test case itself violating the ANSI spec. I updated, cleaned up, or removed outright some other outdated or confusing entries in the BUGS file and from the bugs list on the man page. Now that BUTLAST no longer blows up on the new problem cases a la (BUTLAST NIL -1), I wonder whether I could stop it from blowing up on the old problem cases a la (BUTLAST NIL)? It looks like a compiler problem, since the interpreted definition of BUTLAST works, even though the compiled one doesn't. In fact, it's a declaration problem, since LENGTH is set to -1 when LIST=NIL, but is declared as an INDEX. (Of course it's likely also a compiler problem, since the compiler is supposed to signal type errors for this kind of declaration error.) I fixed the misdeclaration, and noted the possible compiler bug in BUGS. After writing the new revised weird type declarations for the not-necessarily positive LENGTH, and writing explanatory comments, ;; (Despite the name, LENGTH can be -1 when when LIST is an ATOM.) for each of the cut-and-pasted (LET ((LENGTH ..)) ..) forms in BUTLAST and NBUTLAST, I said "screw it" -- no, that's not it, I quoted Martin Fowler and Kent Beck: "If you see the same code structure in more than one place, you can be sure that your program will be better if you find a way to unify them," and "It's surprising how often you look at thickly commented code and notice that the comments are there because the code is bad." So I just rewrote BUTLAST and NBUTLAST. Hopefully the new versions will be better-behaved than the old ones. Now that the INDEX type is used in DEFUN MAKE-GENSYM-LIST, which belongs in early-extensions.lisp, INDEX should be defined before early-extensions.lisp, i.e. earlier than its current definition in early-c.lisp. Move it to early-extensions.lisp. Then to make that work, since DEF!TYPE is used to define INDEX, defbangtype.lisp needs to precede early-extensions.lisp in stems-and-flags.lisp-expr; so move it. Also, INDEX is defined in terms of SB!XC:ARRAY-DIMENSION-LIMIT, so early-array.lisp needs to move before the new location of defbangtype.lisp. And then early-vm.lisp needs to move before that, so I might as well move the rest of the early-vm-ish stuff back too. And then DEFTYPE is used before deftype.lisp, so I need to change DEFMACRO DEF!TYPE to DEF!MACRO DEF!TYPE, so I need to move defbangmacro.lisp before deftype.lisp. (This is like a trip down memory lane to the endless tweaks and recompiles it took me to find and unravel the twisted order dependencies which make CMU CL unbootstrappable. Ah, those were the days..:-) The DEFTYPEs for INDEX and POSN in early-assem.lisp duplicate the functionality of the SB-KERNEL:INDEX type. * Change uses of the SB-ASSEM::POSN type to uses of the INDEX type. * Delete the SB-ASSEM::POSN type and the SB-ASSEM::MAX-POSN constant. * Move SB-KERNEL:INDEX into SB-INT, since it's not really just a kernel-level thing, but makes sense for implementing user-level stuff in SB-INT and SB-EXT and SB-C (and SB-ASSEM). * Grep for all '[a-z]:+index[^-a-z]' and rename them (or just remove prefixes) to match new SB-INT-ness of INDEX. * Make the SB-ASSEM package use the SB-INT package; delete the SB-ASSEM::INDEX type and SB-ASSEM::MAX-INDEX constant. And since as a rule anything which can see SB-INT deserves to see SB-EXT too, make SB-ASSEM use SB-EXT as well. --- diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 72d3a40..06015e4 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -2807,7 +2807,7 @@ initially undefined function references:~2%") (*data-page* 0)) (format t - "[building initial core file in file ~S: ~%" + "[building initial core file in ~S: ~%" filenamestring) (force-output) diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index 2926e72..cd3447d 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -47,7 +47,7 @@ (i 0 (1+ i))) ((>= i no-of-slots)) ;endp rem-slots)) (declare (list rem-slots) - (type sb-kernel:index i)) + (type sb-int:index i)) (setf (aref slots i) (first rem-slots))) slots)) (t diff --git a/src/pcl/fngen.lisp b/src/pcl/fngen.lisp index 9c74f49..4bd35ca 100644 --- a/src/pcl/fngen.lisp +++ b/src/pcl/fngen.lisp @@ -109,10 +109,10 @@ new)) (defun fgen-test (fgen) (svref fgen 0)) -(defun fgen-gensyms (fgen) (svref fgen 1)) -(defun fgen-generator (fgen) (svref fgen 2)) +(defun fgen-gensyms (fgen) (svref fgen 1)) +(defun fgen-generator (fgen) (svref fgen 2)) (defun fgen-generator-lambda (fgen) (svref fgen 3)) -(defun fgen-system (fgen) (svref fgen 4)) +(defun fgen-system (fgen) (svref fgen 4)) (defun get-function-generator (lambda test-converter code-converter) (let* ((test (compute-test lambda test-converter)) diff --git a/tests/assertoid.lisp b/tests/assertoid.lisp new file mode 100644 index 0000000..d115d9e --- /dev/null +++ b/tests/assertoid.lisp @@ -0,0 +1,93 @@ +;;;; the ASSERTOID macro, asserting something with added generality +;;;; to help in regression tests + +(cl:in-package :cl-user) + +;;; EXPR is an expression to evaluate (both with EVAL and with +;;; COMPILE/FUNCALL). EXTRA-OPTIMIZATIONS is a list of lists of +;;; optimizations to pass to (DECLARE (OPTIMIZE ..)), to cause the +;;; expression to be tested in other than the default optimization +;;; level(s). +;;; +;;; The messiness with the various flavors of EXPECTED stuff is +;;; to handle various issues: +;;; * Some things are expected to signal errors instead of returning +;;; ordinary values. +;;; * Some things are expected to return multiple values. +;;; * Some things can return any of several values (e.g. generalized +;;; booleans). +;;; The default is to expect a generalized boolean true. +;;; +;;; Use EXPECTED-LAMBDA to require an answer which satisfies the given +;;; LAMBDA. EXPECTED-EQL, EXPECTED-EQUAL, and EXPECTED-EQUALP are +;;; shorthand for special cases of EXPECTED-LAMBDA. +;;; +;;; Use EXPECTED-ERROR to require an error to be thrown. Use +;;; EXPECTED-ERROR-LAMBDA to require that an error be thrown and +;;; that further it satisfies the given lambda. +(defmacro assertoid (expr + &key + extra-optimizations + (expected-eql nil expected-eql-p) + (expected-equal nil expected-equal-p) + (expected-equalp nil expected-equalp-p) + (expected-lambda (cond + (expected-eql-p + (lambda (x) + (eql x (eval expected-eql)))) + (expected-equal-p + (lambda (x) + (equal x (eval expected-equal)))) + (expected-equalp-p + (lambda (x) + (equalp x (eval expected-equalp)))) + (t + (lambda (x) + x))) + expected-lambda-p) + (expected-error-type nil expected-error-type-p) + (expected-error-lambda (if expected-error-type + (lambda (condition) + (typep condition + expected-error-type)) + nil) + expected-error-lambda-p)) + (when (> (count-if #'identity + (vector expected-eql-p + expected-equal-p + expected-equalp-p + expected-lambda-p + expected-error-type-p + expected-error-lambda-p)) + 1) + (error "multiple EXPECTED-FOO arguments")) + (when expected-error-lambda + (error "stub: expected-error functionality not supported yet")) + (let ((eval-expected-lambda (eval expected-lambda))) + (flet ((frob (evaloid) + (let ((result (funcall evaloid expr))) + (unless (funcall eval-expected-lambda result) + (error "failed assertoid" expr)))) + (compile-as-evaloid (optimizations) + (lambda (expr) + (funcall (compile nil + `(lambda () + (declare (optimize ,@optimizations)) + ,expr)))))) + (frob #'eval) + (frob (compile-as-evaloid ())) + (dolist (i extra-optimizations) + (frob (compile-as-evaloid i)))))) + +;;; examples +(assertoid (= 2 (length (list 1 2)))) +(assertoid (= 2 (length (list 1 2))) + :extra-optimizations (((speed 2) (space 3)) + ((speed 1) (space 3)))) +(assertoid (cons 1 2) + :expected-lambda (lambda (x) (equal x '(1 . 2)))) +(assertoid (cons (list 1 2) (list 1 2)) + :expected-equal '((1 2) 1 2)) +;;; not implemented yet: +#+nil (assertoid (length (eval (find-package :cl))) + :expected-error-type 'type-error) diff --git a/tests/map-tests.impure.lisp b/tests/map-tests.impure.lisp new file mode 100644 index 0000000..76ee566 --- /dev/null +++ b/tests/map-tests.impure.lisp @@ -0,0 +1,103 @@ +(cl:in-package :cl-user) + +(load "assertoid.lisp") + +;;; tests of MAP +;;; FIXME: Move these into their own file. +(assertoid (map 'vector #'+ '(1 2 3) '(30 20)) + :expected-equalp #(31 22)) +(assertoid (map 'list #'+ #(1 2) '(100) #(0) #(100 100)) + :expected-equal '(201)) + +(defmacro with-mapnil-test-fun (fun-name &body body) + `(let ((reversed-result nil)) + (flet ((,fun-name (&rest rest) + (push rest reversed-result))) + ,@body + (nreverse reversed-result)))) +(assertoid (with-mapnil-test-fun fun + (map nil #'fun #(1))) + :expected-equal '((1))) +(assertoid (with-mapnil-test-fun fun + (map nil #'fun #() '(1 2 3))) + :expected-equal '()) +(assertoid (with-mapnil-test-fun fun + (map nil #'fun #(a b c) '(alpha beta) '(aleph beth))) + :expected-equal '((a alpha aleph) (b beta beth))) + +;;; Exercise MAP repeatedly on the same dataset by providing various +;;; combinations of sequence type arguments, declarations, and so +;;; forth. +(defvar *list-1* '(1)) +(defvar *list-2* '(1 2)) +(defvar *list-3* '(1 2 3)) +(defvar *list-4* '(1 2 3 4)) +(defvar *vector-10* #(10)) +(defvar *vector-20* #(10 20)) +(defvar *vector-30* #(10 20 30)) +(defmacro maptest (&key + result-seq + fun-name + arg-seqs + arg-types + (result-element-types '(t))) + (let ((reversed-assertoids nil)) + (dotimes (arg-type-index (expt 2 (length arg-types))) + (labels (;; Arrange for EXPR to be executed. + (arrange (expr) + (push expr reversed-assertoids)) + ;; We toggle the various type declarations on and + ;; off depending on the bit pattern in ARG-TYPE-INDEX, + ;; so that we get lots of different things to test. + (eff-arg-type (i) + (if (and (< i (length arg-types)) + (plusp (logand (expt 2 i) + arg-type-index))) + (nth i arg-types) + t)) + (args-with-type-decls () + (let ((reversed-result nil)) + (dotimes (i (length arg-seqs) (nreverse reversed-result)) + (push `(the ,(eff-arg-type i) + ,(nth i arg-seqs)) + reversed-result))))) + (dolist (fun `(',fun-name #',fun-name)) + (dolist (result-type (cons 'list + (mapcan (lambda (et) + `((vector ,et) + (simple-array ,et 1))) + result-element-types))) + (arrange + `(assertoid (map ',result-type ,fun ,@(args-with-type-decls)) + :expected-equalp (coerce ,result-seq + ',result-type))))) + (arrange + `(assertoid (mapcar (lambda (args) (apply #',fun-name args)) + (with-mapnil-test-fun mtf + (map nil + ;; (It would be nice to test MAP + ;; NIL with function names, too, + ;; but I can't see any concise way + ;; to do it..) + #'mtf + ,@(args-with-type-decls)))) + :expected-equal (coerce ,result-seq 'list))))) + `(progn ,@(nreverse reversed-assertoids)))) +(maptest :result-seq '(2 3) + :fun-name 1+ + :arg-seqs (*list-2*) + :arg-types (list)) +(maptest :result-seq '(nil nil nil) + :fun-name oddp + :arg-seqs (*vector-30*) + :arg-types (vector)) +(maptest :result-seq '(12 24) + :fun-name + + :arg-seqs (*list-2* *list-2* *vector-30*) + :arg-types (list list vector)) + +(print "returning successfully") +(terpri) +;;(sb-impl::flush-standard-output-streams) +;;(finish-output) +(quit :unix-status 104) diff --git a/tests/run-tests.sh b/tests/run-tests.sh index 366eba1..7c7da12 100644 --- a/tests/run-tests.sh +++ b/tests/run-tests.sh @@ -5,15 +5,26 @@ # how we invoke SBCL sbcl=${1:-sbcl --noprint --noprogrammer} +# "Ten four" is the closest numerical slang I can find to "OK", so +# it's the return value we expect from a successful test. +tenfour () { + if [ $? = 104 ]; then + echo ok + else + echo test failed: $? + return 1 + fi +} + # *.pure.lisp files are ordinary Lisp code with no side effects, # and we can run them all in a single Lisp process. -(for f in *.pure.lisp; do echo \"$f\"; done) | $sbcl < pure.lisp +(for f in *.pure.lisp; do echo \"$f\"; done) | $sbcl ; tenfour # *.impure.lisp files are Lisp code with side effects (e.g. doing DEFSTRUCT # or DEFTYPE or DEFVAR). Each one needs to be run as a separate # invocation of Lisp. for f in *.impure.lisp; do - echo $f | $sbcl < pure.lisp + echo $f | $sbcl ; tenfour done # *.test.sh files are scripts to test stuff, typically stuff which can't @@ -21,11 +32,11 @@ done # may be associated with other files foo*, e.g. foo.lisp, foo-1.lisp, # or foo.pl. for f in *.test.sh; do - sh $f || exit failed test $f + sh $f ; tenfour done # *.assertoids files contain ASSERTOID statements to test things # interpreted and at various compilation levels. for f in *.assertoids; do - echo "(load \"$f\")" | $sbcl --eval '(load "assertoid.lisp")' + echo "(load \"$f\")" | $sbcl --eval '(load "assertoid.lisp")' ; tenfour done