From 2695f20cc74e0693f184fa5c7327d4c557e5537f Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Tue, 12 Jun 2001 02:12:50 +0000 Subject: [PATCH] 0.6.12.31: finished getting rid of %PRIMITIVE SB!C:BYTE-BLT in favor of SB!KERNEL:%BYTE-BLT Now there are no primitive translators, so everything "grep -i primitive.translator" can go away. deleted not-much-use stuff related to %SP-STRING-SEARCH, %SP-FIND-CHARACTER, and %SP-REVERSE-FIND-CHARACTER deleted unused %SP-SKIP-CHARACTER, %SP-REVERSE-SKIP-CHARACTER, and MAYBE-SAP-MAYBE-STRING --- package-data-list.lisp-expr | 5 +- src/code/mipsstrops.lisp | 89 ---------------------------------- src/compiler/generic/vm-tran.lisp | 62 ++++++++++++------------ src/compiler/ir1tran.lisp | 95 +++++++++++++++++-------------------- src/compiler/seqtran.lisp | 21 -------- version.lisp-expr | 2 +- 6 files changed, 76 insertions(+), 198 deletions(-) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 1ea1a16..a778220 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -172,7 +172,6 @@ "ANY" "ARGUMENT-COUNT-ERROR" "ASSEMBLE-FILE" "ATTRIBUTES" "ATTRIBUTES-INTERSECTION" "ATTRIBUTES-UNION" "ATTRIBUTES=" "BIND" - "BYTE-BLT" "CALL" "CALL-LOCAL" "CALL-NAMED" "CALL-OUT" "CALL-VARIABLE" "CALLEE-NFP-TN" "CALLEE-RETURN-PC-TN" "CASE-BODY" "CATCH-BLOCK" "CHECK-CONS" @@ -187,7 +186,7 @@ "CURRENT-BINDING-POINTER" "CURRENT-NFP-TN" "CURRENT-STACK-POINTER" "DEALLOC-ALIEN-STACK-SPACE" "DEALLOC-NUMBER-STACK-SPACE" "DEF-BOOLEAN-ATTRIBUTE" - "DEF-IR1-TRANSLATOR" "DEF-PRIMITIVE-TRANSLATOR" + "DEF-IR1-TRANSLATOR" "!DEF-PRIMITIVE-TYPE" "!DEF-PRIMITIVE-TYPE-ALIAS" "DEF-SOURCE-TRANSFORM" "!DEF-VM-SUPPORT-ROUTINE" "DEFINE-ASSEMBLY-ROUTINE" "DEFINE-MOVE-FUNCTION" @@ -1444,7 +1443,7 @@ and even SB-VM seem to have become somewhat blurred over the years." ;; FIXME: %PRIMITIVE shouldn't be here. (I now know that %SYS ;; is for OS-dependent stuff. %PRIMITIVE should probably be in ;; SB!KERNEL.) - "%PRIMITIVE" "%SP-FIND-CHARACTER" + "%PRIMITIVE" "%STANDARD-CHAR-P" "*LONG-SITE-NAME*" "*SHORT-SITE-NAME*" "*STDERR*" "*STDIN*" diff --git a/src/code/mipsstrops.lisp b/src/code/mipsstrops.lisp index 5acc918..6f98979 100644 --- a/src/code/mipsstrops.lisp +++ b/src/code/mipsstrops.lisp @@ -77,92 +77,3 @@ (declare (fixnum index1 index2)) (if (char/= (schar string1 index1) (schar string2 index2)) (return index1))))))) - -(defmacro maybe-sap-maybe-string ((var) &body body) - `(etypecase ,var - (system-area-pointer - (macrolet ((byte-ref (index) - `(sap-ref-8 ,',var ,index)) - (char-ref (index) - `(code-char (byte-ref ,index)))) - ,@body)) - (simple-string - (macrolet ((char-ref (index) - `(schar ,',var ,index)) - (byte-ref (index) - `(char-code (char-ref ,index)))) - ,@body)))) - -;;; Search STRING for the CHARACTER from START to END. If the -;;; character is found, the corresponding index into STRING is -;;; returned, otherwise NIL is returned. -(defun %sp-find-character (string start end character) - (declare (fixnum start end) - (type (or simple-string system-area-pointer) string) - (base-char character)) - (maybe-sap-maybe-string (string) - (do ((index start (1+ index))) - ((>= index end) nil) - (declare (fixnum index)) - (when (char= (char-ref index) character) - (return index))))) - -;;; Search STRING for CHARACTER from END to START. If the character is -;;; found, the corresponding index into STRING is returned, otherwise -;;; NIL is returned. -(defun %sp-reverse-find-character (string start end character) - (declare (type (or simple-string system-area-pointer) string) - (fixnum start end) - (base-char character)) - (maybe-sap-maybe-string (string) - (do ((index (1- end) (1- index)) - (terminus (1- start))) - ((= index terminus) nil) - (declare (fixnum terminus index)) - (if (char= (char-ref index) character) - (return index))))) - -;;; Return the index of the first character between START and END -;;; which is not CHAR= to CHARACTER, or NIL if there is no such -;;; character. -(defun %sp-skip-character (string start end character) - (declare (type (or simple-string system-area-pointer) string) - (fixnum start end) - (base-char character)) - (maybe-sap-maybe-string (string) - (do ((index start (1+ index))) - ((= index end) nil) - (declare (fixnum index)) - (if (char/= (char-ref index) character) - (return index))))) - -;;; Return the index of the last character between START and END which -;;; is not CHAR= to CHARACTER, or NIL if there is no such character. -(defun %sp-reverse-skip-character (string start end character) - (declare (type (or simple-string system-area-pointer) string) - (fixnum start end) - (base-char character)) - (maybe-sap-maybe-string (string) - (do ((index (1- end) (1- index)) - (terminus (1- start))) - ((= index terminus) nil) - (declare (fixnum terminus index)) - (if (char/= (char-ref index) character) - (return index))))) - -;;; Search for the substring of STRING1 specified in STRING2. Return -;;; an index into STRING2, or NIL if the substring wasn't found. -(defun %sp-string-search (string1 start1 end1 string2 start2 end2) - (declare (simple-string string1 string2)) - (do ((index2 start2 (1+ index2))) - ((= index2 end2) nil) - (declare (fixnum index2)) - (when (do ((index1 start1 (1+ index1)) - (index2 index2 (1+ index2))) - ((= index1 end1) t) - (declare (fixnum index1 index2)) - (when (= index2 end2) - (return-from %sp-string-search nil)) - (when (char/= (char string1 index1) (char string2 index2)) - (return nil))) - (return index2)))) diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp index 2156e05..0d5849e 100644 --- a/src/compiler/generic/vm-tran.lisp +++ b/src/compiler/generic/vm-tran.lisp @@ -244,36 +244,7 @@ (setf (%raw-bits result-bit-array index) (32bit-logical-not (%raw-bits bit-array index)))))) -;;;; BYTE-BLT - -(def-primitive-translator byte-blt (src src-start dst dst-start dst-end) - - ;; new version - ;; - ;; FIXME: CMU CL had a hairier implementation of this. It had the - ;; small problem that it didn't work for large (>16M) values of - ;; SRC-START or DST-START. However, it might have been more - ;; efficient. In particular, I don't really know how much the - ;; foreign function call costs us here. My guess is that if the - ;; overhead is acceptable for SQRT and COS, it's acceptable here, - ;; but this should probably be checked. -- WHN - (once-only ((src-start src-start) - (dst-start dst-start)) - `(flet ((->sap (thing) - (etypecase thing - (system-area-pointer thing) - ;; FIXME: The code here rather relies on the simple - ;; unboxed array here having byte-sized entries. That - ;; should be asserted explicitly, I just haven't found - ;; a concise way of doing it. (It would be nice to - ;; declare it in the DEFKNOWN too.) - ((simple-unboxed-array (*)) (vector-sap thing))))) - (declare (inline ->sap)) - (without-gcing - (memmove (sap+ (->sap ,dst) ,dst-start) - (sap+ (->sap ,src) ,src-start) - (- ,dst-end ,dst-start))) - nil))) +;;;; %BYTE-BLT ;;; FIXME: The old CMU CL code used various COPY-TO/FROM-SYSTEM-AREA ;;; stuff (with all the associated bit-index cruft and overflow @@ -282,8 +253,35 @@ ;;; currently (ca. sbcl-0.6.12.30) the main interface for code in ;;; SB!KERNEL and SB!SYS (e.g. i/o code). It's not clear that it's the ;;; ideal interface, though, and it probably deserves some thought. -(deftransform %byte-blt ((a1 a2 a3 a4 a5) (t t t t t)) - '(%primitive byte-blt a1 a2 a3 a4 a5)) +(deftransform %byte-blt ((src src-start dst dst-start dst-end) + ((or (simple-unboxed-array (*)) system-area-pointer) + index + (or (simple-unboxed-array (*)) system-area-pointer) + index + index)) + ;; FIXME: CMU CL had a hairier implementation of this (back when it + ;; was still called (%PRIMITIVE BYTE-BLT). It had the small problem + ;; that it didn't work for large (>16M) values of SRC-START or + ;; DST-START. However, it might have been more efficient. In + ;; particular, I don't really know how much the foreign function + ;; call costs us here. My guess is that if the overhead is + ;; acceptable for SQRT and COS, it's acceptable here, but this + ;; should probably be checked. -- WHN + '(flet ((sapify (thing) + (etypecase thing + (system-area-pointer thing) + ;; FIXME: The code here rather relies on the simple + ;; unboxed array here having byte-sized entries. That + ;; should be asserted explicitly, I just haven't found + ;; a concise way of doing it. (It would be nice to + ;; declare it in the DEFKNOWN too.) + ((simple-unboxed-array (*)) (vector-sap thing))))) + (declare (inline sapify)) + (without-gcing + (memmove (sap+ (sapify dst) dst-start) + (sap+ (sapify src) src-start) + (- dst-end dst-start))) + nil)) ;;;; transforms for EQL of floating point values diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 6b36ad1..cdf1a25 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -2174,9 +2174,6 @@ (compiler-error "Lisp error during evaluation of info args:~%~A" condition)))) -;;; a hashtable that translates from primitive names to translation functions -(defvar *primitive-translators* (make-hash-table :test 'eq)) - ;;; If there is a primitive translator, then we expand the call. ;;; Otherwise, we convert to the %%PRIMITIVE funny function. The first ;;; argument is the template, the second is a list of the results of @@ -2187,60 +2184,54 @@ ;;; a fatal error during IR2 conversion. ;;; ;;; KLUDGE: It's confusing having multiple names floating around for -;;; nearly the same concept: PRIMITIVE, TEMPLATE, VOP. Might it be -;;; possible to reimplement BYTE-BLT (the only use of -;;; *PRIMITIVE-TRANSLATORS*) some other way, then get rid of primitive -;;; translators altogether, so that there would be no distinction -;;; between primitives and vops? Then we could call primitives vops, -;;; rename TEMPLATE to VOP-TEMPLATE, rename BACKEND-TEMPLATE-NAMES to -;;; BACKEND-VOPS, and rename %PRIMITIVE to VOP.. -- WHN 19990906 -;;; FIXME: Look at doing this ^, it doesn't look too hard actually. I -;;; think BYTE-BLT could probably just become an inline function. +;;; nearly the same concept: PRIMITIVE, TEMPLATE, VOP. Now that CMU +;;; CL's *PRIMITIVE-TRANSLATORS* stuff is gone, we could call +;;; primitives VOPs, rename TEMPLATE to VOP-TEMPLATE, rename +;;; BACKEND-TEMPLATE-NAMES to BACKEND-VOPS, and rename %PRIMITIVE to +;;; VOP or %VOP.. -- WHN 2001-06-11 +;;; FIXME: Look at doing this ^, it doesn't look too hard actually. (def-ir1-translator %primitive ((&whole form name &rest args) start cont) (unless (symbolp name) (compiler-error "The primitive name ~S is not a symbol." name)) - (let* ((translator (gethash name *primitive-translators*))) - (if translator - (ir1-convert start cont (funcall translator (cdr form))) - (let* ((template (or (gethash name *backend-template-names*) - (compiler-error - "The primitive name ~A is not defined." - name))) - (required (length (template-arg-types template))) - (info (template-info-arg-count template)) - (min (+ required info)) - (nargs (length args))) - (if (template-more-args-type template) - (when (< nargs min) - (compiler-error "Primitive ~A was called with ~R argument~:P, ~ - but wants at least ~R." - name - nargs - min)) - (unless (= nargs min) - (compiler-error "Primitive ~A was called with ~R argument~:P, ~ - but wants exactly ~R." - name - nargs - min))) - - (when (eq (template-result-types template) :conditional) - (compiler-error - "%PRIMITIVE was used with a conditional template.")) - - (when (template-more-results-type template) - (compiler-error - "%PRIMITIVE was used with an unknown values template.")) - - (ir1-convert start - cont - `(%%primitive ',template - ',(eval-info-args - (subseq args required min)) - ,@(subseq args 0 required) - ,@(subseq args min))))))) + (let* ((template (or (gethash name *backend-template-names*) + (compiler-error + "The primitive name ~A is not defined." + name))) + (required (length (template-arg-types template))) + (info (template-info-arg-count template)) + (min (+ required info)) + (nargs (length args))) + (if (template-more-args-type template) + (when (< nargs min) + (compiler-error "Primitive ~A was called with ~R argument~:P, ~ + but wants at least ~R." + name + nargs + min)) + (unless (= nargs min) + (compiler-error "Primitive ~A was called with ~R argument~:P, ~ + but wants exactly ~R." + name + nargs + min))) + + (when (eq (template-result-types template) :conditional) + (compiler-error + "%PRIMITIVE was used with a conditional template.")) + + (when (template-more-results-type template) + (compiler-error + "%PRIMITIVE was used with an unknown values template.")) + + (ir1-convert start + cont + `(%%primitive ',template + ',(eval-info-args + (subseq args required min)) + ,@(subseq args 0 required) + ,@(subseq args min))))) ;;;; QUOTE and FUNCTION diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index d72020d..05066fa 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -324,27 +324,6 @@ ;;; applied to characters (defparameter *char=-functions* '(eql equal char=)) -(deftransform search ((string1 string2 &key (start1 0) end1 (start2 0) end2 - test) - (simple-string simple-string &rest t)) - (unless (or (not test) - (continuation-function-is test *char=-functions*)) - (give-up-ir1-transform)) - '(sb!impl::%sp-string-search string1 start1 (or end1 (length string1)) - string2 start2 (or end2 (length string2)))) - -(deftransform position ((item sequence &key from-end test (start 0) end) - (t simple-string &rest t)) - (unless (or (not test) - (continuation-function-is test *char=-functions*)) - (give-up-ir1-transform)) - `(and (typep item 'character) - (,(if (constant-value-or-lose from-end) - 'sb!impl::%sp-reverse-find-character - 'sb!impl::%sp-find-character) - sequence start (or end (length sequence)) - item))) - (deftransform find ((item sequence &key from-end (test #'eql) (start 0) end) (t simple-string &rest t)) `(if (position item sequence diff --git a/version.lisp-expr b/version.lisp-expr index d78a06a..491714d 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -15,4 +15,4 @@ ;;; versions, and a string like "0.6.5.12" is used for versions which ;;; aren't released but correspond only to CVS tags or snapshots. -"0.6.12.30" +"0.6.12.31" -- 1.7.10.4