- cmucl-cvs - mailman3.common-lisp.net

[Git][cmucl/cmucl][issue-175-simplify-float-compare-vops] Add tests for =, for completeness.
by Raymond Toy (＠rtoy) 08 Mar '23

08 Mar '23

Raymond Toy pushed to branch issue-175-simplify-float-compare-vops at cmucl / cmucl Commits: 9cb12348 by Raymond Toy at 2023-03-08T10:33:46-08:00 Add tests for =, for completeness. - - - - - 1 changed file: - tests/nan.lisp Changes: ===================================== tests/nan.lisp ===================================== @@ -32,7 +32,9 @@ (frob single-float <) (frob single-float >) (frob double-float <) - (frob double-float >))) + (frob double-float >) + (frob single-float =) + (frob double-float =))) (define-test nan-single.< (:tag :nan) @@ -158,3 +160,50 @@ (assert-false (dtst->3 1d0 *double-float-nan* 3d0)) (assert-false (dtst->3 *double-float-nan* *double-float-nan* 3d0)))) +(define-test nan-single.= + (:tag :nan) + ;; Basic tests with regular numbers. + (assert-true (stst-= 1f0 1f0)) + (assert-false (stst-= 2f0 1f0)) + (assert-false (stst-= 0f0 1f0)) + ;; Tests with NaN, where = should fail. + (ext:with-float-traps-masked (:invalid) + (assert-false (stst-= *single-float-nan* 1f0)) + (assert-false (stst-= 1f0 *single-float-nan*)) + (assert-false (stst-= *single-float-nan* *single-float-nan*)))) + +(define-test nan-double.= + (:tag :nan) + ;; Basic tests with regular numbers. + (assert-true (stst-= 1d0 1d0)) + (assert-false (stst-= 2d0 1d0)) + (assert-false (stst-= 0d0 1d0)) + ;; Tests with NaN, where = should fail. + (ext:with-float-traps-masked (:invalid) + (assert-false (stst-= *double-float-nan* 1d0)) + (assert-false (stst-= 1d0 *double-float-nan*)) + (assert-false (stst-= *double-float-nan* *double-float-nan*)))) + +(define-test nan-single.=3 + (:tag :nan) + ;; Basic tests with regular numbers. + (assert-true (stst-=3 1f0 1f0 1f0)) + (assert-false (stst-=3 1f0 1f0 0f0)) + (assert-false (stst-=3 0f0 1f0 1f0)) + ;; Tests with NaN, where = should fail. + (ext:with-float-traps-masked (:invalid) + (assert-false (stst-=3 *single-float-nan* 1f0 1f0)) + (assert-false (stst-=3 1f0 *single-float-nan* 1f0)) + (assert-false (stst-=3 1f0 1f0 *single-float-nan*)))) + +(define-test nan-double.=3 + (:tag :nan) + ;; Basic tests with regular numbers. + (assert-true (dtst-=3 1d0 1d0 1d0)) + (assert-false (dtst-=3 1d0 1d0 0d0)) + (assert-false (dtst-=3 0d0 1d0 1d0)) + ;; Tests with NaN, where = should fail. + (ext:with-float-traps-masked (:invalid) + (assert-false (dtst-=3 *double-float-nan* 1d0 1d0)) + (assert-false (dtst-=3 1d0 *double-float-nan* 1d0)) + (assert-false (dtst-=3 1d0 1d0 *double-float-nan*)))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/9cb12348b64546ee281c5ff… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/9cb12348b64546ee281c5ff… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-175-simplify-float-compare-vops] 2 commits: Simplify the vops to need just one jmp instead of two.
by Raymond Toy (＠rtoy) 08 Mar '23

08 Mar '23

Raymond Toy pushed to branch issue-175-simplify-float-compare-vops at cmucl / cmucl Commits: 6ff1b068 by Raymond Toy at 2023-03-08T10:16:58-08:00 Simplify the vops to need just one jmp instead of two. - - - - - 8ff33374 by Raymond Toy at 2023-03-08T10:17:51-08:00 Add tests for NaN comparisons. - - - - - 2 changed files: - src/compiler/x86/float-sse2.lisp - + tests/nan.lisp Changes: ===================================== src/compiler/x86/float-sse2.lisp ===================================== @@ -964,18 +964,23 @@ (descriptor-reg (inst ,inst x (,ea y)))) (cond (not-p - (inst jmp :p target) - (inst jmp :na target)) + ;; Instead of x > y, we're doing x <= y and want + ;; to jmp when x <= y. If NaN occurrs we also + ;; want to jump. x <= y means CF = 1 or ZF = 1. + ;; When NaN occurs, ZF, PF, and CF are all set. + ;; Hence, we can just test for x <= y. + (inst jmp :be target)) (t - (let ((not-lab (gen-label))) - (inst jmp :p not-lab) - (inst jmp :a target) - (emit-label not-lab))))))))) + ;; If there's NaN, the ZF, PF, and CF bits are + ;; set. We only want to jmp to the target when + ;; x > y. This happens if CF = 0. Hence, we + ;; will not jmp to the target if NaN occurred. + (inst jmp :a target)))))))) (frob > single comiss) (frob > double comisd)) (macrolet - ((frob (op size inst) + ((frob (op size inst mover) (let ((ea (ecase size (single 'ea-for-sf-desc) @@ -987,22 +992,29 @@ `(define-vop (,name ,inherit) (:translate ,op) (:info target not-p) + (:temporary (:sc ,sc-type) load-y) (:generator 3 (sc-case y (,sc-type - (inst ,inst x y)) + (inst ,inst y x)) (descriptor-reg - (inst ,inst x (,ea y)))) + (inst ,mover load-y (,ea y)) + (inst ,inst load-y x))) (cond (not-p - (inst jmp :p target) - (inst jmp :nb target)) + ;; Instead of x < y, we're doing x >= y and want + ;; to jmp when x >= y. But x >=y is the same as + ;; y <= x, so if we swap the args, we can apply + ;; the same logic we use for > not-p case above. + (inst jmp :be target)) (t - (let ((not-lab (gen-label))) - (inst jmp :p not-lab) - (inst jmp :b target) - (emit-label not-lab))))))))) - (frob < single comiss) - (frob < double comisd)) + ;; We want to jump when x < y. This is the same + ;; as jumping when y > x. So if we reverse the + ;; args, we can apply the same logic as we did + ;; above for the > vop. + + (inst jmp :a target)))))))) + (frob < single comiss movss) + (frob < double comisd movsd)) ;;;; Conversion: ===================================== tests/nan.lisp ===================================== @@ -0,0 +1,160 @@ +;;; Tests for NaN comparisons. +(defpackage :nan-tests + (:use :cl :lisp-unit)) + +(in-package :nan-tests) + +(defparameter *single-float-nan* + (ext:with-float-traps-masked (:invalid :divide-by-zero) + (/ 0d0 0d0))) + +(defparameter *double-float-nan* + (ext:with-float-traps-masked (:invalid :divide-by-zero) + (/ 0d0 0d0))) + + +(eval-when (:compile-toplevel :load-toplevel :execute) + (macrolet + ((frob (ntype op) + (let* ((name (ext:symbolicate (if (eq ntype 'single-float) + "S" + "D") + "TST-" op)) + (name3 (ext:symbolicate name "3"))) + + `(progn + (defun ,name (x y) + (declare (,ntype x y)) + (,op x y)) + (defun ,name3 (x y z) + (declare (,ntype x y z)) + (,op x y z)))))) + (frob single-float <) + (frob single-float >) + (frob double-float <) + (frob double-float >))) + +(define-test nan-single.< + (:tag :nan) + ;; First just make sure it works with regular single-floats + (assert-true (stst-< 1f0 2f0)) + (assert-false (stst-< 1f0 1f0)) + (assert-false (stst-< 1f0 0f0)) + ;; Now try NaN. All comparisons should be false. + (ext:with-float-traps-masked (:invalid) + (assert-false (stst-< *single-float-nan* 1f0)) + (assert-false (stst-< 1f0 *single-float-nan*)) + (assert-false (stst-< *single-float-nan* *single-float-nan*)))) + +(define-test nan-double.< + (:tag :nan) + ;; First just make sure it works with regular single-floats + (assert-true (dtst-< 1d0 2d0)) + (assert-false (dtst-< 1d0 1d0)) + (assert-false (dtst-< 1d0 0d0)) + ;; Now try NaN. All comparisons should be false. + (ext:with-float-traps-masked (:invalid) + (assert-false (dtst-< *double-float-nan* 1d0)) + (assert-false (dtst-< 1d0 *double-float-nan*)) + (assert-false (dtst-< *double-float-nan* *double-float-nan*)))) + +(define-test nan-single.> + (:tag :nan) + ;; First just make sure it works with regular single-floats + (assert-true (stst-> 2f0 1f0)) + (assert-false (stst-> 1f0 1f0)) + (assert-false (stst-> 0f0 1f0)) + ;; Now try NaN. All comparisons should be false. + (ext:with-float-traps-masked (:invalid) + (assert-false (stst-> *single-float-nan* 1f0)) + (assert-false (stst-> 1f0 *single-float-nan*)) + (assert-false (stst-> *single-float-nan* *single-float-nan*)))) + +(define-test nan-double.> + (:tag :nan) + ;; First just make sure it works with regular single-floats + (assert-true (dtst-> 2d0 1d0)) + (assert-false (dtst-> 1d0 1d0)) + (assert-false (dtst-> 0d0 1d0)) + ;; Now try NaN. All comparisons should be false. + (ext:with-float-traps-masked (:invalid) + (assert-false (dtst-> *double-float-nan* 1d0)) + (assert-false (dtst-> 1d0 *double-float-nan*)) + (assert-false (dtst-> *double-float-nan* *double-float-nan*)))) + +(define-test nan-single.<3 + (:tag :nan) + ;; First just make sure it works with regular single-floats + (assert-true (stst-<3 1f0 2f0 3f0)) + (assert-false (stst-<3 1f0 2f0 2f0)) + (assert-false (stst-<3 1f0 1f0 2f0)) + (assert-false (stst-<3 1f0 0f0 2f0)) + ;; Now try NaN. Currently we can only test if there's NaN in the + ;; first two args. When NaN is the last arg, we return the + ;; incorrect value because of how multi-compare converts multiple + ;; args into paris of comparisons. + ;; + ;; When that is fixed, we can add additional tests. Nevertheless, + ;; this is useful because it tests the not-p case of the vops. + (ext:with-float-traps-masked (:invalid) + (assert-false (stst-<3 *single-float-nan* 2f0 3f0)) + (assert-false (stst-<3 1f0 *single-float-nan* 3f0)) + (assert-false (stst-<3 *single-float-nan* *single-float-nan* 3f0)))) + +(define-test nan-double.<3 + (:tag :nan) + ;; First just make sure it works with regular double-floats + (assert-true (dtst-<3 1d0 2d0 3d0)) + (assert-false (dtst-<3 1d0 2d0 2d0)) + (assert-false (dtst-<3 1d0 1d0 2d0)) + (assert-false (dtst-<3 1d0 0d0 2d0)) + ;; Now try NaN. Currently we can only test if there's NaN in the + ;; first two args. When NaN is the last arg, we return the + ;; incorrect value because of how multi-compare converts multiple + ;; args into paris of comparisons. + ;; + ;; When that is fixed, we can add additional tests. Nevertheless, + ;; this is useful because it tests the not-p case of the vops. + (ext:with-float-traps-masked (:invalid) + (assert-false (dtst-<3 *double-float-nan* 2d0 3d0)) + (assert-false (dtst-<3 1d0 *double-float-nan* 3d0)) + (assert-false (dtst-<3 *double-float-nan* *double-float-nan* 3d0)))) + +(define-test nan-single.>3 + (:tag :nan) + ;; First just make sure it works with regular single-floats + (assert-true (stst->3 3f0 2f0 1f0)) + (assert-false (stst->3 3f0 1f0 1f0)) + (assert-false (stst->3 2f0 2f0 1f0)) + (assert-false (stst->3 0f0 2f0 1f0)) + ;; Now try NaN. Currently we can only test if there's NaN in the + ;; first two args. When NaN is the last arg, we return the + ;; incorrect value because of how multi-compare converts multiple + ;; args into paris of comparisons. + ;; + ;; When that is fixed, we can add additional tests. Nevertheless, + ;; this is useful because it tests the not-p case of the vops. + (ext:with-float-traps-masked (:invalid) + (assert-false (stst->3 *single-float-nan* 2f0 3f0)) + (assert-false (stst->3 1f0 *single-float-nan* 3f0)) + (assert-false (stst->3 *single-float-nan* *single-float-nan* 3f0)))) + +(define-test nan-double.>3 + (:tag :nan) + ;; First just make sure it works with regular double-floats + (assert-true (dtst->3 3d0 2d0 1d0)) + (assert-false (dtst->3 3d0 1d0 1d0)) + (assert-false (dtst->3 2d0 2d0 1d0)) + (assert-false (dtst->3 0d0 2d0 1d0)) + ;; Now try NaN. Currently we can only test if there's NaN in the + ;; first two args. When NaN is the last arg, we return the + ;; incorrect value because of how multi-compare converts multiple + ;; args into paris of comparisons. + ;; + ;; When that is fixed, we can add additional tests. Nevertheless, + ;; this is useful because it tests the not-p case of the vops. + (ext:with-float-traps-masked (:invalid) + (assert-false (dtst->3 *double-float-nan* 2d0 3d0)) + (assert-false (dtst->3 1d0 *double-float-nan* 3d0)) + (assert-false (dtst->3 *double-float-nan* *double-float-nan* 3d0)))) + View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/87906cf27d0fa2d30ccc4d… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/87906cf27d0fa2d30ccc4d… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-175-simplify-float-compare-vops
by Raymond Toy (＠rtoy) 08 Mar '23

08 Mar '23

Raymond Toy pushed new branch issue-175-simplify-float-compare-vops at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-175-simplify-float-… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-157-directory-no-magic-wildcarding] Need to merge the directory pathname with defaults
by Raymond Toy (＠rtoy) 08 Mar '23

08 Mar '23

Raymond Toy pushed to branch issue-157-directory-no-magic-wildcarding at cmucl / cmucl Commits: d5b02338 by Raymond Toy at 2023-03-08T08:43:59-08:00 Need to merge the directory pathname with defaults If we don't then logical pathnames don't work, among other things. In particular the following ansi-tests were failling: DIRECTORY.8, OPEN.OUTPUT.28, OPEN.OUTPUT.35, OPEN.IO.28, OPEN.IO.35, OPEN.PROBE.12, OPEN.PROBE.13, OPEN.PROBE.14, OPEN.PROBE.15, OPEN.PROBE.16, OPEN.PROBE.17, OPEN.PROBE.18, OPEN.PROBE.19, OPEN.PROBE.20, OPEN.ERROR.4, OPEN.ERROR.5, OPEN.ERROR.6, OPEN.ERROR.7, OPEN.ERROR.8, OPEN.ERROR.9, OPEN.ERROR.10, OPEN.ERROR.11, OPEN.ERROR.12, OPEN.ERROR.13, OPEN.ERROR.14. With this change, the ansi-tests suite passes. - - - - - 1 changed file: - src/code/filesys.lisp Changes: ===================================== src/code/filesys.lisp ===================================== @@ -1120,7 +1120,9 @@ optionally keeping some of the most recent old versions." (setf prev elem)) (nreverse results)))) (let ((results nil)) - (enumerate-search-list (pathname pathname) + (enumerate-search-list + (pathname (merge-pathnames pathname + *default-pathname-defaults*)) (enumerate-matches (name pathname nil :follow-links follow-links) (when (or all (let ((slash (position #\/ name :from-end t))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/d5b023387b05012738abd70… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/d5b023387b05012738abd70… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-156-take-2-nan-comparison] Use existing function to compute >= and <=
by Raymond Toy (＠rtoy) 08 Mar '23

08 Mar '23

Raymond Toy pushed to branch issue-156-take-2-nan-comparison at cmucl / cmucl Commits: bd505bab by Raymond Toy at 2023-03-08T07:56:11-08:00 Use existing function to compute >= and <= The code assumed if a0 >= b0 and a1 >= b1 implied a >= b for a bigfloat. But I forgot that 1.99999...w0 is represented as 2d0 and a tiny negative number. So `(<= 2w0 1.99999...w0)` would return false because, while a0 <= b0, a1 <= b1 is false. So for simplicity just use the obvious replacement that a <= b is the same as a < b or a = b, which we already have. [skip ci] - - - - - 1 changed file: - src/compiler/float-tran-dd.lisp Changes: ===================================== src/compiler/float-tran-dd.lisp ===================================== @@ -670,13 +670,13 @@ (declaim (inline dd<=)) (defun dd<= (a0 a1 b0 b1) - (and (<= a0 b0) - (<= a1 b1))) + (or (dd> a0 a1 b0 b1) + (dd= a0 a1 b0 b1))) (declaim (inline dd>=)) (defun dd>= (a0 a1 b0 b1) - (and (>= a0 b0) - (>= a1 b1))) + (or (dd> a0 a1 b0 b1) + (dd= a0 a1 b0 b1))) (deftransform = ((a b) (vm::double-double-float vm::double-double-float) *) `(dd= (kernel:double-double-hi a) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/bd505bab9b50e50016cea7c… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/bd505bab9b50e50016cea7c… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-156-take-2-nan-comparison
by Raymond Toy (＠rtoy) 07 Mar '23

07 Mar '23

Raymond Toy pushed new branch issue-156-take-2-nan-comparison at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-156-take-2-nan-comp… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Fix #173: Add pprinter for define-assembly-routine
by Raymond Toy (＠rtoy) 06 Mar '23

06 Mar '23

Raymond Toy pushed to branch master at cmucl / cmucl Commits: b2f6ab4c by Raymond Toy at 2023-03-06T17:07:46+00:00 Fix #173: Add pprinter for define-assembly-routine - - - - - 7a15c464 by Raymond Toy at 2023-03-06T17:07:49+00:00 Merge branch 'issue-173-pprint-def-assem-routine' into 'master' Fix #173: Add pprinter for define-assembly-routine Closes #173 See merge request cmucl/cmucl!126 - - - - - 1 changed file: - src/code/pprint.lisp Changes: ===================================== src/code/pprint.lisp ===================================== @@ -1920,6 +1920,42 @@ When annotations are present, invoke them at the right positions." (pprint-newline :mandatory stream))) (pprint-exit-if-list-exhausted) (pprint-newline :mandatory stream)))) + +(defun pprint-define-assembly (stream list &rest noise) + (declare (ignore noise)) + (pprint-logical-block (stream list :prefix "(" :suffix ")") + ;; Output "define-assembly-routine" + (output-object (pprint-pop) stream) + (pprint-exit-if-list-exhausted) + (write-char #\space stream) + ;; Output routine name and options. + (pprint-logical-block (stream (pprint-pop) :prefix "(" :suffix ")") + ;; Output the routine name + (output-object (pprint-pop) stream) + (pprint-exit-if-list-exhausted) + (pprint-newline :mandatory stream) + (pprint-indent :block 0 stream) + ;; Output options, one per line, neatly lined up and indented + ;; below the routine name. + (loop + (output-object (pprint-pop) stream) + (pprint-exit-if-list-exhausted) + (pprint-newline :mandatory stream))) + ;; Now output the args, results, and temps used by the assembly + ;; routine. Instead of lining up with the routine name, let's + ;; just indent it 4 spaces from the "define-assembly-routine" so + ;; it doesn't look so top-heavy. + (pprint-indent :block 4 stream) + (pprint-newline :mandatory stream) + (pprint-logical-block (stream (pprint-pop) :prefix "(" :suffix ")") + (loop + (output-object (pprint-pop) stream) + (pprint-exit-if-list-exhausted) + (pprint-newline :mandatory stream))) + ;; Now print out the assembly code as if it were a tagbody. Then + ;; labels are outdented by one to make them easy to see. + (pprint-newline :mandatory stream) + (pprint-tagbody-guts stream))) ;;;; Interface seen by regular (ugly) printer and initialization routines. @@ -2037,7 +2073,8 @@ When annotations are present, invoke them at the right positions." (stream::with-stream-class pprint-with-like) (lisp::with-array-data pprint-with-like) (c:define-vop pprint-define-vop) - (c:sc-case pprint-sc-case))) + (c:sc-case pprint-sc-case) + (c:define-assembly-routine pprint-define-assembly))) (defun pprint-init () (setf *initial-pprint-dispatch* (make-pprint-dispatch-table)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/9d32d69a918d3542444ab3… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/9d32d69a918d3542444ab3… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-157-directory-no-magic-wildcarding
by Raymond Toy (＠rtoy) 06 Mar '23

06 Mar '23

Raymond Toy pushed new branch issue-157-directory-no-magic-wildcarding at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-157-directory-no-ma… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-173-pprint-def-assem-routine
by Raymond Toy (＠rtoy) 05 Mar '23

05 Mar '23

Raymond Toy pushed new branch issue-173-pprint-def-assem-routine at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-173-pprint-def-asse… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] Indent let in %time correctly.
by Raymond Toy (＠rtoy) 05 Mar '23

05 Mar '23

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 9d32d69a by Raymond Toy at 2023-03-05T07:43:06-08:00 Indent let in %time correctly. A `let` sexp in `%time` was not indented correctly. Indent it correctly now. - - - - - 1 changed file: - src/code/time.lisp Changes: ===================================== src/code/time.lisp ===================================== @@ -352,51 +352,51 @@ (old-run-utime old-run-stime old-page-faults old-bytes-consed) (time-get-sys-info)) (let ((start-gc-run-time *gc-run-time*)) - (setq cycle-count (- (cycle-count/float))) - (multiple-value-prog1 - ;; Execute the form and return its values. - (funcall fun) - (incf cycle-count (cycle-count/float)) - (multiple-value-setq - (new-run-utime new-run-stime new-page-faults new-bytes-consed) - (time-get-sys-info)) - (setq new-real-time (- (get-internal-real-time) real-time-overhead)) - (let ((gc-run-time (max (- *gc-run-time* start-gc-run-time) 0)) - (bytes-consed (- new-bytes-consed old-bytes-consed cons-overhead))) - (unless *in-get-time-consing* - (terpri *trace-output*) - (pprint-logical-block (*trace-output* nil :per-line-prefix "; ") - (format *trace-output* - (intl:gettext "Evaluation took:~% ~ + (setq cycle-count (- (cycle-count/float))) + (multiple-value-prog1 + ;; Execute the form and return its values. + (funcall fun) + (incf cycle-count (cycle-count/float)) + (multiple-value-setq + (new-run-utime new-run-stime new-page-faults new-bytes-consed) + (time-get-sys-info)) + (setq new-real-time (- (get-internal-real-time) real-time-overhead)) + (let ((gc-run-time (max (- *gc-run-time* start-gc-run-time) 0)) + (bytes-consed (- new-bytes-consed old-bytes-consed cons-overhead))) + (unless *in-get-time-consing* + (terpri *trace-output*) + (pprint-logical-block (*trace-output* nil :per-line-prefix "; ") + (format *trace-output* + (intl:gettext "Evaluation took:~% ~ ~S seconds of real time~% ~ ~S seconds of user run time~% ~ ~S seconds of system run time~% ") - (max (/ (- new-real-time old-real-time) - (float internal-time-units-per-second)) - 0.0) - (max (/ (- new-run-utime old-run-utime) 1000000.0) 0.0) - (max (/ (- new-run-stime old-run-stime) 1000000.0) 0.0)) - (format *trace-output* - (intl:ngettext - "~:D ~A cycle~% ~ + (max (/ (- new-real-time old-real-time) + (float internal-time-units-per-second)) + 0.0) + (max (/ (- new-run-utime old-run-utime) 1000000.0) 0.0) + (max (/ (- new-run-stime old-run-stime) 1000000.0) 0.0)) + (format *trace-output* + (intl:ngettext + "~:D ~A cycle~% ~ ~@[[Run times include ~S seconds GC run time]~% ~]" - "~:D ~A cycles~% ~ + "~:D ~A cycles~% ~ ~@[[Run times include ~S seconds GC run time]~% ~]" - (truncate cycle-count)) - (truncate cycle-count) - "CPU" - (unless (zerop gc-run-time) - (/ (float gc-run-time) - (float internal-time-units-per-second)))) - (format *trace-output* - (intl:ngettext "~S page fault and~% " - "~S page faults and~% " - (max (- new-page-faults old-page-faults) 0)) - (max (- new-page-faults old-page-faults) 0)) - (format *trace-output* - (intl:ngettext "~:D byte consed.~%" - "~:D bytes consed.~%" - (max (- bytes-consed (or *time-consing* 0)) 0)) - (max (- bytes-consed (or *time-consing* 0)) 0))) - (terpri *trace-output*)) - (setq *last-time-consing* bytes-consed)))))) + (truncate cycle-count)) + (truncate cycle-count) + "CPU" + (unless (zerop gc-run-time) + (/ (float gc-run-time) + (float internal-time-units-per-second)))) + (format *trace-output* + (intl:ngettext "~S page fault and~% " + "~S page faults and~% " + (max (- new-page-faults old-page-faults) 0)) + (max (- new-page-faults old-page-faults) 0)) + (format *trace-output* + (intl:ngettext "~:D byte consed.~%" + "~:D bytes consed.~%" + (max (- bytes-consed (or *time-consing* 0)) 0)) + (max (- bytes-consed (or *time-consing* 0)) 0))) + (terpri *trace-output*)) + (setq *last-time-consing* bytes-consed)))))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/9d32d69a918d3542444ab30… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/9d32d69a918d3542444ab30… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0