From 23f1e2ef66bcc31ca7ea765a82a97998119aa4d5 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Sat, 29 Dec 2001 17:39:51 +0000 Subject: [PATCH] 0.pre7.106: merged NJF dolist-to-macrolet patch (sbcl-devel 2001-12-29) investigated why I can't resize SIMPLE-FUN, and scribbled various notes about what I found --- TODO | 1 + src/compiler/generic/genesis.lisp | 3 +- src/compiler/generic/objdef.lisp | 22 ++++ src/compiler/seqtran.lisp | 216 +++++++++++++++++++------------------ src/runtime/gc.c | 4 +- src/runtime/gencgc.c | 17 ++- version.lisp-expr | 2 +- 7 files changed, 145 insertions(+), 120 deletions(-) diff --git a/TODO b/TODO index f45f268..c15d321 100644 --- a/TODO +++ b/TODO @@ -13,6 +13,7 @@ for 0.7.0: ** finished s/FUNCTION/FUN/ ** s/VARIABLE/VAR/ ** s/TOP-LEVEL/TOPLEVEL/ + ** perhaps s/DEF-FROB/DEF/ or s/DEF-FROB/DEFINE/ * global style systematization: ** s/#'(lambda/(lambda/ * pending patches and bug reports that go in (or else get handled diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 2f7d6a7..0c575dc 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -1403,7 +1403,8 @@ sb!vm:word-shift)))) (#.sb!vm:closure-header-widetag (make-random-descriptor - (cold-foreign-symbol-address-as-integer "closure_tramp"))))) + (cold-foreign-symbol-address-as-integer + "closure_tramp"))))) fdefn)) (defun initialize-static-fns () diff --git a/src/compiler/generic/objdef.lisp b/src/compiler/generic/objdef.lisp index 5156cad..50b7a53 100644 --- a/src/compiler/generic/objdef.lisp +++ b/src/compiler/generic/objdef.lisp @@ -10,6 +10,28 @@ ;;;; files for more information. (in-package "SB!VM") + +;;;; KLUDGE: The primitive objects here may look like self-contained +;;;; definitions, but in general they're not. In particular, if you +;;;; try to add a slot to them, beware of the following: +;;;; * (mysterious crashes which occur after changing the length +;;;; of SIMPLE-FUN, just adding a new slot not even doing anything +;;;; with it, still dunno why) +;;;; * The GC scavenging code (and for all I know other GC code too) +;;;; is not automatically generated from these layouts, but instead +;;;; was hand-written to correspond to them. The offsets are +;;;; automatically propagated into the GC scavenging code, but the +;;;; existence of slots, and whether they should be scavenged, is +;;;; not automatically propagated. Thus e.g. if you add a +;;;; SIMPLE-FUN-DEBUG-INFO slot holding a tagged object which needs +;;;; to be GCed, you need to tweak scav_code_header() and +;;;; verify_space() in gencgc.c, and the corresponding code in gc.c. +;;;; * Various code (e.g. STATIC-FSET in genesis.lisp) is hard-wired +;;;; to know the name of the last slot of the object the code works +;;;; with, and implicitly to know that the last slot is special (being +;;;; the beginning of an arbitrary-length sequence of bytes following +;;;; the fixed-layout slots). +;;;; -- WHN 2001-12-29 ;;;; the primitive objects themselves diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 81c943f..91713e5 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -227,62 +227,62 @@ (deftransform %setelt ((s i v) (list * *)) '(setf (car (nthcdr i s)) v)) -;;; FIXME: I still think (DOLIST (..) (DEFTRANSFORM ..)) is weird. -;;; For that matter, it would be nice to use DEF-FROB for these -;;; sorts of things, so folks looking for the definitions of -;;; FOO can search for '\(def.*\' and have a chance in hell.. -(dolist (name '(member memq)) - (deftransform name ((e l &key (test #'eql)) '* '* :node node :when :both - :eval-name t) - (unless (constant-continuation-p l) - (give-up-ir1-transform)) - - (let ((val (continuation-value l))) - (unless (policy node - (or (= speed 3) - (and (>= speed space) - (<= (length val) 5)))) - (give-up-ir1-transform)) - - (labels ((frob (els) - (if els - `(if (funcall test e ',(car els)) - ',els - ,(frob (cdr els))) - nil))) - (frob val))))) - -;;; FIXME: Rewrite this so that these definitions of DELETE, ASSOC, and MEMBER -;;; are lexically findable: -;;; (MACROLET ((DEF-FROB (X Y) ..)) -;;; (DEF-FROB DELETE DELQ) -;;; (DEF-FROB ASSOC ASSQ) -;;; (DEF-FROB MEMBER MEMQ)) -;;; And while I'm at it, I could save a few byte by implementing the -;;; transform body as call to a shared function instead of duplicated -;;; macroexpanded code. -(dolist (x '((delete delq) - (assoc assq) - (member memq))) - (destructuring-bind (fun eq-fun) x - (deftransform fun ((item list &key test) '(t list &rest t) '* - :eval-name t) - "convert to EQ test" - ;; FIXME: The scope of this transformation could be widened somewhat, - ;; letting it work whenever the test is 'EQL and we know from the - ;; type of ITEM that it #'EQ works like #'EQL on it. (E.g. types - ;; FIXNUM, CHARACTER, and SYMBOL.) - ;; If TEST is EQ, apply transform, else - ;; if test is not EQL, then give up on transform, else - ;; if ITEM is not a NUMBER or is a FIXNUM, apply transform, else - ;; give up on transform. - (cond (test - (unless (continuation-function-is test '(eq)) - (give-up-ir1-transform))) - ((types-equal-or-intersect (continuation-type item) - (specifier-type 'number)) - (give-up-ir1-transform "Item might be a number."))) - `(,eq-fun item list)))) +;;; FIXME: The MACROLET ... DEF-FROB ... DEFTRANSFORM idioms in this +;;; file are literal translations of old CMU CL DOLIST ... DEFTRANSFORM, +;;; and so use :EVAL-NAME for historical reasons. It'd be tidier to +;;; just let macroexpansion substitution take care of everything, +;;; and remove both :EVAL-NAME and the extra layer of quotes. + +(macrolet ((def-frob (name) + `(deftransform ',name ((e l &key (test #'eql)) '* '* :node node :when :both + :eval-name t) + (unless (constant-continuation-p l) + (give-up-ir1-transform)) + + (let ((val (continuation-value l))) + (unless (policy node + (or (= speed 3) + (and (>= speed space) + (<= (length val) 5)))) + (give-up-ir1-transform)) + + (labels ((frob (els) + (if els + `(if (funcall test e ',(car els)) + ',els + ,(frob (cdr els))) + nil))) + (frob val)))))) + (def-frob member) + (def-frob memq)) + +;;; FIXME: We have rewritten the original code that used DOLIST to this +;;; more natural MACROLET. However, the original code suggested that when +;;; this was done, a few bytes could be saved by a call to a shared +;;; function. This remains to be done. +(macrolet ((def-frob (fun eq-fun) + `(deftransform ',fun ((item list &key test) '(t list &rest t) '* + :eval-name t) + "convert to EQ test" + ;; FIXME: The scope of this transformation could be + ;; widened somewhat, letting it work whenever the test is + ;; 'EQL and we know from the type of ITEM that it #'EQ + ;; works like #'EQL on it. (E.g. types FIXNUM, CHARACTER, + ;; and SYMBOL.) + ;; If TEST is EQ, apply transform, else + ;; if test is not EQL, then give up on transform, else + ;; if ITEM is not a NUMBER or is a FIXNUM, apply + ;; transform, else give up on transform. + (cond (test + (unless (continuation-function-is test '(eq)) + (give-up-ir1-transform))) + ((types-equal-or-intersect (continuation-type item) + (specifier-type 'number)) + (give-up-ir1-transform "Item might be a number."))) + `(,',eq-fun item list)))) + (def-frob delete delq) + (def-frob assoc assq) + (def-frob member memq)) (deftransform delete-if ((pred list) (t list)) "open code" @@ -542,57 +542,59 @@ ;;; We transform the case-sensitive string predicates into a non-keyword ;;; version. This is an IR1 transform so that we don't have to worry about ;;; changing the order of evaluation. -(dolist (stuff '((string< string<*) - (string> string>*) - (string<= string<=*) - (string>= string>=*) - (string= string=*) - (string/= string/=*))) - (destructuring-bind (fun pred*) stuff - (deftransform fun ((string1 string2 &key (start1 0) end1 - (start2 0) end2) - '* '* :eval-name t) - `(,pred* string1 string2 start1 end1 start2 end2)))) - -;;; Return a form that tests the free variables STRING1 and STRING2 for the -;;; ordering relationship specified by Lessp and Equalp. The start and end are -;;; also gotten from the environment. Both strings must be simple strings. -(dolist (stuff '((string<* t nil) - (string<=* t t) - (string>* nil nil) - (string>=* nil t))) - (destructuring-bind (name lessp equalp) stuff - (deftransform name ((string1 string2 start1 end1 start2 end2) - '(simple-string simple-string t t t t) '* - :eval-name t) - `(let* ((end1 (if (not end1) (length string1) end1)) - (end2 (if (not end2) (length string2) end2)) - (index (sb!impl::%sp-string-compare - string1 start1 end1 string2 start2 end2))) - (if index - (cond ((= index ,(if lessp 'end1 'end2)) index) - ((= index ,(if lessp 'end2 'end1)) nil) - ((,(if lessp 'char< 'char>) - (schar string1 index) - (schar string2 - (truly-the index - (+ index - (truly-the fixnum - (- start2 start1)))))) - index) - (t nil)) - ,(if equalp 'end1 nil)))))) - -(dolist (stuff '((string=* not) - (string/=* identity))) - (destructuring-bind (name result-fun) stuff - (deftransform name ((string1 string2 start1 end1 start2 end2) - '(simple-string simple-string t t t t) '* - :eval-name t) - `(,result-fun - (sb!impl::%sp-string-compare - string1 start1 (or end1 (length string1)) - string2 start2 (or end2 (length string2))))))) +(macrolet ((def-frob (fun pred*) + `(deftransform ',fun ((string1 string2 &key (start1 0) end1 + (start2 0) end2) + '* '* :eval-name t) + `(,',pred* string1 string2 start1 end1 start2 end2)))) + (def-frob string< string<*) + (def-frob string> string>*) + (def-frob string<= string<=*) + (def-frob string>= string>=*) + (def-frob string= string=*) + (def-frob string/= string/=*)) + +;;; Return a form that tests the free variables STRING1 and STRING2 +;;; for the ordering relationship specified by LESSP and EQUALP. The +;;; start and end are also gotten from the environment. Both strings +;;; must be SIMPLE-STRINGs. +(macrolet ((def-frob (name lessp equalp) + `(deftransform ',name ((string1 string2 start1 end1 start2 end2) + '(simple-string simple-string t t t t) '* + :eval-name t) + `(let* ((end1 (if (not end1) (length string1) end1)) + (end2 (if (not end2) (length string2) end2)) + (index (sb!impl::%sp-string-compare + string1 start1 end1 string2 start2 end2))) + (if index + (cond ((= index ,(if ',lessp 'end1 'end2)) index) + ((= index ,(if ',lessp 'end2 'end1)) nil) + ((,(if ',lessp 'char< 'char>) + (schar string1 index) + (schar string2 + (truly-the index + (+ index + (truly-the fixnum + (- start2 start1)))))) + index) + (t nil)) + ,(if ',equalp 'end1 nil)))))) + (def-frob string<* t nil) + (def-frob string<=* t t) + (def-frob string>* nil nil) + (def-frob string>=* nil t)) + +(macrolet ((def-frob (name result-fun) + `(deftransform ',name ((string1 string2 start1 end1 start2 end2) + '(simple-string simple-string t t t t) '* + :eval-name t) + `(,',result-fun + (sb!impl::%sp-string-compare + string1 start1 (or end1 (length string1)) + string2 start2 (or end2 (length string2))))))) + (def-frob string=* not) + (def-frob string/=* identity)) + ;;;; string-only transforms for sequence functions ;;;; diff --git a/src/runtime/gc.c b/src/runtime/gc.c index 47ed1b4..1be6a63 100644 --- a/src/runtime/gc.c +++ b/src/runtime/gc.c @@ -724,8 +724,8 @@ trans_code(struct code *code) fheaderp = (struct simple_fun *) native_pointer(fheaderl); gc_assert(widetag_of(fheaderp->header) == SIMPLE_FUN_HEADER_WIDETAG); - /* calcuate the new function pointer and the new */ - /* function header */ + /* Calculate the new function pointer and the new */ + /* function header. */ nfheaderl = fheaderl + displacement; nfheaderp = (struct simple_fun *) native_pointer(nfheaderl); diff --git a/src/runtime/gencgc.c b/src/runtime/gencgc.c index b8d18d7..a90c60d 100644 --- a/src/runtime/gencgc.c +++ b/src/runtime/gencgc.c @@ -2174,8 +2174,8 @@ trans_code(struct code *code) fheaderp = (struct simple_fun *) native_pointer(fheaderl); gc_assert(widetag_of(fheaderp->header) == SIMPLE_FUN_HEADER_WIDETAG); - /* Calculate the new function pointer and the new */ - /* function header. */ + /* Calculate the new function pointer and the new + * function header. */ nfheaderl = fheaderl + displacement; nfheaderp = (struct simple_fun *) native_pointer(nfheaderl); @@ -2192,8 +2192,7 @@ trans_code(struct code *code) prev_pointer = &nfheaderp->next; } - /* sniff_code_object(new_code,displacement);*/ - apply_code_fixups(code,new_code); + apply_code_fixups(code, new_code); return new_code; } @@ -2215,8 +2214,8 @@ scav_code_header(lispobj *where, lispobj object) /* Scavenge the boxed section of the code data block. */ scavenge(where + 1, n_header_words - 1); - /* Scavenge the boxed section of each function object in the */ - /* code data block. */ + /* Scavenge the boxed section of each function object in the + * code data block. */ for (entry_point = code->entry_points; entry_point != NIL; entry_point = function_ptr->next) { @@ -2224,7 +2223,7 @@ scav_code_header(lispobj *where, lispobj object) gc_assert(is_lisp_pointer(entry_point)); function_ptr = (struct simple_fun *) native_pointer(entry_point); - gc_assert(widetag_of(function_ptr->header) == SIMPLE_FUN_HEADER_WIDETAG); + gc_assert(widetag_of(function_ptr->header)==SIMPLE_FUN_HEADER_WIDETAG); scavenge(&function_ptr->name, 1); scavenge(&function_ptr->arglist, 1); @@ -5150,8 +5149,8 @@ verify_space(lispobj *start, size_t words) /* Scavenge the boxed section of the code data block */ verify_space(start + 1, nheader_words - 1); - /* Scavenge the boxed section of each function object in - * the code data block. */ + /* Scavenge the boxed section of each function + * object in the code data block. */ fheaderl = code->entry_points; while (fheaderl != NIL) { fheaderp = diff --git a/version.lisp-expr b/version.lisp-expr index d790b5c..ee94201 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; for internal versions, especially for internal versions off the ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.pre7.104" +"0.pre7.106" -- 1.7.10.4