Skip to content
Snippets Groups Projects

Compare revisions

Changes are shown as if the source revision was being merged into the target revision. Learn more about comparing revisions.

Source

Select target project
No results found

Target

Select target project
  • cmucl/cmucl
  • pfominykh/cmucl
  • yitzchak/cmucl
  • rkreuter/cmucl
  • cshapiro/cmucl
5 results
Show changes
Commits on Source (16)
Showing
with 1802 additions and 1339 deletions
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))
 
......
Source diff could not be displayed: it is too large. Options to address this: view the blob.
This diff is collapsed.
No preview for this file type
......@@ -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))
(def-alien-routine ("cpc_rele" %cpc_rele) int)
(define-condition cpc-condition (condition) ())
(define-condition cpc-error (cpc-condition) ())
(define-condition cpc-unavailable (cpc-error) ())
(define-condition cpc-noaccess (cpc-error) ())
(define-condition cpc-no-such-event (cpc-error) ())
(defun cpc-get-cpu-version ()
(unless (zerop (%cpc_access))
(error 'cpc-noaccess))
(let ((res (%cpc_getcpuver)))
(when (eql -1 res) (error 'cpc-unavailable))
res))
(defun cpc-init ()
(setf +cpu-version+ (cpc-get-cpu-version))
(case +cpu-version+
(#.+cpc_ultra1+ (pushnew :cpc-ultrasparc-1 *features*))
(#.+cpc_ultra2+ (pushnew :cpc-ultrasparc-2 *features*))
(#.+cpc_ultra3+ (pushnew :cpc-ultrasparc-3 *features*))
(#.+cpc_ultra3_i+ (pushnew :cpc-ultrasparc-3i *features*))
(#.+cpc_pentium+ (pushnew :cpc-pentium *features*)))
+cpu-version+)
;; the caller should call CPC-FREE on the returned value
(defun cpc-string-to-event (spec)
(let ((event (make-alien cpc_event_t)))
(unless (zerop (%cpc_strtoevent +cpu-version+ spec event))
(error 'cpc-no-such-event))
event))
(defun cpc-bind-event (event)
(unless (zerop (%cpc_bind_event event 0))
(error 'cpc-error)))
;; this side-effects EVENT
(defun cpc-take-sample (event)
(unless (zerop (%cpc_take_sample event))
(error 'cpc-error)))
(defun cpc-event-diff (diff before after)
(%cpc_event_diff diff before after))
(defun cpc-free (&rest events)
(dolist (e events)
(when (alien::alien-pointer-type-p e)
(free-alien e))))
;;; adapted from code by Derek L Davies <ddavies@world.std.com> posted
;;; to cmucl-help@cons.org on 2000-07-13.
;;; Munged code from CMUCL's multiprocessing START-SIGALRM-YIELD
;;; function. Might be dangerous: needs to be heavily tested.
;;;
;;; Examples:
;;;
;;; (with-timeout (5 (progn (format t "Timed out!~%") 'time-is-up))
;;; (do ((i 0 (+ i 1))) ((> i 3) 'done)
;;; (sleep 3) (format t "hi~%")))
;;; => TIME-IS-UP
;;;
;;; (with-timeout (30 (progn (format t "Timed out!~%") 'time-is-up))
;;; (do ((i 0 (+ i 1))) ((> i 3) 'done)
;;; (sleep 3) (format t "hi~%")))
;;; => DONE
(defvar *nested-with-timeout* nil)
(defmacro with-timeout ((timeout-symbol &rest if-timedout) &rest body)
(let ((catch-tag (gensym))
(secs (gensym))
(usecs (gensym)))
`(unwind-protect
(catch ',catch-tag
(if *nested-with-timeout*
(progn
(format *debug-io* "Nested with-timeout running under CMUCL.")
(setq *nested-with-timeout* nil))
(progn
(prog2
(progn
(setq *nested-with-timeout* t)
;; Disable the gencgc pointer filter to improve interrupt safety.
#+gencgc
(setf (alien:extern-alien "enable_pointer_filter" alien:unsigned) 0)
(flet ((sigalrm-handler (signal code scp)
(declare (ignore signal code scp))
(when (<= lisp::*free-interrupt-context-index* 1)
(progn
(setq *nested-with-timeout* nil)
(throw ',catch-tag (progn ,@if-timedout))))))
(sys:enable-interrupt :sigalrm #'sigalrm-handler))
(multiple-value-bind (,secs ,usecs)
(floor (floor (* 1000000.0 ,timeout-symbol)) 1000000)
(unix:unix-setitimer :real 0 0 ,secs ,usecs)))
(progn ,@body)
;; This resets the timer. If we fail to do this we'll get a throw after
;; we've exited the catch.
(unix:unix-setitimer :real 0 0 0 0)
(setq *nested-with-timeout* nil))))))))
;; Run FUNCTION with ARGS for MAX-SECONDS seconds, and return multiple
;; values delta-pic0 and delta-pic1.
(defun cpc-trace (event-spec function &key (max-seconds 10))
(let ((event (cpc-string-to-event event-spec))
delta-pic0 delta-pic1)
(when (zerop +cpu-version+) (cpc-init))
(with-alien ((before cpc_event_t)
(after cpc_event_t)
(diff cpc_event_t))
(cpc-bind-event event)
(cpc-take-sample (addr before))
(with-timeout (max-seconds 'timeout)
(funcall function))
(cpc-take-sample (addr after))
(cpc-event-diff (addr diff) (addr after) (addr before))
(setf delta-pic0 (alien:slot diff 'ce_pic0))
(setf delta-pic1 (alien:slot diff 'ce_pic1)))
(cpc-free event)
(values delta-pic0 delta-pic1)))
(defvar *pic0* 0)
(defvar *pic1* 0)
(defvar *old-cpc-event* (alien:make-alien cpc_event_t))
(defun cpc-sigalrm-handler (sig code scp)
(declare (ignore sig code scp)
(optimize speed))
(let ((delta-pic0 0)
(delta-pic1 0))
(with-alien ((now cpc_event_t)
(diff cpc_event_t))
(cpc-take-sample (addr now))
(cpc-event-diff (addr diff) (addr now) *old-cpc-event*)
(setf delta-pic0 (alien:slot diff 'ce_pic0))
(setf delta-pic1 (alien:slot diff 'ce_pic1))
;; copy from now to *old-cpc-event*
(dotimes (byte (alien:alien-size cpc_event_t :bytes))
(setf (sys:sap-ref-8 (alien:alien-sap *old-cpc-event*) byte)
(sys:sap-ref-8 (alien:alien-sap now) byte))))
(incf *pic0* delta-pic0)
(incf *pic1* delta-pic1)))
;; different version, that polls the counters every 3 seconds
(defun cpc-trace/poll (event-spec function &key (max-seconds 7))
(let ((event (cpc-string-to-event event-spec))
(elapsed-seconds 0))
(assert (<= 3 max-seconds))
(dotimes (byte (alien:alien-size cpc_event_t :bytes))
(setf (sys:sap-ref-8 (alien:alien-sap *old-cpc-event*) byte) 0))
;; don't set to 0 to avoid division by zero
(setf *pic0* 1
*pic1* 1)
(cpc-bind-event event)
(sys:enable-interrupt :sigvtalrm #'cpc-sigalrm-handler)
(unix:unix-setitimer :virtual 3 0 3 0)
(cpc-take-sample *old-cpc-event*)
(if max-seconds
(with-timeout (max-seconds 'timeout)
(funcall function))
(funcall function))
;; should add an UNWIND-PROTECT
(unix:unix-setitimer :virtual 0 0 0 0)
(sys:ignore-interrupt :sigvtalrm)
(funcall #'cpc-sigalrm-handler 0 0 0)
(cpc-free event))
(values *pic0* *pic1*))
;; some sample uses of the library to calculate various statistics
;; FIXME rewrite these in terms of a wrapper function that adds them to a list of available
;; monitoring functions
(defun calculate-cpi (function)
(cpc-init)
(multiple-value-bind (pic0 pic1)
(funcall #'cpc-trace/poll "pic0=Instr_cnt,pic1=Cycle_cnt" function)
(float (/ pic1 pic0))))
(defun calculate-icache-miss (function)
(cpc-init)
(ecase +cpu-version+
((#.+cpc_ultra1+ #.+cpc_ultra2+)
(multiple-value-bind (pic0 pic1)
(funcall #'cpc-trace/poll "pic0=IC_ref,pic1=IC_hit" function)
(float (/ (- pic0 pic1) pic0))))
((#.+cpc_ultra3+ #.+cpc_ultra3_plus+ #.+cpc_ultra3_i+)
(multiple-value-bind (pic0 pic1)
(funcall #'cpc-trace/poll "pic0=IC_ref,pic1=IC_miss" function)
(float (/ pic1 pic0))))))
(defun calculate-ecache-miss (function)
(cpc-init)
(ecase +cpu-version+
((#.+cpc_ultra1+ #.+cpc_ultra2+)
(multiple-value-bind (pic0 pic1)
(funcall #'cpc-trace/poll "pic0=EC_ref,pic1=EC_hit" function)
(float (/ (- pic0 pic1) pic0))))
((#.+cpc_ultra3+ #.+cpc_ultra3_plus+ #.+cpc_ultra3_i+)
(multiple-value-bind (pic0 pic1)
(funcall #'cpc-trace/poll "pic0=EC_ref,pic1=EC_misses" function)
(float (/ pic1 pic0))))))
;; Counts the proportion of cycles stalled due to the event that no
;; instructions are issued because I-queue is empty from instruction
;; cache miss. This count includes L2-cache miss processing if a
;; L2-cache miss also occurs.
(defun calculate-instruction-stall (function)
(cpc-init)
(multiple-value-bind (pic0 pic1)
(funcall #'cpc-trace/poll "pic0=Dispatch0_IC_miss,pic1=Cycle_cnt" function)
(float (/ pic0 pic1))))
;; Counts the proportion of cycles stalled due to the event that no
;; instructions are issued because I-queue is empty due to branch
;; misprediction.
(defun calculate-mispredict-stall (function)
(cpc-init)
(multiple-value-bind (pic0 pic1)
(funcall #'cpc-trace/poll "pic0=Cycle_cnt,pic1=Dispatch0_mispred" function)
(float (/ pic1 pic0))))
(defun calculate-load-stall (function)
(cpc-init)
(ecase +cpu-version+
((#.+cpc_ultra1+ #.+cpc_ultra2+)
(multiple-value-bind (pic0 pic1)
(funcall #'cpc-trace/poll "pic0=Load_use,pic1=Cycle_cnt" function)
(float (/ pic0 pic1))))
;; Rstall_IU_use is the number of cycles stalled because the
;; processor was waiting for an integer value to be generated.
;; There is also a corresponding Rstall_FP_use counter, which we ignore here.
((#.+cpc_ultra3+ #.+cpc_ultra3_plus+ #.+cpc_ultra3_i+)
(multiple-value-bind (pic0 pic1)
(funcall #'cpc-trace/poll "pic0=Rstall_IU_use,pic1=Cycle_cnt" function)
(float (/ pic0 pic1))))))
;; FIXME on US-III want to know Re_DC_miss for L1 & L2 cache misses
;; mostly uninteresting: this is always very close to 0
(defun calculate-stob-stall (function)
(cpc-init)
(case +cpu-version+
((#.+cpc_ultra1+ #.+cpc_ultra2+)
(multiple-value-bind (pic0 pic1)
(funcall #'cpc-trace/poll "pic0=Dispatch0_storeBuf,pic1=Cycle_cnt" function)
(float (/ pic0 pic1))))))
;; approximately 90 cycles are required to handle a TLB miss on an UltraSPARC III processor
(defun calculate-DTLB-miss (function)
(cpc-init)
(ecase +cpu-version+
((#.+cpc_ultra3+ #.+cpc_ultra3_plus+ #.+cpc_ultra3_i+)
(multiple-value-bind (pic0 pic1)
(funcall #'cpc-trace/poll "pic0=DTLB_miss,pic1=Cycle_cnt" function)
(float (/ pic0 pic1))))))
;; D-Cache Miss Rate = 0.000058 <- L1 cache miss
;; L2 miss rate = 0.024860 <- L2 cache miss
;; FP Stall rate = 0.286592 <- float pipeline stalls
;; DTLB miss rate = 0.299275 <- TLB misses rate (30%)
;; FLOPS = 2157.783478 <- float operations per second
;; elapsed time = 85.420990 secs <- total time to run
;;
;;
;; pic0=DC_rd,pic1=DC_wr_miss
;; pic0=DC_wr,pic1=DC_wr_miss
;; pic1=Rstall_FP_use,pic0=Cycle_cnt
;; FM_pipe_completion,pic0=FA_pipe_completion (FLOPS)
;; === for UltraSPARC II ==
;;
;; event0: Cycle_cnt Instr_cnt Dispatch0_IC_miss IC_ref DC_rd DC_wr
;; EC_ref EC_snoop_inv Dispatch0_storeBuf Load_use
;; EC_write_hit_RDO EC_rd_hit
;;
;; event1: Cycle_cnt Instr_cnt Dispatch0_mispred EC_wb EC_snoop_cb
;; Dispatch0_FP_use IC_hit DC_rd_hit DC_wr_hit Load_use_RAW
;; EC_hit EC_ic_hit
;;
;; === UltraSPARC III events ==
;;
;; event0: Cycle_cnt Instr_cnt Dispatch0_IC_miss IC_ref DC_rd DC_wr
;; EC_ref EC_snoop_inv Dispatch0_br_target Dispatch0_2nd_br
;; Rstall_storeQ Rstall_IU_use EC_write_hit_RTO EC_rd_miss
;; PC_port0_rd SI_snoop SI_ciq_flow SI_owned SW_count_0
;; IU_Stat_Br_miss_taken IU_Stat_Br_count_taken
;; Dispatch_rs_mispred FA_pipe_completion MC_reads_0
;; MC_reads_1 MC_reads_2 MC_reads_3 MC_stalls_0 MC_stalls_2
;;
;; event1: Cycle_cnt Instr_cnt Dispatch0_mispred EC_wb EC_snoop_cb
;; IC_miss_cancelled Re_endian_miss Re_FPU_bypass Re_DC_miss
;; Re_EC_miss IC_miss DC_rd_miss DC_wr_miss Rstall_FP_use
;; EC_misses EC_ic_miss Re_PC_miss ITLB_miss DTLB_miss WC_miss
;; WC_snoop_cb WC_scrubbed WC_wb_wo_read PC_soft_hit
;; PC_snoop_inv PC_hard_hit PC_port1_rd SW_count_1
;; IU_Stat_Br_miss_untaken IU_Stat_Br_count_untaken
;; PC_MS_misses MC_writes_0 MC_writes_1 MC_writes_2
;; MC_writes_3 MC_stalls_1 MC_stalls_3 Re_RAW_miss
;; FM_pipe_completion
;;
;; EOF
......@@ -7,7 +7,7 @@
(require :clx)
(defsystem :demos
(defsystem :contrib-demos
:name "demos"
:maintainer "CMU Common Lisp Group"
:licence "Public Domain"
......
......@@ -2,7 +2,7 @@
(in-package :asdf)
(defsystem :embedded-c
(defsystem :contrib-embedded-c
:name "embedded-c"
:author "Helmut Eller"
:license "Public Domain"
......
......@@ -2,12 +2,12 @@
(in-package :asdf)
(defsystem :follows-mouse
(defsystem :contrib-follows-mouse
:name "follows-mouse"
:maintainer "Todd Kaufman"
:licence "Public Domain"
:long-description "This Hemlock customization causes Hemlock's current window to be set to
whatever Hemlock window the mouse enters, except the echo area."
whatever Hemlock window the mouse enters, except the echo area.
of the X Window System."
:components
((:file "follow-mouse")))
......
......@@ -9,8 +9,10 @@
;;; feebs.
;;;
(in-package "SAMPLE-BRAINS" :use '("LISP" "FEEBS"))
(defpackage "SAMPLE-BRAINS"
(:use "LISP" "FEEBS"))
(in-package "SAMPLE-BRAINS")
;;; Experimental brain. Like the built-in conservative brain, but without the
;;; range limitation.
......
......@@ -2,9 +2,9 @@
(in-package :asdf)
(defsystem :feebs
(defsystem :contrib-games-feebs
:name "feebs"
:description "Planet of the Feebs. A somewhat educational simulation game."
:components
((:file "feebs")
(:file "brains")))
\ No newline at end of file
(:file "brains" :depends-on ("feebs"))))
......@@ -2,7 +2,7 @@
(in-package :asdf)
(defsystem :hist
(defsystem :contrib-hist
:name "hist"
:maintainer "Scott E. Fahlman"
:licence "Public Domain"
......
......@@ -23,6 +23,9 @@
;;; Dependencies: Depends only on standard Common Lisp facilities.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defpackage "HIST"
(:use "COMMON-LISP")
(in-package "HIST")
(export '(hist hist-record))
......
......@@ -2,7 +2,7 @@
(in-package :asdf)
(defsystem :ops
(defsystem :contrib-ops
:name "ops"
:licence "Public Domain"
:description "MIT Regression Tester"
......
......@@ -20,7 +20,8 @@
;;;; modules. This must be loaded first so commonlisp systems that
;;;; expand macros early have them available.
(unless (find-package "OPS") (make-package "OPS"))
(defpackage "OPS"
(:use "COMMON-LISP"))
(in-package "OPS")
......
;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
(in-package :asdf)
(defsystem :contrib-packed-sse2
:name "cmu-packed-sse2"
:maintainer "Cmucl project"
:licence "Public Domain"
:long-description "Functions to work with packed SSE2 objects"
:components
((:file "packed-sse2")))
......@@ -2,7 +2,7 @@
(in-package :asdf)
(defsystem :psgraph
(defsystem :contrib-psgraph
:name "PSGrapher"
:author "Joseph Bates et al."
:licence "Public Domain"
......