Commit 9514ed06 authored by Raymond Toy's avatar Raymond Toy
Browse files

Merge branch 'master' into rtoy-issue-76-add-ansi-tests-to-ci

parents 6f87c065 974366fb
Pipeline #1441 failed with stage
in 13 minutes and 59 seconds
variables:
download_url: "https://common-lisp.net/project/cmucl/downloads/snapshots/2018/10"
version: "2018-10-x86"
bootstrap: "-B boot-21d.lisp"
download_url: "https://common-lisp.net/project/cmucl/downloads/snapshots/2020/04"
version: "2020-04-x86"
bootstrap: ""
linux-runner:
tags:
......
......@@ -102,6 +102,11 @@
\"contrib-games-feebs\", \"contrib-hist\", \"contrib-psgraph\",
\"contrib-ops\", \"contrib-embedded-c\", \"contrib-sprof\", and
\"contrib-packed-sse2\". "
;; First, load asdf if it's not already loaded. This is needed to
;; load easily the contribs that use asdf. There are no contribs
;; that use defsystem, so we won't autoload defsystem.
(unless (featurep :asdf)
(load "modules:asdf/asdf"))
(let ((saved-modules (copy-list *modules*))
(module-name (module-name-string module-name)))
(unless (member module-name *modules* :test #'string=)
......@@ -158,19 +163,5 @@
(defmodule "asdf"
"modules:asdf/asdf")
;; Lisp-unit
(defmodule :lisp-unit
"modules:load-lisp-unit")
(defmodule "lisp-unit"
"modules:load-lisp-unit")
;; Allow user to specify "cmu-contribs" or :cmu-contribs.
(defmodule "cmu-contribs"
"modules:contrib")
(defmodule :cmu-contribs
"modules:contrib")
(defmodule :unix
"modules:load-unix")
;;; -*- mode: Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; buffer-read-only: t; -*-
;;; This is ASDF 3.3.3: Another System Definition Facility.
;;; This is ASDF 3.3.4: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
......@@ -1697,7 +1697,7 @@ form suitable for testing with #+."
(in-package :uiop/version)
 
(with-upgradability ()
(defparameter *uiop-version* "3.3.3")
(defparameter *uiop-version* "3.3.4")
 
(defun unparse-version (version-list)
"From a parsed version (a list of natural numbers), compute the version string"
......@@ -1987,16 +1987,17 @@ use getenvp to return NIL in such a case."
 
(defsetf getenv (x) (val)
"Set an environment variable."
(declare (ignorable x val))
(declare (ignorable x val))
#+allegro `(setf (sys:getenv ,x) ,val)
#+clasp `(ext:setenv ,x ,val)
#+clisp `(system::setenv ,x ,val)
#+clozure `(ccl:setenv ,x ,val)
#+cmucl `(unix:unix-setenv ,x ,val 1)
#+ecl `(ext:setenv ,x ,val)
#+lispworks `(hcl:setenv ,x ,val)
#+(or ecl clasp) `(ext:setenv ,x ,val)
#+lispworks `(setf (lispworks:environment-variable ,x) ,val)
#+mkcl `(mkcl:setenv ,x ,val)
#+sbcl `(progn (require :sb-posix) (symbol-call :sb-posix :setenv ,x ,val 1))
#-(or allegro clisp clozure cmucl ecl lispworks mkcl sbcl)
#-(or allegro clasp clisp clozure cmucl ecl lispworks mkcl sbcl)
'(not-implemented-error '(setf getenv)))
 
(defun getenvp (x)
......@@ -2175,7 +2176,8 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie
#+(or cmucl scl) (unix:unix-chdir (ext:unix-namestring x))
#+cormanlisp (unless (zerop (win32::_chdir (namestring x)))
(error "Could not set current directory to ~A" x))
#+(or clasp ecl) (ext:chdir x)
#+ecl (ext:chdir x)
#+clasp (ext:chdir x t)
#+gcl (system:chdir x)
#+lispworks (hcl:change-directory x)
#+mkcl (mk-ext:chdir x)
......@@ -3226,7 +3228,7 @@ Subdirectories should NOT be returned.
override the default at your own risk.
DIRECTORY-FILES tries NOT to resolve symlinks if the implementation permits this,
but the behavior in presence of symlinks is not portable. Use IOlib to handle such situations."
(let ((dir (pathname directory)))
(let ((dir (ensure-directory-pathname directory)))
(when (logical-pathname-p dir)
;; Because of the filtering we do below,
;; logical pathnames have restrictions on wild patterns.
......@@ -3507,7 +3509,10 @@ resolving them with respect to GETCWD if the DEFAULTS were relative"
"call the THUNK in a context where the current directory was changed to DIR, if not NIL.
Note that this operation is usually NOT thread-safe."
(if dir
(let* ((dir (resolve-symlinks* (get-pathname-defaults (pathname-directory-pathname dir))))
(let* ((dir (resolve-symlinks*
(get-pathname-defaults
(ensure-directory-pathname
dir))))
(cwd (getcwd))
(*default-pathname-defaults* dir))
(chdir dir)
......@@ -3662,11 +3667,10 @@ the validation function designated (as per ENSURE-FUNCTION) by the VALIDATE keyw
which in practice is thus compulsory, and validates by returning a non-NIL result.
If you're suicidal or extremely confident, just use :VALIDATE T."
(check-type if-does-not-exist (member :error :ignore))
(setf directory-pathname (ensure-pathname directory-pathname
:want-pathname t :want-non-wild t
:want-physical t :want-directory t))
(cond
((not (and (pathnamep directory-pathname) (directory-pathname-p directory-pathname)
(physical-pathname-p directory-pathname) (not (wild-pathname-p directory-pathname))))
(parameter-error "~S was asked to delete ~S but it is not a physical non-wildcard directory pathname"
'delete-directory-tree directory-pathname))
((not validatep)
(parameter-error "~S was asked to delete ~S but was not provided a validation predicate"
'delete-directory-tree directory-pathname))
......@@ -4166,6 +4170,8 @@ BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
(defun read-file-forms (file &rest keys &key count &allow-other-keys)
"Open input FILE with option KEYS (except COUNT),
and read its contents as per SLURP-STREAM-FORMS with given COUNT.
If COUNT is null, read to the end of the stream;
if COUNT is an integer, stop after COUNT forms were read.
BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
(apply 'call-with-input-file file
#'(lambda (input) (slurp-stream-forms input :count count))
......@@ -4970,7 +4976,7 @@ This can help you produce more deterministic output for FASLs."))
#+clozure '(ccl::*nx-speed* ccl::*nx-space* ccl::*nx-safety*
ccl::*nx-debug* ccl::*nx-cspeed*)
#+(or cmucl scl) '(c::*default-cookie*)
#+clasp '()
#+clasp nil
#+ecl (unless (use-ecl-byte-compiler-p) '(c::*speed* c::*space* c::*safety* c::*debug*))
#+gcl '(compiler::*speed* compiler::*space* compiler::*compiler-new-safety* compiler::*debug*)
#+lispworks '(compiler::*optimization-level*)
......@@ -4981,7 +4987,8 @@ This can help you produce more deterministic output for FASLs."))
#-(or abcl allegro clasp clisp clozure cmucl ecl lispworks mkcl sbcl scl xcl)
(warn "~S does not support ~S. Please help me fix that."
'get-optimization-settings (implementation-type))
#+(or abcl allegro clasp clisp clozure cmucl ecl lispworks mkcl sbcl scl xcl)
#+clasp (cleavir-env:optimize (cleavir-env:optimize-info CLASP-CLEAVIR:*CLASP-ENV*))
#+(or abcl allegro clisp clozure cmucl ecl lispworks mkcl sbcl scl xcl)
(let ((settings '(speed space safety debug compilation-speed #+(or cmucl scl) c::brevity)))
#.`(loop #+(or allegro clozure)
,@'(:with info = #+allegro (sys:declaration-information 'optimize)
......@@ -4990,7 +4997,7 @@ This can help you produce more deterministic output for FASLs."))
,@(or #+(or abcl clasp ecl gcl mkcl xcl) '(:for v :in +optimization-variables+))
:for y = (or #+(or allegro clozure) (second (assoc x info)) ; normalize order
#+clisp (gethash x system::*optimize* 1)
#+(or abcl clasp ecl mkcl xcl) (symbol-value v)
#+(or abcl ecl mkcl xcl) (symbol-value v)
#+(or cmucl scl) (slot-value c::*default-cookie*
(case x (compilation-speed 'c::cspeed)
(otherwise x)))
......@@ -5004,13 +5011,15 @@ This can help you produce more deterministic output for FASLs."))
(unless (equal *previous-optimization-settings* settings)
(setf *previous-optimization-settings* settings))))
(defmacro with-optimization-settings ((&optional (settings *optimization-settings*)) &body body)
#+(or allegro clisp)
(let ((previous-settings (gensym "PREVIOUS-SETTINGS")))
`(let ((,previous-settings (get-optimization-settings)))
#+(or allegro clasp clisp)
(let ((previous-settings (gensym "PREVIOUS-SETTINGS"))
(reset-settings (gensym "RESET-SETTINGS")))
`(let* ((,previous-settings (get-optimization-settings))
(,reset-settings #+clasp (reverse ,previous-settings) #-clasp ,previous-settings))
,@(when settings `((proclaim `(optimize ,@,settings))))
(unwind-protect (progn ,@body)
(proclaim `(optimize ,@,previous-settings)))))
#-(or allegro clisp)
(proclaim `(optimize ,@,reset-settings)))))
#-(or allegro clasp clisp)
`(let ,(loop :for v :in +optimization-variables+ :collect `(,v ,v))
,@(when settings `((proclaim `(optimize ,@,settings))))
,@body)))
......@@ -5039,7 +5048,6 @@ This can help you produce more deterministic output for FASLs."))
#+sbcl
'(sb-c::simple-compiler-note
"&OPTIONAL and &KEY found in the same lambda list: ~S"
#+sb-eval sb-kernel:lexical-environment-too-complex
sb-kernel:undefined-alien-style-warning
sb-grovel-unknown-constant-condition ; defined above.
sb-ext:implicit-generic-function-warning ;; Controversial.
......@@ -5050,6 +5058,10 @@ This can help you produce more deterministic output for FASLs."))
sb-kernel:redefinition-with-defgeneric
sb-kernel:redefinition-with-defmethod
sb-kernel::redefinition-with-defmacro) ; not exported by old SBCLs
#+sbcl
(let ((condition (find-symbol* '#:lexical-environment-too-complex :sb-kernel nil)))
(when condition
(list condition)))
'("No generic function ~S present when encountering macroexpansion of defmethod. Assuming it will be an instance of standard-generic-function.")) ;; from closer2mop
"A suggested value to which to set or bind *uninteresting-conditions*.")
 
......@@ -5524,7 +5536,8 @@ possibly in a different process. Otherwise just call THUNK."
(or *compile-file-pathname* *load-pathname*))
 
(defun load-pathname ()
"Portably return the LOAD-PATHNAME of the current source file or fasl"
"Portably return the LOAD-PATHNAME of the current source file or fasl.
May return a relative pathname."
*load-pathname*) ;; magic no longer needed for GCL.
 
(defun lispize-pathname (input-file)
......@@ -5603,6 +5616,8 @@ it will filter them appropriately."
(or object-file
(compile-file-pathname output-file :fasl-p nil)))
(tmp-file (tmpize-pathname physical-output-file))
#+clasp
(tmp-object-file (compile-file-pathname tmp-file :output-type :object))
#+sbcl
(cfasl-file (etypecase emit-cfasl
(null nil)
......@@ -5628,7 +5643,7 @@ it will filter them appropriately."
(list* tmp-file keywords)))
#+clasp (apply 'compile-file input-file :output-file
(if object-file
(list* object-file :output-type :object #|:system-p t|# keywords)
(list* tmp-object-file :output-type :object #|:system-p t|# keywords)
(list* tmp-file keywords)))
#+mkcl (apply 'compile-file input-file
:output-file object-file :fasl-p nil keywords)))))
......@@ -5643,14 +5658,13 @@ it will filter them appropriately."
(when (and #+(or clasp ecl) object-file)
(setf output-truename
(compiler::build-fasl tmp-file
#+(or clasp ecl) :lisp-files #+mkcl :lisp-object-files (list object-file))))
#+(or clasp ecl) :lisp-files #+mkcl :lisp-object-files (list #+clasp tmp-object-file #-clasp object-file))))
(or (not compile-check)
(apply compile-check input-file
:output-file output-truename
keywords))))
(delete-file-if-exists physical-output-file)
(when output-truename
#+clasp (when output-truename (rename-file-overwriting-target tmp-file output-truename))
;; see CLISP bug 677
#+clisp
(progn
......@@ -5658,6 +5672,21 @@ it will filter them appropriately."
(unless lib-file (setf lib-file (make-pathname :type "lib" :defaults physical-output-file)))
(rename-file-overwriting-target tmp-lib lib-file))
#+sbcl (when cfasl-file (rename-file-overwriting-target tmp-cfasl cfasl-file))
#+clasp
(progn
;;; the following 4 rename-file-overwriting-target better be atomic, but we can't implement this right now
#+:target-os-darwin
(let ((temp-dwarf (pathname (strcat (namestring output-truename) ".dwarf")))
(target-dwarf (pathname (strcat (namestring physical-output-file) ".dwarf"))))
(when (probe-file temp-dwarf)
(rename-file-overwriting-target temp-dwarf target-dwarf)))
;;; need to rename the bc or ll file as well or test-bundle.script fails
;;; They might not exist with parallel compilation
(let ((bitcode-src (compile-file-pathname tmp-file :output-type :bitcode))
(bitcode-target (compile-file-pathname physical-output-file :output-type :bitcode)))
(when (probe-file bitcode-src)
(rename-file-overwriting-target bitcode-src bitcode-target)))
(rename-file-overwriting-target tmp-object-file object-file))
(rename-file-overwriting-target output-truename physical-output-file)
(setf output-truename (truename physical-output-file)))
#+clasp (delete-file-if-exists tmp-file)
......@@ -7185,7 +7214,7 @@ directive.")
(if wilden (wilden p) p))))
((eql :home) (user-homedir-pathname))
((eql :here) (resolve-absolute-location
(or *here-directory* (pathname-directory-pathname (load-pathname)))
(or *here-directory* (pathname-directory-pathname (truename (load-pathname))))
:ensure-directory t :wilden nil))
((eql :user-cache) (resolve-absolute-location
*user-cache* :ensure-directory t :wilden nil)))
......@@ -7599,7 +7628,7 @@ previously-loaded version of ASDF."
;; "3.4.5.67" would be a development version in the official branch, on top of 3.4.5.
;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5
;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67
(asdf-version "3.3.3")
(asdf-version "3.3.4")
(existing-version (asdf-version)))
(setf *asdf-version* asdf-version)
(when (and existing-version (not (equal asdf-version existing-version)))
......@@ -11408,8 +11437,10 @@ system names contained using COERCE-NAME. Return the result."
(coerce-name (component-system component))))
component)))
 
;; the following are all systems that Stas Boukarev maintains and refuses to fix,
;; hoping instead to make my life miserable. Instead, I just make ASDF ignore them.
(defparameter* *known-systems-with-bad-secondary-system-names*
(list-to-hash-set '("cl-ppcre")))
(list-to-hash-set '("cl-ppcre" "cl-interpol")))
(defun known-system-with-bad-secondary-system-names-p (asd-name)
;; Does .asd file with name ASD-NAME contain known exceptions
;; that should be screened out of checking for BAD-SYSTEM-NAME?
......@@ -11724,7 +11755,7 @@ for all the linkable object files associated with the system or its dependencies
"--all-systems"
;; These use a different type .fasb or .a instead of .fasl
#-(or clasp ecl mkcl) "--system"))))
(format nil "~A~@[~A~]" (component-name c) suffix))))
(format nil "~A~@[~A~]" (coerce-filename (component-name c)) suffix))))
(type (bundle-pathname-type bundle-type)))
(values (list (subpathname (component-pathname c) name :type type))
(eq (class-of o) (coerce-class (component-build-operation c)
......@@ -11895,14 +11926,23 @@ or of opaque libraries shipped along the source code."))
;;;
(with-upgradability ()
(defmethod output-files ((o deliver-asd-op) (s system))
(list (make-pathname :name (component-name s) :type "asd"
(list (make-pathname :name (coerce-filename (component-name s)) :type "asd"
:defaults (component-pathname s))))
 
;; because of name collisions between the output files of different
;; subclasses of DELIVER-ASD-OP, we cannot trust the file system to
;; tell us if the output file is up-to-date, so just treat the
;; operation as never being done.
(defmethod operation-done-p ((o deliver-asd-op) (s system))
(declare (ignorable o s))
nil)
(defmethod perform ((o deliver-asd-op) (s system))
"Write an ASDF system definition for loading S as a delivered system."
(let* ((inputs (input-files o s))
(fasl (first inputs))
(library (second inputs))
(asd (first (output-files o s)))
(asd (output-file o s))
(name (if (and fasl asd) (pathname-name asd) (return-from perform)))
(version (component-version s))
(dependencies
......@@ -11914,7 +11954,7 @@ or of opaque libraries shipped along the source code."))
:keep-operation 'basic-load-op))
(while-collecting (x) ;; resolve the sideway-dependencies of s
(map-direct-dependencies
'load-op s
'prepare-op s
#'(lambda (o c)
(when (and (typep o 'load-op) (typep c 'system))
(x c)))))))
......@@ -11928,12 +11968,17 @@ which is probably not what you want; you probably need to tweak your output tran
:if-does-not-exist :create)
(format s ";;; Prebuilt~:[~; monolithic~] ASDF definition for system ~A~%"
(operation-monolithic-p o) name)
(format s ";;; Built for ~A ~A on a ~A/~A ~A~%"
(lisp-implementation-type)
(lisp-implementation-version)
(software-type)
(machine-type)
(software-version))
;; this can cause bugs in cases where one of the functions returns a multi-line
;; string
(let ((description-string (format nil ";;; Built for ~A ~A on a ~A/~A ~A"
(lisp-implementation-type)
(lisp-implementation-version)
(software-type)
(machine-type)
(software-version))))
;; ensure the whole thing is on one line
(print (remove-if #'(lambda (x) (member x (list #\newline #\return))) description-string) s)
(terpri s))
(let ((*package* (find-package :asdf-user)))
(pprint `(defsystem ,name
:class prebuilt-system
......@@ -11949,7 +11994,7 @@ which is probably not what you want; you probably need to tweak your output tran
(let* ((input-files (input-files o c))
(fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test-not #'equalp))
(non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'equalp))
(output-files (output-files o c))
(output-files (output-files o c)) ; can't use OUTPUT-FILE fn because possibility it's NIL
(output-file (first output-files)))
(assert (eq (not input-files) (not output-files)))
(when input-files
......@@ -12232,6 +12277,10 @@ the DEFPACKAGE-FORM uses it or imports a symbol from it."
(dolist (p arguments) (dep (string p))))
((:import-from :shadowing-import-from)
(dep (string (first arguments))))
#+sbcl
((:local-nicknames)
(loop* :for (local-nickname actual-package-name) :in arguments :do
(dep (string actual-package-name))))
((:nicknames :documentation :shadow :export :intern :unintern :recycle)))))
:from-end t :test 'equal))
 
......
This source diff could not be displayed because it is too large. You can view the blob instead.
This diff is collapsed.
......@@ -7,41 +7,9 @@
(ext:file-comment
"$Header: src/contrib/contrib.lisp $")
;;; Define the various contrib modules. We use defmodule for now
;;; because it's easy for the contribs.
;;; Empty for backward compatibility for users who require'd
;;; cmu-contribs to get the CMU contribs. The contribs all use asdf
;;; now, so we don't need this file to do anything.
(in-package "EXT")
(defmodule "contrib-demos"
"modules:demos/demos" "modules:demos/menu")
(defmodule "contrib-follow-mouse"
"modules:follow-mouse/follow-mouse")
(defmodule "contrib-games-feebs"
"modules:games/feebs/feebs")
(defmodule "contrib-hist"
"modules:hist/hist")
(defmodule "contrib-psgraph"
"modules:psgraph/psgraph")
;; This actually consists of several files, but compile-ops will
;; compile and load them all, so this module appears to have just the
;; one file.
(defmodule "contrib-ops"
"modules:ops/compile-ops")
(defmodule "contrib-embedded-c"
"modules:embedded-c/embedded-c")
;; Sprof really needs to be compiled, so make this module compile sprof.
(defmodule "contrib-sprof"
"modules:sprof/compile-sprof")
;; packed sse2 needs to be compiled to work.
(defmodule "contrib-packed-sse2"
"modules:packed-sse2/compile-packed-sse2")
(provide "cmu-contribs")
;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
(in-package :asdf)
#+solaris
(defsystem :contrib-cpc
:name "tcp-forwarder"
:author "Eric Marsden"
:maintainer "CMU Common Lisp Group"
:long-description "Interface to CPU Performace Counters Library provided with Solaris"
:components
((:file "cpc")))
;;; cpc.lisp -- access the hardware performance counters on Solaris
;;
;; Author: Eric Marsden <emarsden@laas.fr>
;; Time-stamp: <2004-01-03 emarsden>
;; Version: 0.5
;; Copying: This code is in the public domain.
;;
;;
;; This file provides access from CMUCL to the CPU Performance
;; Counters Library provided with Solaris 8. These routines allow you
;; to obtain measurements on certain low level performance measures,
;; such as the number of instructions and processor cycles required to
;; execute a certain bit of code, the number of cycles lost due to
;; incorrectly predicted branches, etc. Only tested on UltraSPARC, but
;; may also work on Solaris x86.
;;
;; Note that the user is responsible for sampling the performance
;; counters sufficiently frequently for them not to wrap. For more
;; information see libcpc(3), cputrack(1) and the SPARC manuals.
;;
;; See also the Perfmon tool
;;
;; <URL:http://www.cps.msu.edu/~enbody/perfmon.html>
;;
;; and
;;
;; <URL:http://developers.sun.com/tools/cc/articles/pcounters.html>
;; <URL:http://developers.sun.com/solaris/articles/optimizing_apps.html>
;; <URL:http://www.sun.com/microelectronics/shade/>
;; <URL:http://www.ece.utexas.edu/projects/ece/lca/courses/tools.html>
;;
;;
;; Here is the meaning of the event specifier flags for UltraSPARC-II
;; (see the SPARC Architecture Manual for more information):
;;
;; +------------------------------------------------------------------+
;; |Cycle_cnt |Accumulated cycles |
;; |Instr_cnt |The number of instructions completed |
;; |Dispatch0_IC_miss |Cycles I-buffer empty from I-Cache miss |
;; |Dispatch0_mispred |Cycles I-buffer empty from branch misprediction|
;; |Dispatch0_storeBuf|Cycles store buffer full |
;; |Dispatch0_FP_use |Cycles stalled waiting for fp dependency |
;; |Load_use |Cycles stalled waiting for load |
;; |Load_use_RAW |Cycles stalled on some weird internal condition|
;; |IC_ref |I-Cache references |
;; |IC_hit |I-Cache hits |
;; |DC_rd |D-Cache read references |
;; |DC_rd_hit |D-Cache read hits |
;; |DC_wr |D-Cache write references |
;; |DC_wr_hit |D-Cache write hits |
;; |EC_ref |E-Cache references |
;; |EC_hit |E-Cache hits |
;; |EC_write_hit_RDO |See User's guide |
;; |EC_wb |E-Cache misses that do writebacks |
;; |EC_snoop_inv |E-Cache invalidates |
;; |EC_snoop_cb |E-Cache snoop copy-backs |
;; |EC_rd_hit |E-Cache read hits from D-Cache misses |
;; |EC_ic_hit |E-Cache read hits from I-Cache misses |
;; +------------------------------------------------------------------+
;;
;; Some of these event specifiers only work on one of the performance
;; counters (eg on pic1 but not pic0); see cputrack -h for details.
;; from cpc_bind_event(3):
;;
;; Sometimes, even the overhead of performing a system call will be too
;; disruptive to the events being measured. Once a call to
;; cpc_bind_event() has been issued, it is possible to directly access
;; the performance hardware registers from within the application. If the
;; performance counter context is active, then the counters will count on
;; behalf of the current LWP .
;;
;; rd %pic, %rN ! All UltraSPARC
;; wr %rN, %pic ! (ditto, but see text)
;; TODO: add ability to flush the caches, in order to be able to
;; compare cold and warm execution times and CPI values. Convert some
;; of the examples provided with perfmon (matrix multiplication for
;; example).
;;
;; Use the ability of the UltraSPARC-III to signal a trap on overflow
;; of a performance counter.
;; The type of statistics that are useful to obtain include
;;
;; - cycles per instruction (CPI)
;; - decomposition into memory loads and stores
;; - the separate contribution of memory latency to total CPI
;; (depends on the program access pattern and on the memory
;; hierarchy, establishes an upper bound on the possible improvement
;; that could be acheived by using prefetching)
;; - number of prefetches issued but never referenced (measures
;; accuracy of address prediction algorithm)
;; - the number of cache misses per 1000 instructions (with
;; decomposition into i-cache, d-cache etc).
;; - the number of cycles lost due to data and control hazards
;;
;; Benchmarks for C++ workloads on UltraSPARC:
;; <URL:http://www.ece.utexas.edu/~radhakri/hipc98/>
;;
;; http://www.ciar.org/~ttk/public/WRL-TR-93.6.ps
;; http://www.ciar.org/~ttk/public/ilp-limits.WRL-TN-15.ps
;; http://www.ciar.org/~ttk/public/ilp-limits.WRL-TN-15.pdf
(defpackage :cpu-performance-counters
(:nicknames :cpc)
(:use :common-lisp
:alien
:c-call)
(:export #:cpc-init
#:cpc-string-to-event
#:cpc-bind-event
#:cpc-take-sample
#:cpc-trace
#:cpc-free))
(in-package :cpc)
(declaim (optimize (speed 3) (safety 1) (debug 0)))
(eval-when (:load-toplevel :execute)
(sys::load-object-file "/usr/lib/libcpc.so"))
;; /usr/include/sys/time.h
(def-alien-type hrtime_t (alien:integer 64))
(def-alien-routine "gethrtime" hrtime_t)
(def-alien-routine "gethrvtime" hrtime_t)
;; /usr/include/sys/cpc_event.h
(eval-when (:compile-toplevel :load-toplevel :execute)
(def-alien-type cpc_event_t
(struct _cpc_event
(ce_cpuver int)
(ce_hrt hrtime_t)
(ce_tick (alien:unsigned 64))
(ce_pic0 (alien:unsigned 64))
(ce_pic1 (alien:unsigned 64))
(ce_pcr (alien:unsigned 64))))
(def-alien-type p_cpc_event_t (* cpc_event_t)))
(defparameter +cpu-version+ 0)
(eval-when (:compile-toplevel :load-toplevel)
(defconstant +CPC_BIND_LWP_INHERIT+ #x1)
(defconstant +CPC_BIND_EMT_OVF+ #x2)
(defconstant +CPC_ULTRA1+ 1000)
(defconstant +CPC_ULTRA2+ 1001)
(defconstant +CPC_ULTRA3+ 1002)
(defconstant +CPC_ULTRA3_PLUS+ 1003)
(defconstant +CPC_ULTRA3_I+ 1004)
(defconstant +CPC_PENTIUM+ 2000)
(defconstant +CPC_PENTIUM_MMX+ 2001)
(defconstant +CPC_PENTIUM_PRO+ 2002)
(defconstant +CPC_PENTIUM_PRO_MMX+ 2003))
;; /usr/include/libcpc.h
(def-alien-routine ("cpc_version" %cpc_version) unsigned-int (ver unsigned-int))
(def-alien-routine ("cpc_getcpuver" %cpc_getcpuver) int)
(def-alien-routine ("cpc_getusage" %cpc_getusage) c-string
(cpuver int))
(def-alien-routine ("cpc_strtoevent" %cpc_strtoevent) int
(cpuver int)
(spec c-string)
(event (* cpc_event_t)))
(def-alien-routine ("cpc_eventtostr" %cpc_eventtostr) c-string
(event (* cpc_event_t)))
(def-alien-routine ("cpc_access" %cpc_access) int)
(def-alien-routine ("cpc_bind_event" %cpc_bind_event) int
(event (* cpc_event_t))
(flags int))
(def-alien-routine ("cpc_take_sample" %cpc_take_sample) int
(event (* cpc_event_t)))
(def-alien-routine ("cpc_event_accum" %cpc_event_accum) void
(accum (* cpc_event_t))
(event (* cpc_event_t)))
(def-alien-routine ("cpc_event_diff" %cpc_event_diff) void
(diff (* cpc_event_t))
(after (* cpc_event_t))
(before (* cpc_event_t)))
(def-alien-routine ("cpc_count_usr_events" %cpc_count_usr_events) int
(enable int))
(def-alien-routine ("cpc_count_sys_events" %cpc_count_sys_events) int
(enable int))