From: Nikodemus Siivola Date: Thu, 18 Dec 2008 20:39:38 +0000 (+0000) Subject: 1.0.23.53: FORMAT performance tweaking 2 X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=901f7fadc47486239d3eaa68745dae5832a74966;p=sbcl.git 1.0.23.53: FORMAT performance tweaking 2 * Rearrange FORMAT-FIXED and open code guts of FORMAT-FIXED-AUX for both single and double-float cases, gaining ~5% speedup for ~F. --- diff --git a/NEWS b/NEWS index 9683e65..0030620 100644 --- a/NEWS +++ b/NEWS @@ -4,7 +4,7 @@ * new feature: the system now signals a continuable error if standard readtable modification is attempted. * optimization: faster generic arithmetic dispatch on x86 and x86-64. - * optimization: unmodified FORMAT ~D is now approximately 5% faster. + * optimization: FORMAT ~D and ~F are now approximately 5% faster. * tradeoff: constant FORMAT control strings are now compiled unless SPACE > SPEED (previously only when SPEED > SPACE.) * bug fix: Red Hat Enterprise 3 mmap randomization workaround. (thanks diff --git a/src/code/target-format.lisp b/src/code/target-format.lisp index 67fc813..f119459 100644 --- a/src/code/target-format.lisp +++ b/src/code/target-format.lisp @@ -485,62 +485,69 @@ (format-fixed stream (next-arg) w d k ovf pad atsignp))) (defun format-fixed (stream number w d k ovf pad atsign) - (if (numberp number) - (if (floatp number) - (format-fixed-aux stream number w d k ovf pad atsign) - (if (rationalp number) - (format-fixed-aux stream - (coerce number 'single-float) - w d k ovf pad atsign) - (format-write-field stream - (decimal-string number) - w 1 0 #\space t))) - (format-princ stream number nil nil w 1 0 pad))) + (typecase number + (float + (format-fixed-aux stream number w d k ovf pad atsign)) + (rational + (format-fixed-aux stream (coerce number 'single-float) + w d k ovf pad atsign)) + (number + (format-write-field stream (decimal-string number) w 1 0 #\space t)) + (t + (format-princ stream number nil nil w 1 0 pad)))) ;;; We return true if we overflowed, so that ~G can output the overflow char ;;; instead of spaces. (defun format-fixed-aux (stream number w d k ovf pad atsign) (declare (type float number)) (cond - ((and (floatp number) - (or (float-infinity-p number) - (float-nan-p number))) - (prin1 number stream) - nil) - (t - (let ((spaceleft w)) - (when (and w (or atsign (minusp (float-sign number)))) - (decf spaceleft)) - (multiple-value-bind (str len lpoint tpoint) - (sb!impl::flonum-to-string (abs number) spaceleft d k) - ;;if caller specifically requested no fraction digits, suppress the - ;;optional trailing zero - (when (and d (zerop d)) (setq tpoint nil)) - (when w - (decf spaceleft len) - ;;optional leading zero - (when lpoint - (if (or (> spaceleft 0) tpoint) ;force at least one digit - (decf spaceleft) - (setq lpoint nil))) - ;;optional trailing zero - (when tpoint - (if (> spaceleft 0) - (decf spaceleft) - (setq tpoint nil)))) - (cond ((and w (< spaceleft 0) ovf) - ;;field width overflow - (dotimes (i w) (write-char ovf stream)) - t) - (t - (when w (dotimes (i spaceleft) (write-char pad stream))) - (if (minusp (float-sign number)) - (write-char #\- stream) - (if atsign (write-char #\+ stream))) - (when lpoint (write-char #\0 stream)) - (write-string str stream) - (when tpoint (write-char #\0 stream)) - nil))))))) + ((or (float-infinity-p number) + (float-nan-p number)) + (prin1 number stream) + nil) + (t + (sb!impl::string-dispatch (single-float double-float) + number + (let ((spaceleft w)) + (when (and w (or atsign (minusp (float-sign number)))) + (decf spaceleft)) + (multiple-value-bind (str len lpoint tpoint) + (sb!impl::flonum-to-string (abs number) spaceleft d k) + ;; if caller specifically requested no fraction digits, suppress the + ;; optional trailing zero + (when (and d (zerop d)) + (setq tpoint nil)) + (when w + (decf spaceleft len) + ;; optional leading zero + (when lpoint + (if (or (> spaceleft 0) tpoint) ;force at least one digit + (decf spaceleft) + (setq lpoint nil))) + ;; optional trailing zero + (when tpoint + (if (> spaceleft 0) + (decf spaceleft) + (setq tpoint nil)))) + (cond ((and w (< spaceleft 0) ovf) + ;; field width overflow + (dotimes (i w) + (write-char ovf stream)) + t) + (t + (when w + (dotimes (i spaceleft) + (write-char pad stream))) + (if (minusp (float-sign number)) + (write-char #\- stream) + (when atsign + (write-char #\+ stream))) + (when lpoint + (write-char #\0 stream)) + (write-string str stream) + (when tpoint + (write-char #\0 stream)) + nil)))))))) (def-format-interpreter #\E (colonp atsignp params) (when colonp diff --git a/version.lisp-expr b/version.lisp-expr index c374dbc..74113a3 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.23.52" +"1.0.23.53"