"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"
"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"
;; 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*"
(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))))
(setf (%raw-bits result-bit-array index)
(32bit-logical-not (%raw-bits bit-array index))))))
\f
-;;;; 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
;;; 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))
\f
;;;; transforms for EQL of floating point values
(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
;;; 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)))))
\f
;;;; QUOTE and FUNCTION
;;; 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
;;; 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"
projects / sbcl.git / commitdiff