From ebf74cb05d78fd18a342d50d797601d613864df8 Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Fri, 8 Mar 1991 19:34:24 +0000 Subject: [PATCH] Initial revision --- code/profile.lisp | 544 ++++++++++++++++++++++++++++++++++++++++++ tools/clxcom.lisp | 40 ++++ tools/pclcom.lisp | 19 ++ tools/worldbuild.lisp | 105 ++++++++ 4 files changed, 708 insertions(+) create mode 100644 code/profile.lisp create mode 100644 tools/clxcom.lisp create mode 100644 tools/pclcom.lisp create mode 100644 tools/worldbuild.lisp diff --git a/code/profile.lisp b/code/profile.lisp new file mode 100644 index 000000000..e903d76ea --- /dev/null +++ b/code/profile.lisp @@ -0,0 +1,544 @@ +;;; -*- Mode: Lisp; Package: Profile; Log: profile.log -*- +;;; +;;; This code has been placed in the public domain by the author. +;;; It is distributed without warranty of any kind. +;;; +;;; Description: Simple profiling facility. +;;; +;;; Author: Skef Wholey, Rob MacLachlan +;;; +;;; Current maintainer: Rob MacLachlan +;;; +;;; Address: Carnegie-Mellon University +;;; Computer Science Department +;;; Pittsburgh, PA 15213 +;;; +;;; Net address: ram@cs.cmu.edu +;;; +;;; Copyright status: Public domain. +;;; +;;; Compatibility: Runs in any valid Common Lisp. Three small implementation- +;;; dependent changes can be made to improve performance and prettiness. +;;; +;;; Dependencies: The macro Quickly-Get-Time and the function +;;; Required-Arguments should probably be tailored to the implementation for +;;; the best results. They will default to working, albeit inefficent, forms +;;; in non-CMU implementations. The Total-Consing macro is used to profile +;;; consing: in unknown implementations 0 will be used. +;;; See the "Implementation Parameters" section. +;;; +;;; Note: a timing overhead factor is computed at load time. This will be +;;; incorrect if profiling code is run in a different environment than this +;;; file was loaded in. For example, saving a core image on a high +;;; performance machine and running it on a low performance one will result +;;; in use of an erroneously small timing overhead factor. +;;; +(in-package "PROFILE") + +(export '(*timed-functions* profile unprofile report-time reset-time)) + + +;;;; Implementation dependent interfaces: + +#-new-compiler +(eval-when (compile eval) + (defmacro fdefinition (x) + `(lisp::careful-symbol-function ,x)) + (defsetf fdefinition lisp::set-symbol-function-carefully)) + +(progn + #-cmu + (eval-when (compile eval) + (warn + "You may want to supply an implementation-specific ~ + Quickly-Get-Time function.")) + + (defconstant quick-time-units-per-second internal-time-units-per-second) + + (defmacro quickly-get-time () + `(the time-type (get-internal-run-time)))) + + +;;; The type of the result from quickly-get-time. +#+cmu +(deftype time-type () '(unsigned-byte 29)) +#-cmu +(deftype time-type () 'unsigned-byte) + + +;;; To avoid unnecessary consing in the "encapsulation" code, we find out the +;;; number of required arguments, and use &rest to capture only non-required +;;; arguments. The function Required-Arguments returns two values: the first +;;; is the number of required arguments, and the second is T iff there are any +;;; non-required arguments (e.g. &optional, &rest, &key). + +#+cmu +(progn + #-new-compiler + (defun required-arguments (name) + (let ((function (symbol-function name))) + (if (eql (system:%primitive get-type function) system:%function-type) + (let ((min (ldb system:%function-min-args-byte + (system:%primitive header-ref function + system:%function-min-args-slot))) + (max (ldb system:%function-max-args-byte + (system:%primitive header-ref function + system:%function-max-args-slot))) + (rest (ldb system:%function-rest-arg-byte + (system:%primitive header-ref function + system:%function-rest-arg-slot))) + (key (ldb system:%function-keyword-arg-byte + (system:%primitive + header-ref function + system:%function-keyword-arg-slot)))) + (values min (or (/= min max) (/= rest 0) (/= key 0)))) + (values 0 t)))) + #+(and new-compiler (not pmax)) + (defun required-arguments (name) + (let* ((function (symbol-function name)) + (stype (system:%primitive get-vector-subtype function))) + (if (eql stype system:%function-entry-subtype) + (let* ((args (cadr (system:%primitive + header-ref + function + system:%function-entry-type-slot))) + (pos (position-if #'(lambda (x) + (and (symbolp x) + (let ((name (symbol-name x))) + (and (>= (length name) 1) + (char= (schar name 0) + #\&))))) + args))) + (if pos + (values pos t) + (values (length args) nil))) + (values 0 t)))) + #+(and new-compiler pmax) + (defun required-arguments (name) + (let* ((function (symbol-function name))) + (if (eql (kernel:get-type function) vm:function-header-type) + (let* ((args (cadr (kernel:%function-header-type function))) + (pos (position-if #'(lambda (x) + (and (symbolp x) + (let ((name (symbol-name x))) + (and (>= (length name) 1) + (char= (schar name 0) + #\&))))) + args))) + (if pos + (values pos t) + (values (length args) nil))) + (values 0 t))))) + +#-cmu +(progn + (eval-when (compile eval) + (warn + "You may want to add an implementation-specific Required-Arguments function.")) + (eval-when (load eval) + (defun required-arguments (name) + (declare (ignore name)) + (values 0 t)))) + + + +;;; The Total-Consing macro is called to find the total number of bytes consed +;;; since the beginning of time. + +#+cmu +(defmacro total-consing () '(the consing-type (ext:get-bytes-consed))) + +#-cmu +(progn + (eval-when (compile eval) + (warn "No consing will be reported unless a Total-Consing function is ~ + defined.")) + + (defmacro total-consing () '0)) + + +;;; The type of the result of TOTAL-CONSING. +#+cmu +(deftype consing-type () '(unsigned-byte 29)) +#-cmu +(deftype consing-type () 'unsigned-byte) + + +;;;; Global data structures: + +(defvar *timed-functions* () + "List of functions that are currently being timed.") + +;;; We associate a PROFILE-INFO structure with each profiled function name. +;;; This holds the functions that we call to manipulate the closure which +;;; implements the encapsulation. +;;; +(defvar *profile-info* (make-hash-table :test #'equal)) +(defstruct profile-info + (name nil) + (old-definition nil :type function) + (new-definition nil :type function) + (read-time nil :type function) + (reset-time nil :type function)) + +;;; PROFILE-INFO-OR-LOSE -- Internal +;;; +(defun profile-info-or-lose (name) + (or (gethash name *profile-info*) + (error "~S is not a profiled function." name))) + + +;;; We keep around a bunch of functions that make encapsulations, one of each +;;; (min-args . optional-p) signature we have encountered so far. We also +;;; precompute a bunch of encapsulation functions. +;;; +(defvar *existing-encapsulations* (make-hash-table :test #'equal)) + + +;;; These variables are used to subtract out the time and consing for recursive +;;; and other dynamically nested profiled calls. The total resource consumed +;;; for each nested call is added into the appropriate variable. When the +;;; outer function returns, these amounts are subtracted from the total. +;;; +(defvar *enclosed-time* 0) +(defvar *enclosed-consing* 0) +(defvar *enclosed-profilings* 0) +(proclaim '(type time-type *enclosed-time*)) +(proclaim '(type consing-type *enclosed-consing*)) +(proclaim '(fixnum *enclosed-profilings*)) + + +;;; The number of seconds a bare function call takes. Factored into the other +;;; overheads, but not used for itself. +;;; +(defvar *call-overhead*) + +;;; The number of seconds that will be charged to a profiled function due to +;;; the profiling code. +(defvar *internal-profile-overhead*) + +;;; The number of seconds of overhead for profiling that a single profiled call +;;; adds to the total runtime for the program. +;;; +(defvar *total-profile-overhead*) + +(proclaim '(single-float *call-overhead* *internal-profile-overhead* + *total-profile-overhead*)) + + +;;;; Profile encapsulations: + +(eval-when (compile load eval) + +;;; MAKE-PROFILE-ENCAPSULATION -- Internal +;;; +;;; Return a lambda expression for a function that (when called with the +;;; function name) will set up that function for profiling. +;;; +;;; A function is profiled by replacing its definition with a closure created +;;; by the following function. The closure records the starting time, calls +;;; the original function, and records finishing time. Other closures are used +;;; to perform various operations on the encapsulated function. +;;; +(defun make-profile-encapsulation (min-args optionals-p) + (let ((required-args ())) + (dotimes (i min-args) + (push (gensym) required-args)) + `(lambda (name) + (let* ((time 0) + (count 0) + (consed 0) + (profile 0) + (old-definition (fdefinition name))) + (declare (type time-type time) (type consing-type consed) + (fixnum count)) + (pushnew name *timed-functions*) + + (setf (fdefinition name) + #'(lambda (,@required-args + ,@(if optionals-p + `(&rest optional-args))) + (incf count) + (let ((time-inc 0) (cons-inc 0) (profile-inc 0)) + (declare (type time-type time-inc) + (type consing-type cons-inc) + (fixnum profile-inc)) + (multiple-value-prog1 + (let ((start-time (quickly-get-time)) + (start-consed (total-consing)) + (*enclosed-time* 0) + (*enclosed-consing* 0) + (*enclosed-profilings* 0)) + (multiple-value-prog1 + ,(if optionals-p + `(apply old-definition + ,@required-args optional-args) + `(funcall old-definition ,@required-args)) + (setq time-inc (- (quickly-get-time) start-time)) + (setq cons-inc (- (total-consing) start-consed)) + (setq profile-inc *enclosed-profilings*) + (incf time + (the time-type + (- time-inc *enclosed-time*))) + (incf consed + (the consing-type + (- cons-inc *enclosed-consing*))) + (incf profile profile-inc))) + (incf *enclosed-time* time-inc) + (incf *enclosed-consing* cons-inc) + (incf *enclosed-profilings* + (the fixnum (1+ profile-inc))))))) + + (setf (gethash name *profile-info*) + (make-profile-info + :name name + :old-definition old-definition + :new-definition (fdefinition name) + :read-time + #'(lambda () + (values count time consed profile)) + :reset-time + #'(lambda () + (setq count 0) + (setq time 0) + (setq consed 0) + (setq profile 0) + t))))))) + +); EVAL-WHEN (COMPILE LOAD EVAL) + + +;;; Precompute some encapsulation functions: +;;; +(eval-when (compile eval) + (defconstant precomputed-encapsulations 8)) +;;; +(macrolet ((frob () + (let ((res ())) + (dotimes (i precomputed-encapsulations) + (push `(setf (gethash '(,i . nil) *existing-encapsulations*) + #',(make-profile-encapsulation i nil)) + res) + (push `(setf (gethash '(,i . t) *existing-encapsulations*) + #',(make-profile-encapsulation i t)) + res)) + `(progn ,@res)))) + (frob)) + + + +;;; Interfaces: + +;;; PROFILE-1-FUNCTION -- Internal +;;; +;;; Profile the function Name. If already profiled, unprofile first. +;;; +(defun profile-1-function (name) + (cond ((fboundp name) + (when (gethash name *profile-info*) + (warn "~S already profiled, so unprofiling it first." name) + (unprofile-1-function name)) + (multiple-value-bind (min-args optionals-p) + (required-arguments name) + (funcall (or (gethash (cons min-args optionals-p) + *existing-encapsulations*) + (setf (gethash (cons min-args optionals-p) + *existing-encapsulations*) + (compile nil (make-profile-encapsulation + min-args optionals-p)))) + name))) + (t + (warn "Ignoring undefined function ~S." name)))) + + +;;; PROFILE -- Public +;;; +(defmacro profile (&rest names) + "PROFILE Name* + Wraps profiling code around the named functions. As in TRACE, the names are + not evaluated. If a function is already profiled, then unprofile and + reprofile (useful to notice function redefinition.) If a name is undefined, + then we give a warning and ignore it. See also UNPROFILE, REPORT-TIME and + RESET-TIME." + `(progn + ,@(mapcar #'(lambda (name) + `(profile-1-function ',name)) + names) + (values))) + + +;;; UNPROFILE -- Public +;;; +(defmacro unprofile (&rest names) + "Unwraps the profiling code around the named functions. Names defaults to + the list of all currently profiled functions." + `(dolist (name ,(if names `',names '*timed-functions*) (values)) + (unprofile-1-function name))) + + +;;; UNPROFILE-1-FUNCTION -- Internal +;;; +(defun unprofile-1-function (name) + (let ((info (profile-info-or-lose name))) + (remhash name *profile-info*) + (setq *timed-functions* + (delete name *timed-functions* + :test #'equal)) + (if (eq (fdefinition name) (profile-info-new-definition info)) + (setf (fdefinition name) (profile-info-old-definition info)) + (warn "Preserving current definition of redefined function ~S." + name)))) + + +(defmacro report-time (&rest names) + "Reports the time spent in the named functions. Names defaults to the list of + all currently profiled functions." + `(%report-times ,(if names `',names '*timed-functions*))) + + +(defstruct (time-info + (:constructor make-time-info (name calls time consing))) + name + calls + time + consing) + + +;;; COMPENSATE-TIME -- Internal +;;; +;;; Return our best guess for the run time in a function, subtracting out +;;; factors for profiling overhead. We subtract out the internal overhead for +;;; each call to this function, since the internal overhead is the part of the +;;; profiling overhead for a function that is charged to that function. +;;; +;;; We also subtract out a factor for each call to a profiled function +;;; within this profiled function. This factor is the total profiling overhead +;;; *minus the internal overhead*. We don't subtract out the internal +;;; overhead, since it was already subtracted when the nested profiled +;;; functions subtracted their running time from the time for the encolsing +;;; function. +;;; +(defun compensate-time (calls time profile) + (let ((compensated + (- (/ (float time) (float quick-time-units-per-second)) + (* *internal-profile-overhead* (float calls)) + (* (- *total-profile-overhead* *internal-profile-overhead*) + (float profile))))) + (if (minusp compensated) 0.0 compensated))) + + +(defun %report-times (names) + (let ((info ()) + (no-call ())) + (dolist (name names) + (let ((pinfo (profile-info-or-lose name))) + (unless (eq (fdefinition name) + (profile-info-new-definition pinfo)) + (warn "Function ~S has been redefined, so times may be inaccurate.~@ + PROFILE it again to record calls to the new definition." + name)) + (multiple-value-bind + (calls time consing profile) + (funcall (profile-info-read-time pinfo)) + (if (zerop calls) + (push name no-call) + (push (make-time-info name calls + (compensate-time calls time profile) + consing) + info))))) + + (setq info (sort info #'>= :key #'time-info-time)) + + (format *trace-output* + "~& Seconds | Consed | Calls | Sec/Call | Name:~@ + ------------------------------------------------------~%") + + (let ((total-time 0.0) + (total-consed 0) + (total-calls 0)) + (dolist (time info) + (incf total-time (time-info-time time)) + (incf total-calls (time-info-calls time)) + (incf total-consed (time-info-consing time)) + (format *trace-output* + "~10,3F | ~9:D | ~7:D | ~10,5F | ~S~%" + (time-info-time time) + (time-info-consing time) + (time-info-calls time) + (/ (time-info-time time) (float (time-info-calls time))) + (time-info-name time))) + (format *trace-output* + "------------------------------------------------------~@ + ~10,3F | ~9:D | ~7:D | | Total~%" + total-time total-consed total-calls) + + (format *trace-output* + "~%Estimated total profiling overhead: ~4,2F seconds~%" + (* *total-profile-overhead* (float total-calls)))) + + (when no-call + (format *trace-output* + "~%These functions were not called:~%~{~<~%~:; ~S~>~}~%" + (sort no-call #'string< :key #'symbol-name))) + (values))) + + +(defmacro reset-time (&rest names) + "Resets the time counter for the named functions. Names defaults to the list + of all currently profiled functions." + `(%reset-time ,(if names `',names '*timed-functions*))) + +(defun %reset-time (names) + (dolist (name names) + (funcall (profile-info-reset-time (profile-info-or-lose name)))) + (values)) + + +;;;; Overhead computation. + +;;; We average the timing overhead over this many iterations. +;;; +(defconstant timer-overhead-iterations 5000) + + +;;; COMPUTE-TIME-OVERHEAD-AUX -- Internal +;;; +;;; Dummy function we profile to find profiling overhead. +;;; +(proclaim '(notinline compute-time-overhead-aux)) +(defun compute-time-overhead-aux (x) + (declare (ignore x))) + + +;;; COMPUTE-TIME-OVERHEAD -- Internal +;;; +;;; Initialize the profiling overhead variables. +;;; +(defun compute-time-overhead () + (macrolet ((frob (var) + `(let ((start (quickly-get-time)) + (fun (symbol-function 'compute-time-overhead-aux))) + (dotimes (i timer-overhead-iterations) + (funcall fun fun)) + (setq ,var + (/ (float (- (quickly-get-time) start)) + (float quick-time-units-per-second) + (float timer-overhead-iterations)))))) + (frob *call-overhead*) + + (unwind-protect + (progn + (profile compute-time-overhead-aux) + (frob *total-profile-overhead*) + (decf *total-profile-overhead* *call-overhead*) + (let ((pinfo (profile-info-or-lose 'compute-time-overhead-aux))) + (multiple-value-bind (calls time) + (funcall (profile-info-read-time pinfo)) + (declare (ignore calls)) + (setq *internal-profile-overhead* + (/ (float time) + (float quick-time-units-per-second) + (float timer-overhead-iterations)))))) + (unprofile compute-time-overhead-aux)))) + +(compute-time-overhead) diff --git a/tools/clxcom.lisp b/tools/clxcom.lisp new file mode 100644 index 000000000..6057e2796 --- /dev/null +++ b/tools/clxcom.lisp @@ -0,0 +1,40 @@ +(in-package "USER") + +(proclaim '(optimize (c::debug-info 2))) + +;;; Hide CLOS from CLX, so objects stay implemented as structures. +;;; +(when (find-package "CLOS") + (rename-package (find-package "CLOS") "NO-CLOS-HERE")) +(when (find-package "PCL") + (rename-package (find-package "PCL") "NO-PCL-HERE")) + +#+nil +(unless (find-package "OLD-XLIB") + (when (find-package "XLIB") + (rename-package (find-package "XLIB") "OLD-XLIB")) + + (make-package "XLIB" :use '("LISP"))) + +(with-compiler-log-file ("clx:compile-clx.log") + (let ((c::*suppress-values-declaration* t)) + (comf "clx:defsystem" :load t) + (comf "clx:depdefs" :load t) + (comf "clx:clx" :load t) + (comf "clx:dependent" :load t) + (comf "clx:macros" :load t) ; these are just macros + (comf "clx:bufmac" :load t) ; these are just macros + (comf "clx:buffer" :load t) + (comf "clx:display" :load t) + (comf "clx:gcontext" :load t) + (comf "clx:input" :load t) + (comf "clx:requests" :load t) + (comf "clx:fonts" :load t) + (comf "clx:graphics" :load t) + (comf "clx:text" :load t) + (comf "clx:attributes" :load t) + (comf "clx:translate" :load t) + (comf "clx:keysyms" :load t) + (comf "clx:manager" :load t) + (comf "clx:image" :load t) + (comf "clx:resource" :load t))) diff --git a/tools/pclcom.lisp b/tools/pclcom.lisp new file mode 100644 index 000000000..357fafa7d --- /dev/null +++ b/tools/pclcom.lisp @@ -0,0 +1,19 @@ + +(in-package "USER") + +(setf c:*suppress-values-declaration* t) + +(setf (search-list "pcl:") '("target:pcl/")) + +(let ((obj (make-pathname :defaults "pcl:defsys" + :type (c:backend-fasl-file-type c:*backend*)))) + (when (< (or (file-write-date obj) 0) + (file-write-date "pcl:defsys.lisp")) + (compile-file "pcl:defsys"))) + +(load "pcl:defsys" :verbose t) + +(import 'kernel:funcallable-instance-p (find-package "PCL")) + +(with-compilation-unit () + (pcl::compile-pcl)) diff --git a/tools/worldbuild.lisp b/tools/worldbuild.lisp new file mode 100644 index 000000000..c66840236 --- /dev/null +++ b/tools/worldbuild.lisp @@ -0,0 +1,105 @@ +;;; -*- Mode: Lisp; Package: Lisp -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; Spice Lisp is currently incomplete and under active development. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; When loaded, this file builds a core image from all the .fasl files that +;;; are part of the kernel CMU Common Lisp system. + +(in-package "LISP") + +(defparameter lisp-files + `(,@(when (string= (c:backend-name c:*backend*) "PMAX") + '("target:assembly/mips/assem-rtns.assem" + "target:assembly/mips/array.assem" + "target:assembly/mips/bit-bash.assem" + "target:assembly/mips/arith.assem" + "target:assembly/mips/alloc.assem")) + ,@(when (string= (c:backend-name c:*backend*) "SPARC") + '("target:assembly/sparc/assem-rtns.assem" + "target:assembly/sparc/array.assem" + "target:assembly/sparc/bit-bash.assem" + "target:assembly/sparc/arith.assem" + "target:assembly/sparc/alloc.assem")) + + "target:code/fdefinition" + "target:code/eval" + + "target:code/type-boot" + "target:code/struct" + "target:code/error" + "target:code/salterror" + "target:compiler/type" + "target:compiler/generic/vm-type" + "target:compiler/type-init" + + "target:code/defstruct" + "target:compiler/proclaim" + "target:compiler/globaldb" + "target:code/pred" + + "target:code/kernel" + "target:code/bit-bash" + "target:code/array" + "target:code/char" + "target:code/lispinit" + "target:code/seq" + "target:code/numbers" + "target:code/float" + "target:code/float-trap" + "target:code/irrat" + "target:code/bignum" + "target:code/defmacro" + "target:code/defrecord" + "target:code/list" + "target:code/hash" + "target:code/macros" + "target:code/sysmacs" + "target:code/symbol" + "target:code/string" + "target:code/mipsstrops" + "target:code/misc" + "target:code/gc" + "target:code/extensions" + "target:code/alieneval" + "target:code/c-call" + "target:code/syscall" + "target:code/vm" + "target:code/serve-event" + "target:code/stream" + "target:code/fd-stream" + "target:code/print" + "target:code/format" + "target:code/package" + "target:code/reader" + "target:code/backq" + "target:code/sharpm" + "target:code/load" + "target:code/machdef" + ,@(when (string= (c:backend-name c:*backend*) "PMAX") + '("target:code/pmax-vm" + "target:code/pmax-machdef")) + ,@(when (string= (c:backend-name c:*backend*) "SPARC") + '("target:code/sparc-vm" + "target:code/sparc-machdef")) + "target:code/filesys" + "target:code/search-list" + + "target:code/signal" + "target:code/interr" + "target:code/debug-info" + "target:code/debug-int" + "target:code/debug" + )) + +(setf *genesis-core-name* "target:ldb/kernel.core") +(setf *genesis-c-header-name* "target:ldb/lisp.h") +(setf *genesis-map-name* "target:ldb/lisp.map") +(setf *genesis-symbol-table* "target:ldb/ldb.map") + +(genesis lisp-files) -- GitLab