--- /dev/null
+#
+# This makefile handles these tasks:
+# . production of pcsdld.sl
+# . installation in scheme library
+#
+# It does not handle the compilation of scheme files.
+
+#SCHEME_ROOT=..
+SCHEME_ROOT=/scheme/8.0/700
+INSTALL_DIRECTORY=$(SCHEME_ROOT)/lib/pcsample
+
+SCHEME_OBJECTS = load.com pcsboot.com pcsdisp.com pcsiproc.com \
+ pcsample.com pcscobl.com pcsintrp.com pribinut.com
+
+pcsdld.sl: pcsdld.o
+ ld -b -o pcsdld.sl pcsdld.o
+
+pcsdld.o: pcsdld.c pcsample.c pcscobl.c pcsiproc.c
+ cc -c -O -Ae +z -I$(SCHEME_ROOT) -DMIT_SCHEME -D_HPUX pcsdld.c
+
+install: pcsdld.sl $(SCHEME_OBJECTS) pcs.bco pcs.bld
+ -mkdir $(INSTALL_DIRECTORY)
+ cp pcsdld.sl $(INSTALL_DIRECTORY)
+ cp pcs.bco pcs.bld *.com *.bci $(INSTALL_DIRECTORY)
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: load.scm,v 1.1 1995/07/28 14:14:08 adams Exp $
+
+Copyright (c) 1995 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; System Packaging
+
+(declare (usual-integrations))
+\f
+(package/system-loader "pcs" '() 'QUERY)
+(add-system! (make-system "PC Sampler" 1 0 '()))
+
+(let ()
+ (define (package-initialize package-name
+ #!optional procedure-name mandatory?)
+ (let ((procedure-name
+ (if (default-object? procedure-name)
+ 'INITIALIZE-PACKAGE!
+ procedure-name))
+ (mandatory?
+ (or (default-object? mandatory?) mandatory?)))
+ (define (print-name string)
+ (display "\n")
+ (display string)
+ (display " (")
+ (let loop ((name package-name))
+ (if (not (null? name))
+ (begin
+ (if (not (eq? name package-name))
+ (display " "))
+ (display (system-pair-car (car name)))
+ (loop (cdr name)))))
+ (display ")"))
+
+ (define (package-reference name)
+ (package/environment (find-package name)))
+
+ (let ((env (package-reference package-name)))
+ (cond ((not procedure-name))
+ ((not (lexical-unreferenceable? env procedure-name))
+ (print-name "initialize:")
+ (if (not (eq? procedure-name 'INITIALIZE-PACKAGE!))
+ (begin
+ (display " [")
+ (display (system-pair-car procedure-name))
+ (display "]")))
+ ((lexical-reference env procedure-name)))
+ ((not mandatory?)
+ (print-name "* skipping:"))
+ (else
+ ;; Missing mandatory package! Report it and die.
+ (print-name "Package")
+ (display " is missing initialization procedure ")
+ (display (system-pair-car procedure-name))
+ (error "Could not initialize a required package."))))))
+
+ (for-each package-initialize
+ '((pribinut)
+ (pc-sample interrupt-handler)
+ (pc-sample)
+ (pc-sample interp-procs)
+ (pc-sample code-blocks)
+ (pc-sample display))))
+;;; fini
+
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: pcs.cbf,v 1.1 1995/07/28 14:14:08 adams Exp $
+
+Copyright (c) 1995 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+(fluid-let ((compiler:coalescing-constant-warnings? #f))
+ (compile-directory "."))
+
+(display "
+
+Remember to use `make -install' to copy compiled files to library directory.
+
+")
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: pcs.pkg,v 1.1 1995/07/28 14:14:08 adams Exp $
+
+Copyright (c) 1995 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; PC Sampler System Packaging
+
+(global-definitions "../runtime/runtime")
+
+
+(define-package (pribinut)
+ (files "pribinut")
+ (parent ())
+ (export (pc-sample)
+ get-primitive-name
+ get-builtin-name
+ get-utility-name
+ get-primitive-count
+ get-builtin-count
+ get-utility-count)
+ (initialization (initialize-package!)))
+
+
+(define-package (pc-sample interrupt-handler)
+ (files "pcsboot" "pcsintrp")
+ (parent ())
+ (import (runtime interrupt-handler)
+ index:interrupt-vector
+ index:interrupt-mask-vector)
+ (export () ; export only because boot.scm does too
+ interrupt-bit/IPPB-flush
+ interrupt-bit/IPPB-extend
+ interrupt-bit/PCBPB-flush
+ interrupt-bit/PCBPB-extend
+ interrupt-bit/HCBPB-flush
+ interrupt-bit/HCBPB-extend)
+ (initialization (initialize-package!)))
+\f
+(define-package (pc-sample)
+ (files "pcsample")
+ (parent ())
+ (export ()
+ *pc-sample/sample-sampler?*
+ *pc-sample/noisy?*
+ pc-sample/init
+ pc-sample/start
+ pc-sample/stop
+ pc-sample/state
+ pc-sample/uninitialized?
+ pc-sample/initialized?
+ pc-sample/running?
+ pc-sample/started?
+ pc-sample/stopped?
+ pc-sample/sample-interval
+ pc-sample/set-sample-interval
+ pc-sample/default-sample-interval
+ pc-sample/fixed-objects
+ pc-sample/builtin-table
+ pc-sample/utility-table
+ pc-sample/primitive-table
+ pc-sample/prob-comp-table
+ pc-sample/UFO-table
+ pc-sample/purified-code-block-block-buffer
+ pc-sample/purified-code-block-offset-buffer
+ pc-sample/heathen-code-block-block-buffer
+ pc-sample/heathen-code-block-offset-buffer
+ pc-sample/interp-proc-buffer
+ pc-sample/status
+ pc-sample/status/previous
+ pc-sample/builtin/status
+ pc-sample/utility/status
+ pc-sample/primitive/status
+ pc-sample/code-block/status
+ pc-sample/code-block-buffer/status
+ pc-sample/interp-proc/status
+ pc-sample/interp-proc-buffer/status
+ pc-sample/prob-comp/status
+ pc-sample/UFO/status
+ pc-sample/reset
+ pc-sample/builtin/reset
+ pc-sample/utility/reset
+ pc-sample/primitive/reset
+ pc-sample/code-block/reset
+ pc-sample/purified-code-block/reset
+ pc-sample/heathen-code-block/reset
+ pc-sample/interp-proc/reset
+ pc-sample/prob-comp/reset
+ pc-sample/UFO/reset
+ pc-sample/enable
+ pc-sample/builtin/enable
+ pc-sample/utility/enable
+ pc-sample/primitive/enable
+ pc-sample/code-block/enable
+ pc-sample/purified-code-block/enable
+ pc-sample/heathen-code-block/enable
+ pc-sample/interp-proc/enable
+ pc-sample/prob-comp/enable
+ pc-sample/UFO/enable
+ pc-sample/disable
+ pc-sample/builtin/disable
+ pc-sample/utility/disable
+ pc-sample/primitive/disable
+ pc-sample/code-block/disable
+ pc-sample/purified-code-block/disable
+ pc-sample/heathen-code-block/disable
+ pc-sample/interp-proc/disable
+ pc-sample/prob-comp/disable
+ pc-sample/UFO/disable
+ call-with-pc-sampling
+ call-with-builtin-pc-sampling
+ call-with-utility-pc-sampling
+ call-with-primitive-pc-sampling
+ call-with-code-block-pc-sampling
+ call-with-interp-proc-pc-sampling
+ call-with-prob-comp-pc-sampling
+ call-with-UFO-pc-sampling
+ with-pc-sampling
+ with-builtin-pc-sampling
+ with-utility-pc-sampling
+ with-primitive-pc-sampling
+ with-code-block-pc-sampling
+ with-interp-proc-pc-sampling
+ with-prob-comp-pc-sampling
+ with-UFO-pc-sampling
+ call-without-pc-sampling
+ call-without-builtin-pc-sampling
+ call-without-utility-pc-sampling
+ call-without-primitive-pc-sampling
+ call-without-code-block-pc-sampling
+ call-without-interp-proc-pc-sampling
+ call-without-prob-comp-pc-sampling
+ call-without-UFO-pc-sampling
+ without-pc-sampling
+ without-builtin-pc-sampling
+ without-utility-pc-sampling
+ without-primitive-pc-sampling
+ without-code-block-pc-sampling
+ without-interp-proc-pc-sampling
+ without-prob-comp-pc-sampling
+ without-UFO-pc-sampling
+ call-with-absolutely-no-pc-sampling
+ call-with-absolutely-no-builtin-pc-sampling
+ call-with-absolutely-no-utility-pc-sampling
+ call-with-absolutely-no-primitive-pc-sampling
+ call-with-absolutely-no-code-block-pc-sampling
+ call-with-absolutely-no-interp-proc-pc-sampling
+ call-with-absolutely-no-prob-comp-pc-sampling
+ call-with-absolutely-no-UFO-pc-sampling
+ with-absolutely-no-pc-sampling
+ with-absolutely-no-builtin-pc-sampling
+ with-absolutely-no-utility-pc-sampling
+ with-absolutely-no-primitive-pc-sampling
+ with-absolutely-no-code-block-pc-sampling
+ with-absolutely-no-interp-proc-pc-sampling
+ with-absolutely-no-prob-comp-pc-sampling
+ with-absolutely-no-UFO-pc-sampling
+ )
+ (export (pc-sample interp-procs)
+ pc-sample/set-state!
+ make-profile-hash-table
+ profile-hash-table-car
+ profile-hash-table-cdr
+ pc-sample/interp-proc-buffer/make
+ fixed-interp-proc-profile-buffer/disable
+ fixed-interp-proc-profile-buffer/install
+ )
+ (export (pc-sample code-blocks)
+ pc-sample/set-state!
+ make-profile-hash-table
+ profile-hash-table-car
+ profile-hash-table-cdr
+ pc-sample/code-block-buffer/make/purified-blocks
+ pc-sample/code-block-buffer/make/purified-offsets
+ pc-sample/code-block-buffer/make/heathen-blocks
+ pc-sample/code-block-buffer/make/heathen-offsets
+ fixed-purified-code-block-profile-buffers/install
+ fixed-heathen-code-block-profile-buffers/install
+ fixed-purified-code-block-profile-buffers/disable
+ fixed-heathen-code-block-profile-buffers/disable
+ )
+
+ (export (pc-sample display)
+ get-builtin-name
+ get-utility-name
+ pc-sample/interp-proc-table
+ pc-sample/code-block-table
+ profile-hash-table-car
+ profile-hash-table-cdr
+ pc-sample/status/builtin-table
+ pc-sample/status/interp-proc-buffer/status
+ pc-sample/status/interp-proc-table
+ pc-sample/status/code-block-buffer/status
+ pc-sample/status/code-block-table
+ pc-sample/status/primitive-table
+ pc-sample/status/prob-comp-table
+ pc-sample/status/UFO-table
+ pc-sample/status/utility-table
+ )
+ (initialization (initialize-package!)))
+
+
+
+
+(define-package (pc-sample interp-procs)
+ (files "pcsiproc")
+ (parent (pc-sample))
+ (export () ; monitor buffer evolution... for now
+ interp-proc-profiling-disabled?
+ interp-proc-profile-buffer/status
+ interp-proc-profile-buffer/status/previous
+ interp-proc-profile-buffer/length
+ interp-proc-profile-buffer/slack
+ interp-proc-profile-buffer/slack-increment
+ interp-proc-profile-buffer/set-slack
+ interp-proc-profile-buffer/set-slack-increment
+ interp-proc-profile-buffer/extend-noisy?
+ interp-proc-profile-buffer/flush-noisy?
+ interp-proc-profile-buffer/overflow-noisy?
+ interp-proc-profile-buffer/extend-noisy?/toggle!
+ interp-proc-profile-buffer/flush-noisy?/toggle!
+ interp-proc-profile-buffer/overflow-noisy?/toggle!
+ interp-proc-profile-buffer/with-extend-notification!
+ interp-proc-profile-buffer/with-flush-notification!
+ interp-proc-profile-buffer/with-overflow-notification!
+ interp-proc-profile-buffer/extend-count?
+ interp-proc-profile-buffer/flush-count?
+ interp-proc-profile-buffer/overflow-count?
+ interp-proc-profile-buffer/extend-count?/toggle!
+ interp-proc-profile-buffer/flush-count?/toggle!
+ interp-proc-profile-buffer/overflow-count?/toggle!
+ interp-proc-profile-buffer/with-extend-count!
+ interp-proc-profile-buffer/with-flush-count!
+ interp-proc-profile-buffer/with-overflow-count!
+ interp-proc-profile-buffer/extend-count
+ interp-proc-profile-buffer/flush-count
+ interp-proc-profile-buffer/overflow-count
+ interp-proc-profile-buffer/extend-count/reset
+ interp-proc-profile-buffer/flush-count/reset
+ interp-proc-profile-buffer/overflow-count/reset
+ )
+ (export (pc-sample interrupt-handler)
+ interp-proc-profile-buffer/flush
+ interp-proc-profile-buffer/extend
+ )
+ (export (pc-sample)
+ interp-proc-profile-table ; probably a kludge
+ interp-proc-profile-table/old
+ interp-proc-profile-table/reset
+ interp-proc-profile-table/enable
+ interp-proc-profile-table/disable
+ interp-proc-profile-buffer/status
+ interp-proc-profile-buffer/status/previous
+ )
+ (export (pc-sample display)
+ interp-proc-profile-datum/count
+ )
+ (initialization (initialize-package!)))
+
+(define-package (pc-sample code-blocks)
+ (files "pcscobl")
+ (parent (pc-sample))
+ (import (runtime compiler-info)
+ compiled-code-block/dbg-info
+ dbg-info?
+ dbg-info/procedures
+ dbg-procedure/label-offset)
+ (export () ; monitor buffer evolution... for now
+ compiled-code-block/trampoline?
+ trampoline/return-to-interpreter?
+ code-block-profiling-disabled?
+ code-block-profile-buffer/status
+ code-block-profile-buffer/status/previous
+ purified-trampoline-profile-table
+ heathen-trampoline-profile-table
+ purified-code-block-profile-buffer/length
+ heathen-code-block-profile-buffer/length
+ purified-code-block-profile-buffer/slack
+ heathen-code-block-profile-buffer/slack
+ purified-code-block-profile-buffer/slack-increment
+ heathen-code-block-profile-buffer/slack-increment
+ purified-code-block-profile-buffer/set-slack
+ heathen-code-block-profile-buffer/set-slack
+ purified-code-block-profile-buffer/set-slack-increment
+ heathen-code-block-profile-buffer/set-slack-increment
+ purified-code-block-profile-buffer/extend-noisy?
+ heathen-code-block-profile-buffer/extend-noisy?
+ purified-code-block-profile-buffer/flush-noisy?
+ heathen-code-block-profile-buffer/flush-noisy?
+ purified-code-block-profile-buffer/overflow-noisy?
+ heathen-code-block-profile-buffer/overflow-noisy?
+ purified-code-block-profile-buffer/extend-noisy?/toggle!
+ heathen-code-block-profile-buffer/extend-noisy?/toggle!
+ purified-code-block-profile-buffer/flush-noisy?/toggle!
+ heathen-code-block-profile-buffer/flush-noisy?/toggle!
+ purified-code-block-profile-buffer/overflow-noisy?/toggle!
+ heathen-code-block-profile-buffer/overflow-noisy?/toggle!
+ purified-code-block-profile-buffer/with-extend-notification!
+ heathen-code-block-profile-buffer/with-extend-notification!
+ purified-code-block-profile-buffer/with-flush-notification!
+ heathen-code-block-profile-buffer/with-flush-notification!
+ purified-code-block-profile-buffer/with-overflow-notification!
+ heathen-code-block-profile-buffer/with-overflow-notification!
+ purified-code-block-profile-buffer/extend-count?
+ heathen-code-block-profile-buffer/extend-count?
+ purified-code-block-profile-buffer/flush-count?
+ heathen-code-block-profile-buffer/flush-count?
+ purified-code-block-profile-buffer/overflow-count?
+ heathen-code-block-profile-buffer/overflow-count?
+ purified-code-block-profile-buffer/extend-count?/toggle!
+ heathen-code-block-profile-buffer/extend-count?/toggle!
+ purified-code-block-profile-buffer/flush-count?/toggle!
+ heathen-code-block-profile-buffer/flush-count?/toggle!
+ purified-code-block-profile-buffer/overflow-count?/toggle!
+ heathen-code-block-profile-buffer/overflow-count?/toggle!
+ purified-code-block-profile-buffer/with-extend-count!
+ heathen-code-block-profile-buffer/with-extend-count!
+ purified-code-block-profile-buffer/with-flush-count!
+ heathen-code-block-profile-buffer/with-flush-count!
+ purified-code-block-profile-buffer/with-overflow-count!
+ heathen-code-block-profile-buffer/with-overflow-count!
+ purified-code-block-profile-buffer/extend-count
+ heathen-code-block-profile-buffer/extend-count
+ purified-code-block-profile-buffer/flush-count
+ heathen-code-block-profile-buffer/flush-count
+ purified-code-block-profile-buffer/overflow-count
+ heathen-code-block-profile-buffer/overflow-count
+ purified-code-block-profile-buffer/extend-count/reset
+ heathen-code-block-profile-buffer/extend-count/reset
+ purified-code-block-profile-buffer/flush-count/reset
+ heathen-code-block-profile-buffer/flush-count/reset
+ purified-code-block-profile-buffer/overflow-count/reset
+ heathen-code-block-profile-buffer/overflow-count/reset)
+ (export (pc-sample interrupt-handler)
+ purified-code-block-profile-buffer/flush
+ purified-code-block-profile-buffer/extend
+ heathen-code-block-profile-buffer/flush
+ heathen-code-block-profile-buffer/extend)
+ (export (pc-sample)
+ code-block-profile-table ; probably a kludge
+ code-block-profile-table/old
+ code-block-profile-tables/reset
+ code-block-profile-tables/enable
+ code-block-profile-tables/disable
+ purified-code-block-profile-tables/reset
+ purified-code-block-profile-tables/enable
+ purified-code-block-profile-tables/disable
+ heathen-code-block-profile-tables/reset
+ heathen-code-block-profile-tables/enable
+ heathen-code-block-profile-tables/disable
+ code-block-profile-buffer/status
+ code-block-profile-buffer/status/previous
+ )
+ (export (pc-sample display)
+ code-block-profile-datum/count
+ )
+ (initialization (initialize-package!)))
+
+
+
+
+
+(define-package (pc-sample display)
+ (files "pcsdisp")
+ (parent (pc-sample))
+ (import (runtime compiler-info)
+ special-form-procedure-name?
+ dbg-info?
+ dbg-procedure?
+ compiled-code-block/filename-and-index
+ compiled-entry/filename-and-index
+ )
+ (export ()
+ pc-sample/status/display
+ pc-sample/builtin/status/display
+ pc-sample/utility/status/display
+ pc-sample/primitive/status/display
+ pc-sample/code-block/status/display
+ pc-sample/interp-proc/status/display
+ pc-sample/prob-comp/status/display
+ pc-sample/UFO/status/display
+ pc-sample/builtin/display-acate
+ pc-sample/utility/display-acate
+ pc-sample/primitive/display-acate
+ pc-sample/code-block/display-acate
+ pc-sample/interp-proc/display-acate
+ pc-sample/prob-comp/display-acate
+ pc-sample/UFO/display-acate
+ pc-sample/purified-trampoline/display-acate
+ pc-sample/heathen-trampoline/display-acate
+ pc-sample/status/table
+ pc-sample/builtin/status/table
+ pc-sample/utility/status/table
+ pc-sample/primitive/status/table
+ pc-sample/code-block/status/table
+ pc-sample/interp-proc/status/table
+ pc-sample/prob-comp/status/table
+ pc-sample/UFO/status/table
+ pc-sample/purified-trampoline/status/table
+ pc-sample/heathen-trampoline/status/table
+ with-pc-sample-displayacation-status
+ *nonmeaningful-procedure-names*
+ *pc-sample/default-status-displayer*
+ with-pc-sample-default-status-displayer
+ )
+ (initialization (initialize-package!)))
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: pcs.sf,v 1.1 1995/07/28 14:14:08 adams Exp $
+
+Copyright (c) 1995 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+(fluid-let ((sf/default-syntax-table syntax-table/system-internal))
+ (sf-directory "."))
+
+(load-option 'CREF)
+
+(cref/generate-constructors "pcs")
+(sf "pcs.con" "pcs.bco")
+(sf "pcs.ldr" "pcs.bld")
--- /dev/null
+/* -*-C-*-
+
+$Id: pcsample.c,v 1.1 1995/07/28 14:14:08 adams Exp $
+
+Copyright (c) 1990-1995 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+/* PCSAMPLE.C -- defines the PC Sample subroutines for UNIX implementations */
+
+/*****************************************************************************/
+#ifdef REALLY_INCLUDE_PROFILE_CODE /* scan_defines concession */
+\f
+/*!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*\
+ * TODO:
+ *
+ * - The mumble_index func ptrs can be avoided via macro passing?!
+ * - Maybe macro-ize/in-line code:
+ * PC_SAMPLE
+ * PC_SAMPLE_RECORD
+ * PC_SAMPLE_UPDATE_BI_BUFFER (after merging out paranoia & verbosity)
+ * PC_SAMPLE_RECORD_TABLE_ENTRY and some others?
+ * PC_SAMPLE_SPILL_GC_SAMPLES_INTO_PRIMITIVE_TABLE
+ *
+\*!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*/
+\f
+
+#include <microcode/ux.h> /* UNIX bullocks */
+#include <microcode/osenv.h> /* For profile_timer_set/clear */
+#include <microcode/config.h> /* For TRUE/FALSE & true/false */
+#include <microcode/scheme.h>
+#include <microcode/uxtrap.h> /* UNIX trap handlers */
+#include <microcode/uxsig.h> /* For DEFUN_STD_HANDLER */
+#include <microcode/prims.h> /* For DEFINE_PRIMITIVE */
+#include <microcode/cmpintmd.h> /* Compiled code interface macros */
+
+#ifdef HAVE_ITIMER /* No interrupt timer ==> no PC sampling */
+
+/*****************************************************************************
+ * Very crude, brute force enable/disable key switch ... KERCHUNK! Debuggery */
+
+static volatile Boolean pc_sample_halted = true ;
+static volatile clock_t profile_interval = 0 ; /* one-shot interval */
+
+/*---------------------------------------------------------------------------*/
+static void
+DEFUN (OS_pc_sample_timer_set, (first, interval),
+ clock_t first AND
+ clock_t interval)
+{
+ /* The profile trap handler will issue another one-shot triggering
+ * of the prof timer once it has handled the pending profile request.
+ * This assures that the profile interval cannot be so small as
+ * to cause PROF triggers to deluge the system.
+ */
+
+ Tsignal_handler_result sighnd_profile() ; /* See uxtrap.c section */
+
+ {
+ OS_profile_timer_clear (); /* ``Cease fire!'' while reset */
+ pc_sample_halted = false; /* clear internal state flag */
+ profile_interval = interval; /* trap handler re-arms @ interval */
+ activate_handler (SIGPROF, ((Tsignal_handler) sighnd_profile));
+ /* in case deactivated */
+ OS_profile_timer_set (first, ((clock_t) 0)); /* Open fire! (one shot) */
+ }
+
+#if ( defined(PCS_LOG_TIMER_DELTA) /* Profile gestalt debuggery */ \
+ || defined(PCS_LOG_TIMER_SET) \
+ )
+ outf_console ("0x%x ", profile_interval) ;
+ outf_flush_console () ;
+#endif
+}
+
+static void
+DEFUN_VOID (OS_pc_sample_timer_clear)
+{
+ long old_mask = sigblock (sigmask (SIGPROF)); /* atomic wrt sigprof */
+ {
+ OS_profile_timer_clear () ; /* ``Cease fire!'' */
+ deactivate_handler (SIGPROF) ; /* disable handler */
+ pc_sample_halted = true ; /* set internal state flag */
+ profile_interval = ((clock_t) 0); /* disable re-triggers too */
+ }
+ (void) sigblock (old_mask) ; /* end atomic wrt sigprof */
+
+#if ( defined(PCS_LOG_TIMER_DELTA) /* Profile gestalt debuggery */ \
+ || defined(PCS_LOG_TIMER_CLEAR) \
+ )
+ outf_console ("-\n") ;
+ outf_flush_console () ;
+#endif
+
+}
+\f
+
+/*****************************************************************************/
+#if !defined(HAVE_SIGCONTEXT) || !defined(HAS_COMPILER_SUPPORT) || defined(USE_STACKLETS)
+/*---------------------------------------------------------------------------*/
+
+static void
+DEFUN (profile_trap_handler, (scp), struct FULL_SIGCONTEXT * scp)
+{
+ /* Cannot recover PC w/o sigcontext (?) so nothing to sample */
+
+#ifndef PCS_TACIT_NO_TRAP
+ outf_error ("\nProfile trap handler called but is non-existent.\n") ;
+ outf_flush_error () ;
+#endif
+
+ return;
+}
+
+#else /* HAVE_SIGCONTEXT and HAS_COMPILER_SUPPORT and not USE_STACKLETS */
+
+#define essential_profile_trap_handler(scp) do \
+{ \
+ extern void EXFUN (pc_sample, (struct FULL_SIGCONTEXT *)); \
+ \
+ pc_sample (scp) ; /* For now, profiler just PC samples */ \
+ OS_pc_sample_timer_set(profile_interval, /* launch another 1-shot */ \
+ profile_interval) ; /* at the same interval */ \
+} while (FALSE)
+
+
+#ifndef PCS_TRAP_LOG /* Sample debuggery */
+#define real_profile_trap_handler(scp) essential_profile_trap_handler(scp)
+#else
+#define real_profile_trap_handler(scp) do \
+{ \
+ essential_profile_trap_handler(scp); \
+ outf_console ("\n; Profile trap handler called while interval = %d.\n", \
+ profile_interval) ; \
+ outf_flush_console () ; \
+} while (FALSE)
+#endif
+\f
+static void
+DEFUN (profile_trap_handler, (scp), struct FULL_SIGCONTEXT * scp)
+{
+
+#ifndef PCS_TRAP_HANDLER_PARANOIA
+
+ real_profile_trap_handler (scp) ;
+ return;
+
+#else /* PCS_TRAP_HANDLER_PARANOIA */
+
+ if ( (! (pc_sample_halted))
+ && (profile_interval != ((clock_t) 0)))
+ real_profile_trap_handler (scp) ;
+
+#ifndef PCS_TACIT_PUNT_BELATED /* Sample debuggery */
+ else if (profile_interval == ((clock_t) 0))
+ {
+ /* This shouldn't arise since now de-activate trap handler @ timer clear */
+ outf_console ("\n\
+ \n;----------------------------------------------\
+ \n; Profile trap handler punted a belated sample.\
+ \n;----------------------------------------------\
+ \n\
+ \n") ;
+ outf_flush_console () ;
+ }
+#endif
+
+#ifndef PCS_TACIT_WIZARD_HALT /* Sample gestalt debuggery */
+ else if (pc_sample_halted)
+ {
+ /* Only official wizards should ever witness this. FNORD! */
+
+ outf_console ("!") ;
+ outf_flush_console ();
+ }
+#endif
+
+#ifndef PCS_TACIT_MUSIC_MAN /* Sample debuggery */
+ else
+ {
+ outf_error ("\n ; There's trouble, right here in Sample City.\n") ;
+ outf_flush_error () ;
+ }
+#endif
+
+#endif /* PCS_TRAP_HANDLER_PARANOIA */
+}
+
+#endif /* HAVE_SIGCONTEXT and HAS_COMPILER_SUPPORT and not USE_STACKLETS */
+
+
+DEFUN_STD_HANDLER (sighnd_profile,
+ {
+ profile_trap_handler (scp);
+ })
+\f
+DEFINE_PRIMITIVE ("PC-SAMPLE/TIMER-CLEAR", Prim_pc_sample_timer_clear, 0, 0,
+ "()\n\
+ Turn off the PC sample timer.\
+ ")
+{
+ PRIMITIVE_HEADER (0);
+ OS_pc_sample_timer_clear ();
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("PC-SAMPLE/TIMER-SET", Prim_pc_sample_timer_set, 2, 2,
+ "(first interval)\n\
+ Set the PC sample timer.\n\
+ First arg FIRST says how long to wait until the first interrupt;\n\
+ second arg INTERVAL says how long to wait between interrupts after that.\n\
+ Both arguments are in units of milliseconds.\
+ ")
+{
+ PRIMITIVE_HEADER (2);
+ OS_pc_sample_timer_set ((arg_nonnegative_integer (1)),
+ (arg_nonnegative_integer (2)));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("%PC-SAMPLE/HALTED?", Prim_pc_sample_halted_p, 0, 0,
+ "()\n\
+ Specifies whether PC sampling has been brute forcably disabled.\n\
+ \n\
+ Only officially designated wizards should even think of using this\n\
+ super secret primitive. FNORD!\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (pc_sample_halted)) ;
+}
+
+DEFINE_PRIMITIVE ("%PC-SAMPLE/HALTED?/TOGGLE!",
+ Prim_pc_sample_halted_p_toggle_bang, 0, 0,
+ "()\n\
+ Toggles the Boolean sense of whether PC sampling is brute forcably disabled.\n\
+ \n\
+ It returns the newly installed sense of the flag.\n\
+ \n\
+ -------\n\
+ WARNING! If pc-sample/init has not been called (to initialize profiling\n\
+ ------- tables) then you will lose big if you naively toggle halted-flag\n\
+ to #F because that will start the profile timer.\n\
+ \n\
+ Only officially designated moby wizards should even think of thinking of\n\
+ using this most ultra super duper secret primitive. FNORD!\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ pc_sample_halted = (! (pc_sample_halted)) ;
+ if ( (! (pc_sample_halted))
+ && (profile_interval != ((clock_t) 0)))
+ OS_pc_sample_timer_set(1, profile_interval) ; /* Throw the switch, Igor! */
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (pc_sample_halted)) ;
+}
+\f
+/*****************************************************************************
+ * Mondo hack to keep track of where the primitive GARBAGE-COLLECT is so we
+ * can still sample GC calls during GC despite the PC_Sample_Primitive_Table
+ * can shift about
+ *****************************************************************************/
+
+long Garbage_Collect_Primitive_Index = -1; /* installed later */
+
+static void
+DEFUN_VOID (pc_sample_cache_GC_primitive_index)
+{
+ SCHEME_OBJECT primitive = make_primitive("GARBAGE-COLLECT");
+ Garbage_Collect_Primitive_Index = ((primitive != SHARP_F)
+ ? PRIMITIVE_NUMBER(primitive) : -1) ;
+#ifdef PCS_LOG_GCI_CACHE
+ outf_console ("\n GC Index %d (0x%x)\n",
+ Garbage_Collect_Primitive_Index,
+ Garbage_Collect_Primitive_Index) ;
+ outf_flush_console () ;
+#endif
+
+}
+
+DEFINE_PRIMITIVE ("%PC-SAMPLE/CACHE-GC-PRIMITIVE-INDEX",
+ Prim_pc_sample_cache_GC_primitive_index, 0, 0,
+ "()\n\
+ Signals the microcode to go find the GARBAGE-COLLECT primitive and cache\n\
+ away its index into the Primitive Table.\n\
+ \n\
+ This should be invoked each time the Primitive Table is altered in such a\n\
+ way that existing primitives can shift about.\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ pc_sample_cache_GC_primitive_index();
+ PRIMITIVE_RETURN(UNSPECIFIC);
+}
+
+
+static volatile Boolean pc_sample_within_GC_flag = false;
+static volatile double GC_samples = 0 ;
+
+static void
+DEFUN_VOID (pc_sample_spill_GC_samples_into_primitive_table)
+{
+ if ( ( GC_samples != 0) /* Something to tally */
+ && (Garbage_Collect_Primitive_Index != -1) /* Safe to tally GC samples */
+ )
+ {
+ /* flush GC_samples into GARBAGE-COLLECT entry w/in Primitive Table */
+ double * fpp
+ = ((double *)
+ (MEMORY_LOC
+ ((VECTOR_REF((Get_Fixed_Obj_Slot(PC_Sample_Primitive_Table)),
+ Garbage_Collect_Primitive_Index)),
+ 1))) ;
+ (* fpp) = ((* fpp) + ((double) GC_samples)) ;
+ }
+ GC_samples = 0 ; /* reset counter */
+}
+
+DEFINE_PRIMITIVE ("PC-SAMPLE/SPILL-GC-SAMPLES-INTO-PRIMITIVE-TABLE",
+ Prim_pc_sample_spill_GC_samples_into_primitive_table, 0, 0,
+ "()\n\
+ Make sure all samples taken during GC are present and accounted for in the\n\
+ Primitive Sample Table.\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ pc_sample_spill_GC_samples_into_primitive_table();
+ PRIMITIVE_RETURN(UNSPECIFIC);
+}
+\f
+
+static void
+DEFUN_VOID (pc_sample__pre_gc_gc_synch_hook)
+{
+ pc_sample_within_GC_flag = true; /* will count samples during GC */
+}
+
+static void
+DEFUN_VOID (pc_sample_post_gc_gc_synch_hook)
+{
+ if ((Get_Fixed_Obj_Slot(PC_Sample_Primitive_Table)) != SHARP_F) /* enabled */
+ pc_sample_spill_GC_samples_into_primitive_table() ;
+ pc_sample_within_GC_flag = false;
+ /***************************************************************************
+ * Moby hack: may still get a few samples after this hook runs but they will
+ * not be lost since we reset the counter *after* GC appears to be over, not
+ * at the beginning of the next GC. Thus, eventually these GCs will be coun-
+ * ted, just not necessarily right away. To be sure, however, that they get
+ * appropriately charged to the current sample run, we will manually call
+ * this hook whenever we try to access the primitive table in runtime code.
+ ***************************************************************************/
+}
+
+/****************************************************************************
+ * Following debuggery was used to isolate bug with unwarranted samples. *
+ ****************************************************************************/
+static Boolean
+DEFUN (repugnant_sample_block_addr_p, (block_addr), SCHEME_OBJECT * block_addr)
+{
+ /* If you uncomment the next lines, add 0x10+ to each constant below */
+ /* outf_error ("Block addr = %lx\n", ((unsigned long) block_addr));
+ outf_flush_error () ;
+ */
+ return ( (((unsigned long) block_addr) == 0x411F60FC) /* IPPB/flush */
+ || (((unsigned long) block_addr) == 0x411EEBD0) /* IPPB/need2flush?*/
+ || (((unsigned long) block_addr) == 0x410C6A94) /* name->package */
+ || (((unsigned long) block_addr) == 0x410EB880) /* package/child */
+ || (((unsigned long) block_addr) == 0x410AEB24) /* ->environment */
+ ); /* block-off+0x40000000 */
+}
+
+static void /* debuggery hook */
+DEFUN (flame_block, (block_addr), SCHEME_OBJECT * block_addr)
+{
+ if (pc_sample_halted)
+ outf_console ("\n\nAAAHH!! 0x%x\n\n",((unsigned long) block_addr));
+ else
+ outf_console ("MADRE!! Bad ass = %lx ; P(h) = %d ; P(i) = %d\n",
+ ((unsigned long) block_addr),
+ pc_sample_halted,
+ profile_interval) ;
+
+ outf_flush_console () ;
+}
+\f
+static struct trap_recovery_info *
+DEFUN (find_sigcontext_ptr_pc, (scp, trinfo),
+ struct FULL_SIGCONTEXT * scp AND
+ struct trap_recovery_info * trinfo
+ )
+{
+ /* Recover the PC from the signal context ptr. */
+ /* (Extracted from continue_from_trap in uxtrap.c) */
+
+ long the_pc = ((FULL_SIGCONTEXT_PC (scp)) & PC_VALUE_MASK);
+
+ int builtin_index;
+ int utility_index;
+
+ int pc_in_builtin;
+ int pc_in_utility;
+ int pc_in_C;
+ int pc_in_heap;
+ int pc_in_constant_space;
+ int pc_in_scheme;
+ int pc_in_hyper_space;
+
+ if ((the_pc & PC_ALIGNMENT_MASK) != 0)
+ {
+ pc_in_builtin = false;
+ pc_in_utility = false;
+ pc_in_C = false;
+ pc_in_heap = false;
+ pc_in_constant_space = false;
+ pc_in_scheme = false;
+ pc_in_hyper_space = true;
+ }
+ else
+ {
+ extern int EXFUN (pc_to_builtin_index, (unsigned long));
+ extern int EXFUN (pc_to_utility_index, (unsigned long));
+
+ builtin_index = (pc_to_builtin_index (the_pc));
+ utility_index = (pc_to_utility_index (the_pc));
+
+ pc_in_builtin = (builtin_index != -1);
+ pc_in_utility = (utility_index != -1);
+ pc_in_C = ( (the_pc <= ((long) (get_etext ())))
+ && (!pc_in_builtin));
+ pc_in_heap = ( (the_pc < ((long) Heap_Top ))
+ && (the_pc >= ((long) Heap_Bottom)));
+ pc_in_constant_space = ( (the_pc < ((long) Free_Constant ))
+ && (the_pc >= ((long) Constant_Space)));
+ pc_in_scheme = ( pc_in_heap
+ || pc_in_constant_space
+ || pc_in_builtin);
+ pc_in_hyper_space = ( (! pc_in_C )
+ && (! pc_in_scheme));
+ }
+
+ if ( pc_in_hyper_space
+ || (pc_in_scheme && ALLOW_ONLY_C)) /* In hyper space. */
+ {
+ (trinfo -> state) = STATE_UNKNOWN;
+ (trinfo -> pc_info_1) = 0; /* UFO[0]: Doesnt look like a primitive */
+ (trinfo -> pc_info_2) = the_pc;
+ (trinfo -> extra_trap_info) = pc_in_hyper_space;
+ }
+ else if (pc_in_scheme) /* In compiled code. */
+ {
+ SCHEME_OBJECT * block_addr = (pc_in_builtin
+ ? ((SCHEME_OBJECT *) NULL)
+ : (find_block_address (((PTR) the_pc),
+ (pc_in_heap
+ ? Heap_Bottom
+ : Constant_Space))));
+ if (block_addr != ((SCHEME_OBJECT *) NULL))
+ {
+ (trinfo -> state) = STATE_COMPILED_CODE;
+ (trinfo -> pc_info_1) = /* code block */
+ (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, block_addr));
+ (trinfo -> pc_info_2) = /* offset w/in block */
+ (LONG_TO_UNSIGNED_FIXNUM (the_pc - ((long) block_addr)));
+ (trinfo -> extra_trap_info) = pc_in_constant_space;
+#ifdef PCS_LOG_REPUGNANCE
+ if (repugnant_sample_block_addr_p (block_addr))
+ flame_block (block_addr);
+#endif
+ }
+ else if (pc_in_builtin) /* In builtin */
+ {
+ (trinfo -> state) = STATE_BUILTIN;
+ (trinfo -> pc_info_1) = builtin_index;
+ (trinfo -> pc_info_2) = SHARP_T;
+ (trinfo -> extra_trap_info) = true;
+ }
+ else /* In Probably Compiled frobby */
+ {
+ int prob_comp_index = (pc_in_constant_space ? 0 : 1) ;
+
+ (trinfo -> state) = STATE_PROBABLY_COMPILED;
+ (trinfo -> pc_info_1) = prob_comp_index;
+ (trinfo -> pc_info_2) = the_pc;
+ (trinfo -> extra_trap_info) = pc_in_constant_space;
+ }
+ }
+ else /* pc_in_C */
+ {
+ /* In the interpreter, a primitive, or a compiled code utility. */
+
+ SCHEME_OBJECT primitive = (Regs[REGBLOCK_PRIMITIVE]);
+
+ if (pc_in_utility) /* In Utility */
+ {
+ (trinfo -> state) = STATE_UTILITY;
+ (trinfo -> pc_info_1) = utility_index;
+ (trinfo -> pc_info_2) = SHARP_F;
+ (trinfo -> extra_trap_info) = false;
+ }
+ else if ((OBJECT_TYPE (primitive)) == TC_PRIMITIVE) /* In Primitive */
+ {
+ (trinfo -> state) = STATE_PRIMITIVE;
+ (trinfo -> pc_info_1) = (PRIMITIVE_NUMBER (primitive));
+ (trinfo -> pc_info_2) = primitive;
+ (trinfo -> extra_trap_info) = true;
+ }
+ else /* In Interpreted or In UFO ?!?!?!?! */
+ {
+ (trinfo -> state) = STATE_UNKNOWN;
+ (trinfo -> pc_info_1) = 1; /* UFO[1]: Looked like a primitive */
+ (trinfo -> pc_info_2) = the_pc;
+ (trinfo -> extra_trap_info) = primitive;
+ }
+ }
+ return (trinfo) ;
+}
+\f
+/*****************************************************************************/
+static SCHEME_OBJECT
+DEFUN (pc_sample_flame_bad_table, (table_no, table), unsigned int table_no AND
+ SCHEME_OBJECT table)
+{
+ outf_error ("\nPC sample table (0x%x) find fault: ", table_no);
+
+ if (table_no >= NFixed_Objects)
+ outf_error ("bad ucode band--- table out of range.") ;
+ else if (! (VECTOR_P(table)))
+ outf_error ("table was not a Scheme VECTOR.") ;
+ else
+ outf_error("Bloody mess, that!") ;
+
+ outf_error ("\n") ;
+ outf_flush_error () ;
+
+ return (UNSPECIFIC) ; /* Fault: signal UNSPECIFIC */
+}
+
+#ifndef PCS_TABLE_PARANOIA
+#define pc_sample_find_table(table_no) Get_Fixed_Obj_Slot (table_no)
+#else
+#define pc_sample_find_table(table_no) do \
+{ \
+ SCHEME_OBJECT table; \
+ \
+ if ( (table_no < NFixed_Objects) /* in band? */\
+ && ((table = (Get_Fixed_Obj_Slot (table_no))) != SHARP_F) /* enabled? */\
+ && (VECTOR_P(table)) /* valid? */\
+ ) /* Success: return vector */ \
+ return (table) ; \
+ else if (table == SHARP_F) /* Disabled: percolate #F */ \
+ return (SHARP_F) ; \
+ else /* fault: lay blame */ \
+ pc_sample_flame_bad_table (table_no, table); \
+} while (FALSE)
+#endif /* PCS_TABLE_PARANOIA */
+
+
+static unsigned long
+DEFUN (pc_sample_cc_block_index, (trinfo), struct trap_recovery_info * trinfo)
+{
+ /* SCHEME_OBJECT block = (trinfo -> pc_info_1);
+ * unsigned int offset = (trinfo -> pc_info_2);
+ */
+ /* SOME DAY....
+ * Compute unique ID for the entry in the code block as:
+ * code_block_ID + index_of_current_cc_block_entry
+ */
+ /* MUCH LATER CC_BLOCK_ID (block_addr) +
+ * INDEX_OF_CURRENT_CC_BLOCK_ENTRY (block_addr, offset)) ;
+ *
+ * .... BUT UNTIL THAT DAY ARRIVES, just store a count
+ */
+
+ return((unsigned long) 0) ;
+}
+
+/*****************************************************************************/
+static unsigned long
+DEFUN (pc_sample_counter_index, (trinfo), struct trap_recovery_info * trinfo)
+{
+ /* For now, we just increment a single counter. Later a more exotic structure
+ * may be maintained.. like discriminated counters and a real-time histogram.
+ */
+
+ return ((unsigned long) 0) ;
+}
+
+/*****************************************************************************/
+static unsigned long
+DEFUN (pc_sample_indexed_table_index, (trinfo), struct trap_recovery_info * trinfo)
+{
+ /* pc_info_1 = index into Mumble_Procedure_Table */
+
+ return ((unsigned long) (trinfo -> pc_info_1)) ;
+}
+\f
+/*****************************************************************************/
+static void
+DEFUN (pc_sample_record_table_entry, (table, index), unsigned int table AND
+ unsigned long index)
+{
+
+#ifdef PCS_LOG_PUNTS /* Punt warnings */
+ if (pc_sample_halted)
+ {
+ outf_console
+ ("\n; PC sample punted in the nick of time from table 0x%x[%d].\n",
+ table, index) ;
+ outf_flush_console () ;
+ }
+ else
+#endif
+
+ {
+ /* For now, we just increment a counter. Later a more exotic structure
+ * may be maintained here.. like a counter and a real-time histogram...
+ */
+ double * fpp = ((double *) (MEMORY_LOC ((VECTOR_REF (table, index)), 1)));
+
+ (*fpp) += 1.0;
+ }
+}
+
+
+
+
+
+
+
+
+
+/*****************************************************************************
+ * Sample verbosity (console logging)...
+ *****************************************************************************/
+
+/*---------------------------------------------------------------------------*/
+static void
+DEFUN (log_cobl_sample, (trinfo), struct trap_recovery_info * trinfo)
+{
+ /* pc_info_1 = code block
+ * pc_info_2 = offset into block
+ * xtra_info = pc_in_constant_space
+ */
+ outf_console
+ ("; PC Sampler encountered a Compiled FNORD! 0x%x (off = %d, P(c) = %d%%)\n",
+ ((unsigned long)(trinfo -> pc_info_1) ),
+ ( UNSIGNED_FIXNUM_TO_LONG((trinfo -> pc_info_2)) ),
+ (( int)(trinfo -> extra_trap_info) )) ;
+ outf_flush_console () ;
+}
+/*---------------------------------------------------------------------------*/
+static void
+DEFUN (log_prob_comp_sample, (trinfo), struct trap_recovery_info * trinfo)
+{
+ /* pc_info_2 = the_pc (long)
+ * xtra_info = pc_in_constant_space
+ */
+ outf_console
+ ("; PC Sampler stumbled into a Prob Comp FNORD! at addr 0x%x (P(c) = %d%%)\n",
+ (trinfo -> pc_info_2), ((Boolean)(trinfo -> extra_trap_info))) ;
+ outf_flush_console () ;
+}
+\f
+/*****************************************************************************
+ * More Sample verbosity (console logging)...
+ *****************************************************************************/
+
+/*---------------------------------------------------------------------------*/
+static void
+DEFUN (log_UNKNOWN_STATE_sample, (trinfo), struct trap_recovery_info * trinfo)
+{
+ /* ``UNKNOWN_STATE'' samples are either interpreted procs or UFOs.
+ * Any way you look at it, you lose. What's that you say...?
+ */
+ outf_console
+ ((((trinfo -> pc_info_1) == SHARP_T) /* pc_apparent_prim? */
+ ? "; PC Sampler taught it taw a pwimitive...\
+ \n; But it didn't. It didn't taw a pwimitive."
+ : (((trinfo -> extra_trap_info) == SHARP_T) /* dreaded hyper space */
+ /*------------------------------------------------------------------*/
+ ? "; **** WARNING! WARNING! DANGER, WILL ROBINSON! DANGER! ****\
+ \n; **** LOST IN HYPER SPACE! WE'RE DOOMED! DOOMED, I TELL YOU! ****\
+ \n; **** ALL DOOMED!! OH, THE PAIN!! THE PAIN!!! ****"
+ /*------------------------------------------------------------------*/
+ : "; PC Sampler had a close encounter with an Unidentifiable Functional Object\
+ \n; -- i.e., This is a UFO sighting! Run for your life!!\
+ \n; ``You will be assimilated. Resistance is futile.''"))) ;
+ /*------------------------------------------------------------------*/
+ outf_console ("\n") ;
+}
+/*---------------------------------------------------------------------------*/
+static void
+DEFUN (log_interp_proc_sample, (trinfo), struct trap_recovery_info * trinfo)
+{
+ /* pc_info_1 = pc_an_apparent_primitive
+ * pc_info_2 = the_pc
+ * extra_trap_info = /prim if pc_info_1 = #T
+ * \pc_in_hyper_space otherwise
+ */
+ outf_console
+ ("\n\
+ \n;---------------------------------------------------------------------\
+ \n; PC Sampler slogged down inside an interpreted bog\
+ \n; in Loch 0x%x at Glen 0x%x.",
+ (trinfo -> pc_info_2),
+ (trinfo -> extra_trap_info)) ;
+ outf_console ("\n; The context was as follows:\n") ;
+ log_UNKNOWN_STATE_sample (trinfo) ;
+ outf_flush_console () ;
+}
+/*---------------------------------------------------------------------------*/
+static void
+DEFUN (log_UFO_sample, (trinfo), struct trap_recovery_info * trinfo)
+{
+ /* pc_info_1 = pc_an_apparent_primitive_flag
+ * pc_info_2 = the_pc
+ * xtra_info = /prim if pc_info_1 = #T
+ * \pc_in_hyper_space otherwise
+ */
+ outf_console
+ ("\n\
+ \n;---------------------------------------------------------------------\
+ \n; BEGIN TRANSMISSION \n; \
+ \n; ^ \n; ` ` \
+ \n; _ ` ` _ \n; \" ` ` \" \
+ \n; \" ` ` \" \n; \" ` .` `. ` \" \
+ \n; \" `` _ _ `` \" \n; ` ` \n;\
+ \n; CAPTAINS'S LOG: ``UFO'' sighting at sector [0x%x] at warp [%d])\n",
+ ((unsigned long)(trinfo -> pc_info_2)),
+ (((trinfo -> pc_info_1) == SHARP_T)
+ ? ((unsigned long) (trinfo -> extra_trap_info)) /* pwimitive */
+ : ( (Boolean) (trinfo -> extra_trap_info))) /* hyperspace? */
+ ) ;
+ log_UNKNOWN_STATE_sample (trinfo) ;
+ outf_console
+ ("\n\
+ \n; END TRANSMISSION\
+ \n;---------------------------------------------------------------------\
+ \n") ;
+ outf_flush_console () ;
+}
+\f
+/*****************************************************************************/
+static void
+DEFUN (pc_sample_update_table, (PC_Sample_Table, trinfo, index_func_ptr),
+ unsigned int PC_Sample_Table AND
+ struct trap_recovery_info * trinfo AND
+ unsigned long (* index_func_ptr)())
+{
+ SCHEME_OBJECT table = UNSPECIFIC;
+ unsigned long index;
+
+#if ( defined(PCS_LOG) /* Sample logging */ \
+ || defined(PCS_LOG_PROB_COMP) \
+ )
+ if (PC_Sample_Table == PC_Sample_Prob_Comp_Table)
+ log_prob_comp_sample (trinfo) ;
+#endif
+
+#if ( defined(PCS_LOG) /* Sample logging */ \
+ || defined(PCS_LOG_UFO) \
+ )
+ if (PC_Sample_Table == PC_Sample_UFO_Table)
+ log_UFO_sample (trinfo) ;
+#endif
+
+ if ((table = pc_sample_find_table (PC_Sample_Table)) == SHARP_F)
+ {
+ /* Samples of this type are disabled, so drop the sample on the floor */
+ /* for now... later count drops */
+ return;
+ }
+ else
+ {
+ index = ((* index_func_ptr)(trinfo)) ;
+
+#ifdef PCS_TABLE_PARANOIA
+ if ( (VECTOR_P (table) )
+ && (VECTOR_LENGTH(table) > index)
+ )
+ {
+#endif /* ------------------------------ PARANOIA OVERDRIVE --------------. */
+ /* | */
+ if ( (PC_Sample_Table == PC_Sample_Primitive_Table) /* | */
+ && ( index == Garbage_Collect_Primitive_Index) /* | */
+ ) /* | */
+ /* Yow! The primitives sample table will be moved by the GC *//* | */
+ /* so storing into it can lose by storing into the old *//* | */
+ /* (broken heart) address. *//* | */
+ /* *//* | */
+ /* To avoid this, we keep a count of GC samples until *//* | */
+ /* the GC is over then add the GC_samples to the GC *//* | */
+ /* primitive's sample entry. *//* | */
+ /* *//* | */
+ /* GJR installed gc_hooks for just this purpose. *//* | */
+ /* Damned sporting of him, I must say. *//* | */
+ /* *//* | */
+ GC_samples += 1; /* | */
+ else /* | */
+ (pc_sample_record_table_entry (table, index)) ; /* | */
+ /* | */
+#ifdef PCS_TABLE_PARANOIA /* <----------- PARANOIA OVERDRIVE --------------' */
+ }
+ else if (VECTOR_P(table)) /* index was out of range */
+ {
+ outf_error
+ ("\nPC sample table (0x%x) update fault: index out of range-- %d >= %d.\n",
+ PC_Sample_Table, index, (VECTOR_LENGTH(table))) ;
+ outf_flush_error () ;
+ }
+ else if (table == UNSPECIFIC) /* fault */
+ return; /* Let it slide: already flamed about it in finder. */
+ else /* something's broken */
+ {
+ outf_error ("\nPC sample find table do a poo-poo, do a poo-poo.\n") ;
+ outf_flush_error () ;
+ }
+#endif /* PCS_TABLE_PARANOIA */
+ }
+}
+\f
+/*****************************************************************************/
+struct profile_buffer_state
+{
+ char * name; /* name string */
+
+ unsigned int ID; /* indices into the Fixed Obj Vector */
+ unsigned int ID_aux; /* ... for the buffer(s) */
+
+ Boolean enabled_flag; /* the buffer qua buffer, as it were */
+ SCHEME_OBJECT buffer;
+ SCHEME_OBJECT buffer_aux;
+ unsigned long length;
+ unsigned long next_empty_slot_index;
+
+ unsigned long slack; /* flush/extend nearness thresholds */
+ long slack_increment;
+
+ unsigned int flush_INT; /* Interrupt request bits */
+ unsigned int extend_INT;
+
+ Boolean flush_noisy_flag; /* verbosity flags for monitoring */
+ Boolean extend_noisy_flag; /* ... buffer parameter performance */
+ Boolean overflow_noisy_flag;
+
+ Boolean flush_immed_flag; /* debuggery hook */
+
+ Boolean debug_flag; /* random hook */
+ Boolean monitor_flag; /* random hook */
+
+ unsigned long flush_count; /* Counts for performance monitoring */
+ unsigned long extend_count;
+ unsigned long overflow_count;
+
+ SCHEME_OBJECT extra_buffer_state_info; /* etc hook for future extensions */
+};
+\f
+/*****************************************************************************/
+static void
+DEFUN (init_profile_buffer_state, (pbs_ptr,
+ name, ID, ID_aux, slack, slack_increment,
+ flush_INT, extend_INT),
+ struct profile_buffer_state * pbs_ptr AND
+ char * name AND
+ unsigned int ID AND
+ unsigned int ID_aux AND
+ unsigned long slack AND
+ long slack_increment AND
+ unsigned int flush_INT AND
+ unsigned int extend_INT)
+{
+ (pbs_ptr -> name) = name; /* arg */
+ (pbs_ptr -> ID) = ID; /* arg */
+ (pbs_ptr -> ID_aux) = ID_aux; /* arg */
+ (pbs_ptr -> enabled_flag) = false;
+ (pbs_ptr -> buffer) = UNSPECIFIC;
+ (pbs_ptr -> buffer_aux) = UNSPECIFIC;
+ (pbs_ptr -> length) = ((unsigned long) 0);
+ (pbs_ptr -> next_empty_slot_index) = ((unsigned long) 0);
+ (pbs_ptr -> slack) = slack; /* arg */
+ (pbs_ptr -> slack_increment) = slack_increment; /* arg */
+ (pbs_ptr -> flush_INT) = flush_INT; /* arg */
+ (pbs_ptr -> extend_INT) = extend_INT; /* arg */
+ (pbs_ptr -> flush_noisy_flag) = false;
+ (pbs_ptr -> extend_noisy_flag) = false;
+ (pbs_ptr -> overflow_noisy_flag) = true;
+ (pbs_ptr -> flush_immed_flag) = false;
+ (pbs_ptr -> debug_flag) = false; /* i.e. no count flush/xtnd */
+ (pbs_ptr -> monitor_flag) = true; /* i.e. count buf overflows */
+ (pbs_ptr -> flush_count) = ((unsigned long) 0);
+ (pbs_ptr -> extend_count) = ((unsigned long) 0);
+ (pbs_ptr -> overflow_count) = ((unsigned long) 0);
+ (pbs_ptr -> extra_buffer_state_info) = SHARP_F;
+}
+/*---------------------------------------------------------------------------*/
+#define init_profile_bi_buffer_state(pbs_ptr, \
+ name, ID, ID_aux, slack, slack_increment,\
+ flush_INT, extend_INT) \
+ init_profile_buffer_state(pbs_ptr, \
+ name, ID, ID_aux, slack, slack_increment,\
+ flush_INT, extend_INT)
+
+#define init_profile_uni_buffer_state(pbs_ptr, \
+ name, ID, slack, slack_increment,\
+ flush_INT, extend_INT) \
+ init_profile_buffer_state(pbs_ptr, \
+ name, ID, false, slack, slack_increment,\
+ flush_INT, extend_INT)
+/*...........................................................................*\
+|*. For example... *|
+\*...........................................................................*/
+
+static struct profile_buffer_state dummy_profile_buffer_state;
+
+static void
+DEFUN_VOID (init_dummy_profile_buffer_state)
+{
+ init_profile_buffer_state(&dummy_profile_buffer_state,
+ "PBS Fnord!", /* name */
+ false, /* ID */
+ false, /* ID_aux */
+ ((unsigned long) 0), /* slack */
+ (( long) 0), /* slack_inc */
+ ((unsigned int) 0), /* flush_INT */
+ ((unsigned int) 0) /* extnd_INT */
+ );
+}
+/*---------------------------------------------------------------------------*/
+\f
+/*****************************************************************************/
+static void
+DEFUN (pc_sample_record_bi_buffer_entry, (entry, entry_aux, PBS),
+ SCHEME_OBJECT entry AND
+ SCHEME_OBJECT entry_aux AND
+ struct profile_buffer_state * PBS)
+{
+ /* Cache some useful state values */
+
+ unsigned long buffer_length = (PBS -> length ) ;
+ unsigned long next_empty_slot_index = (PBS -> next_empty_slot_index) ;
+
+ if (next_empty_slot_index >= buffer_length)
+ {
+ (PBS -> next_empty_slot_index) = buffer_length - 1 ;
+ if (PBS -> overflow_noisy_flag)
+ {
+ outf_error ("\n\nBloody Hell! The bloody %s bloody overflowed.\n",
+ (PBS -> name)) ;
+ outf_flush_error () ;
+ }
+ if (PBS -> monitor_flag)
+ (PBS -> overflow_count) += 1;
+ }
+
+#ifdef PCS_LOG_PUNTS /* Punt warnings */
+ else if (pc_sample_halted)
+ {
+ outf_console ("\n; PC sample %s entry punted in the nick of time.\n",
+ (PBS -> name)) ;
+ outf_flush_console () ;
+
+ return;
+ }
+#endif
+
+ else
+ {
+ unsigned long next_index_plus_slack ;
+
+ /* Cache some more useful state values */
+
+ Boolean uni_buffer_flag = (! (PBS -> ID_aux)) ;
+
+ SCHEME_OBJECT buffer = (PBS -> buffer ) ;
+ SCHEME_OBJECT buffer_aux = (PBS -> buffer_aux) ;
+ unsigned long slack = (PBS -> slack ) ;
+ unsigned int flush_INT = (PBS -> flush_INT) ;
+ unsigned int extend_INT = (PBS -> extend_INT) ;
+
+ ( VECTOR_SET(buffer , next_empty_slot_index, entry )) ;
+ if (! uni_buffer_flag)
+ (VECTOR_SET(buffer_aux, next_empty_slot_index, entry_aux)) ;
+
+ next_empty_slot_index += 1 ; /* incr cache */
+ (PBS -> next_empty_slot_index) = next_empty_slot_index ; /* synch cache */
+
+ next_index_plus_slack = next_empty_slot_index + slack ;
+
+#ifdef PCS_FLUSH_DEBUGGERY /* Flush debuggering */
+ outf_console (";============================================\n") ;
+ outf_console ("; name == %s\n", (PBS -> name) ) ;
+ outf_console ("; ni+s == %d\n", next_index_plus_slack ) ;
+ outf_console ("; blen == %d\n", buffer_length ) ;
+ outf_console ("; nmti == %d\n", next_empty_slot_index ) ;
+ outf_console ("; slak == %d\n", slack ) ;
+ outf_console ("; BFQP == %d\n", INTERRUPT_QUEUED_P ( flush_INT)) ;
+ outf_console ("; BFXP == %d\n", INTERRUPT_QUEUED_P (extend_INT)) ;
+ outf_flush_console () ;
+#endif
+
+
+ /* ... continued on next page ... */
+\f
+ /* ... pc_sample_record_bi_buffer_entry: continued from previous page... */
+
+ /* Buffer Nearly Full (or unsigned overflow) ? */
+
+ if ( (next_index_plus_slack > buffer_length) /* nearfull */
+ || (next_index_plus_slack < next_empty_slot_index) /* overflow */
+ || (next_index_plus_slack < slack ) /* overflow */
+ || (PBS -> flush_immed_flag) /* Flush debuggering */
+ )
+ {
+ if (! (INTERRUPT_QUEUED_P(flush_INT)))
+ {
+ REQUEST_INTERRUPT(flush_INT) ;
+ if (PBS -> flush_noisy_flag)
+ { outf_console ("\n;>>>>>>>>> %s Flush Request issued.",
+ (PBS -> name)) ; outf_flush_console () ;
+ }
+ if ((PBS -> debug_flag) && (PBS -> monitor_flag)) /* can monitor */
+ (PBS -> flush_count) += 1; /* in runtime */
+ }
+ else if (PBS -> flush_noisy_flag)
+ { outf_console ("\n;>> >> > %s Flush Request still queued.",
+ (PBS -> name)) ; outf_flush_console () ;
+ }
+ }
+
+ /* Buffer Full? */
+
+ if ( (! (INTERRUPT_QUEUED_P (extend_INT)))
+ && (next_empty_slot_index >= buffer_length) /* > is PARANOIA */
+ )
+ {
+ int slack_inc_neg_p ; /* Gonna cut the slack a little slack */
+ unsigned long new_slack ; /* to increase our margin of safety. */
+
+ /* Cache one last useful state value */
+
+ long slack_increment = (PBS -> slack_increment) ;
+
+ /* Back up the next slot pointer so we don't go out of range */
+
+ (PBS -> next_empty_slot_index) = buffer_length - 1 ;
+
+ /* Increase slack to attempt to avoid additional overflows */
+
+ slack_inc_neg_p = (slack_increment < 0) ;
+ new_slack = (slack_inc_neg_p
+ ? slack - ((unsigned long) (- slack_increment))
+ : slack + ((unsigned long) slack_increment )) ;
+
+ if ( slack_inc_neg_p && (new_slack > slack))
+ new_slack = 1 ; /* unsigned underflow: min to 1 */
+ else if ((! slack_inc_neg_p) && (new_slack < slack))
+ new_slack = slack ; /* unsigned overflow: max to old value */
+
+ (PBS -> slack) = new_slack ;
+
+ /* Issue extend request */
+
+ REQUEST_INTERRUPT (extend_INT) ;
+ if (PBS -> extend_noisy_flag)
+ { outf_console ("\n;>>>>>>>>> %s Extend Request issued.",
+ (PBS -> name)) ; outf_flush_console () ;
+ }
+ if ((PBS -> debug_flag) && (PBS -> monitor_flag)) /* can monitor */
+ (PBS -> extend_count) += 1; /* in runtime */
+ }
+ else if ((PBS -> extend_noisy_flag) && (INTERRUPT_QUEUED_P (extend_INT)))
+ { outf_console ("\n;>> >> > %s Extend Request still queued.",
+ (PBS -> name)) ; outf_flush_console () ;
+ }
+ }
+}
+/*...........................................................................*/
+#define FNORD UNSPECIFIC
+
+#define pc_sample_record_buffer_entry(entry, PBS) /* uni_buffer is a */\
+ pc_sample_record_bi_buffer_entry(entry, FNORD, PBS) /* ...special case */
+\f
+/*****************************************************************************/
+static void
+DEFUN (pc_sample_update_bi_buffer, (buffer_state, trinfo, record_func_ptr),
+ struct profile_buffer_state * buffer_state AND
+ struct trap_recovery_info * trinfo AND
+ void (* record_func_ptr)())
+{
+ /* Like interp-procs, wanna maintain a hashtable of instances encountered,
+ * so we maintain a buffer and defer to an interrupt handler to flush and
+ * extend the buffer as needed. Both the code block and the offset into the
+ * code block are informative (since code blocks can contain multiple
+ * definitions) so both are stored in synchronized buffers [i.e., slot N of
+ * each of two buffers stores the Nth sampled code block and its associated
+ * code block offset].
+ *
+ * Moreover, purified (non-relocateable) code blocks are distinguished from
+ * non-purified (``heathen''?) code blocks since the GC can move the latter
+ * around but not the former...meaning that purified ones can be hashed off
+ * their addr/offset alone whereas heathens must be obj hashed (christened?).
+ *
+ * FOR PURIFIED CODE BLOCKS...
+ * Win. Location is fixed so needn't sweat GC re-location
+ * For now, buffer addr/offset pairs for later hashing.
+ *
+ * FOR HEATHEN CODE BLOCKS...
+ * Sigh. GC can re-locate, so buffer SCHEME_OBJ ptr for hashing.
+ * For now, buffer away the re-locatable addr & offset for later hashing.
+ *
+ * Once we arrange for the linker/loader to embed a hash code, we can just
+ * use that instead of buffered add/offset pairs.
+ */
+
+#ifndef PCS_FOV_SNARK_HUNT
+
+ if (buffer_state -> enabled_flag)
+ ((* record_func_ptr)(trinfo)) ;
+ else
+ {
+ /* Samples of this type are disabled, so drop the sample on the floor */
+ /* for now... later count drops */
+ return;
+ }
+
+ return;
+
+
+ /* ... continued on next page ... */
+\f
+ /* ... pc_sample_update_bi_buffer: continued from previous page ... */
+
+
+
+#else /* PCS_FOV_SNARK_HUNT */
+
+ Boolean uni_buffer_flag = (! (buffer_state -> ID_aux)) ;
+
+ SCHEME_OBJECT buffer_1 = (pc_sample_find_table (buffer_state -> ID )) ;
+ SCHEME_OBJECT buffer_2 = (uni_buffer_flag
+ ? SHARP_F /* treat as if disabled */
+ : (pc_sample_find_table (buffer_state -> ID_aux)));
+
+ if ( (VECTOR_P (buffer_1)) /* massive paranoia... */
+ && (uni_buffer_flag || (VECTOR_P (buffer_2)))
+ && (buffer_state -> enabled_flag) /* ... flag alone should suffice */
+ )
+ ((* record_func_ptr)(trinfo)) ;
+
+ /* very paranoid debuggery... should just return now, no questions asked */
+
+ else if ( (buffer_1 == SHARP_F ) /* buffer_1 disabled? */
+ || (buffer_1 == UNSPECIFIC) /* buffer_1 un-initialized */
+ || ( (! uni_buffer_flag) /* regardez buffer_2? */
+ && ( (buffer_2 == SHARP_F ) /* buffer_2 disabled? */
+ || (buffer_2 == UNSPECIFIC) /* buffer_2 un-initialized? */
+ )
+ )
+ )
+ {
+
+#ifdef PCS_PBS_ENABLE_PARANOIA /* Paranoia */
+ if (buffer_state -> enabled_flag)
+ {
+ outf_error ("\nSigh. %s looked enabled but is disabled.\n",
+ (buffer_state -> name)) ;
+ outf_flush_error () ;
+ }
+#endif
+
+ return; /* Let it slide: find_table will have flamed if appropriate. */
+ }
+ else
+ {
+ outf_error ("\nThere's something rotten in the state of update_buffer\n") ;
+ outf_flush_error () ;
+ }
+
+#endif /* PCS_FOV_SNARK_HUNT */
+
+}
+/*...........................................................................*/
+
+#define pc_sample_update_buffer(buffer_state, trinfo, record_func_ptr) \
+ pc_sample_update_bi_buffer(buffer_state, trinfo, record_func_ptr)/* aka */
+\f
+/*****************************************************************************/
+#include "pcsiproc.c" /* (Interpreted) Interp-Proc sampling */
+#include "pcscobl.c" /* (Compiled) Code Block sampling */
+
+#define VALID_PC_SAMPLE_ENV_P(env) ((OBJECT_TYPE (env) == TC_ENVIRONMENT))
+/*****************************************************************************/
+static void
+DEFUN (pc_sample_record, (trinfo), struct trap_recovery_info * trinfo)
+{
+
+#ifdef PCS_LOG_PUNTS /* Punt warnings */
+ if (pc_sample_halted)
+ {
+ outf_console
+ ("\n; PC sample punted at the last moment: HALTED flag set.\n");
+ outf_flush_console ();
+ }
+ else
+#endif
+
+ {
+ switch (trinfo -> state)
+ {
+ case STATE_BUILTIN:
+ pc_sample_update_table (PC_Sample_Builtin_Table, trinfo,
+ pc_sample_indexed_table_index);
+ break;
+ case STATE_UTILITY:
+ pc_sample_update_table (PC_Sample_Utility_Table, trinfo,
+ pc_sample_indexed_table_index);
+ break;
+ case STATE_PRIMITIVE:
+ pc_sample_update_table (PC_Sample_Primitive_Table, trinfo,
+ pc_sample_indexed_table_index);
+ break;
+ case STATE_PROBABLY_COMPILED:
+ pc_sample_update_table (PC_Sample_Prob_Comp_Table, trinfo,
+ pc_sample_indexed_table_index);
+ break;
+ case STATE_COMPILED_CODE:
+ pc_sample_update_table (PC_Sample_Code_Block_Table, trinfo,
+ pc_sample_cc_block_index);
+
+ /* Above line is a back door for future expansion...real code is: */
+
+ (((Boolean)(trinfo -> extra_trap_info)) /* pc_in_constant_space */
+ ? (pc_sample_update_bi_buffer (&purified_cobl_profile_buffer_state,
+ trinfo,
+ pc_sample_record_purified_cobl))
+ : (pc_sample_update_bi_buffer (& heathen_cobl_profile_buffer_state,
+ trinfo,
+ pc_sample_record_heathen_cobl))) ;
+ break;
+ case STATE_UNKNOWN: /* i.e., in interpreted code or in hyper space */
+ /* Hope we're in interpreted code and attempt to deduce the current
+ * interp-proc from the current active environment frame anyway.
+ * GJR suggested nabbing the current ENV to find the current PROC,
+ * warning that the current ENV may be invalid, e.g. in the middle
+ * of a LOAD. In that case we are S.O.L., so record a UFO. Sigh.
+ */
+ ((VALID_PC_SAMPLE_ENV_P (pc_sample_current_env_frame = Fetch_Env()))
+ ? pc_sample_update_buffer (&interp_proc_profile_buffer_state,
+ trinfo,
+ pc_sample_record_interp_proc)
+ : pc_sample_update_table (PC_Sample_UFO_Table,
+ trinfo,
+ pc_sample_indexed_table_index)) ;
+ break;
+ }
+ }
+}
+\f
+/*****************************************************************************/
+void
+DEFUN (pc_sample, (scp), struct FULL_SIGCONTEXT * scp)
+{
+
+#ifdef PCS_LOG_PUNTS /* Punt warnings */
+ if (pc_sample_halted)
+ {
+ outf_console ("\n; PC sample called but punted due to halt flag.\n") ;
+ outf_flush_console () ;
+ }
+ else
+#endif
+
+ if (pc_sample_within_GC_flag)
+ GC_samples += 1;
+ else
+ {
+ struct trap_recovery_info trinfo ;
+
+ (pc_sample_record (find_sigcontext_ptr_pc (scp, &trinfo)));
+
+#ifdef PCS_LOG /* Sample logging */
+ outf_console ("; PC sample called.\n") ;
+ outf_flush_console () ;
+#endif
+
+ }
+}
+
+/*****************************************************************************/
+static int
+DEFUN_VOID (pc_sample_install_gc_synch_gc_hooks)
+{
+ static int stat = -1; /* some clown may call this more than once */
+
+ if (stat != 0)
+ {
+ if ((stat = add_pre_gc_hook(pc_sample__pre_gc_gc_synch_hook)) != 0)
+ outf_error (";Could not add pre_gc GC synch hook. You.lose\n");
+
+ else if ((stat = add_post_gc_hook(pc_sample_post_gc_gc_synch_hook)) != 0)
+ outf_error (";Could not add post_gc GC synch hook. You.lose\n");
+
+ else if ((stat = add_post_gc_hook(resynch_IPPB_post_gc_hook)) != 0)
+ outf_error (";Could not add post GC IPPB re-synch hook. You.lose\n");
+
+ else if ((stat = add_post_gc_hook(resynch_CBPBs_post_gc_hook)) != 0)
+ outf_error (";Could not add post GC CBPB re-synch hook. You.lose\n");
+
+ outf_flush_error () ;
+ }
+ return (stat);
+}
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("%PC-SAMPLE/INSTALL-GC-SYNCH-GC-HOOKS",
+ Prim_pc_sample_install_gc_synch_gc_hooks, 0, 0,
+ "()\n\
+ This must be called once when PC sampling is enabled.\n\
+ \n\
+ If it returns #F then PC sampling must be disabled. You.lose\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT ((pc_sample_install_gc_synch_gc_hooks() == 0)));
+}
+\f
+/*****************************************************************************/
+static void
+DEFUN_VOID (pc_sample_disable_microcode)
+{
+ IPPB_disable (); /* From pcsiproc.c */
+ CBPBs_disable (); /* From pcscobl.c */
+}
+/*---------------------------------------------------------------------------*/
+/*---------------------------------------------------------------------------*/
+static void
+DEFUN_VOID (pc_sample_init_profile_buffer_states)
+{
+ init_dummy_profile_buffer_state ();
+ init_IPPB_profile_buffer_state ();
+ init_CBPB_profile_buffer_states();
+}
+/*---------------------------------------------------------------------------*/
+static int
+DEFUN_VOID (pc_sample_install_microcode)
+{
+ static int stat = -1; /* Some clown may call this more than once */
+
+ if (stat != 0)
+ {
+ if (! (Valid_Fixed_Obj_Vector ())) /* Profile tables are in the FOV */
+ {
+ outf_error
+ ("\npc_sample_install_microcode encountered an invalid Fixed Obj Vector.\n") ;
+ outf_flush_error () ;
+ }
+ else /* safe to init */
+ {
+ pc_sample_cache_GC_primitive_index();
+
+ pc_sample_init_profile_buffer_states();
+
+ if ((stat = pc_sample_install_gc_synch_gc_hooks()) != 0) /* Once only! */
+ {
+ outf_error
+ ("; PC Sample GC synch GC hooks installation failed (0x%x)\n");
+ outf_flush_error () ;
+ }
+ /* ... maybe more stuff here later ... */
+
+ if (stat != 0)
+ {
+ outf_error ("; PC Sample installation failed. You.lose\n");
+ outf_flush_error () ;
+ }
+ }
+ }
+ return (stat);
+}
+/*---------------------------------------------------------------------------*/
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("%PC-SAMPLE/INSTALL-MICROCODE",
+ Prim_pc_sample_install_microcode, 0, 0,
+ "()\n\
+ Installs the microcode support structures for PC sampling.\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT ((pc_sample_install_microcode() == 0)));
+}
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("%PC-SAMPLE/DISABLE-MICROCODE",
+ Prim_pc_sample_disable_microcode, 0, 0,
+ "()\n\
+ Disables the microcode support structures for PC sampling.\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ pc_sample_disable_microcode ();
+ PRIMITIVE_RETURN (UNSPECIFIC) ;
+}
+/*****************************************************************************/
+#endif /* HAVE_ITIMER */
+#endif /* REALLY_INCLUDE_PROFILE_CODE */
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: pcsample.scm,v 1.1 1995/07/28 14:14:08 adams Exp $
+
+Copyright (c) 1995 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+#|
+TODO:
+ Flonum in counts should be coerced into exacts straight away.
+ Make profile tables hold their elements weakly again (?)
+ Reset should preserve enable/disable state.
+ Separate timing from sampling.
+|#
+
+;;;; PC Sampling
+;;; package: (pc-sample)
+
+(declare (usual-integrations))
+\f
+(define (initialize-package!)
+ (set! *pc-sample/state* 'UNINITIALIZED)
+ (set! *pc-sample/sample-interval* pc-sample/default-sample-interval)
+ (install))
+
+(define-primitives
+ (pc-sample/timer-clear 0)
+ (pc-sample/timer-set 2)
+ (%pc-sample/halted? 0) ; super secret state hook
+ (pc-sample/spill-GC-samples-into-primitive-table 0)
+ ( interp-proc-profile-buffer/install 1)
+ ( interp-proc-profile-buffer/disable 0)
+ (purified-code-block-profile-buffers/install 2)
+ ( heathen-code-block-profile-buffers/install 2)
+ (purified-code-block-profile-buffers/disable 0)
+ ( heathen-code-block-profile-buffers/disable 0)
+ ;; Following for runtime/microcode installation only
+ (%pc-sample/install-microcode 0)
+ (%pc-sample/disable-microcode 0)
+ )
+
+(define index:pc-sample/builtin-table)
+(define index:pc-sample/utility-table)
+(define index:pc-sample/primitive-table)
+(define index:pc-sample/code-block-table)
+(define index:pc-sample/purified-code-block-block-buffer)
+(define index:pc-sample/purified-code-block-offset-buffer)
+(define index:pc-sample/heathen-code-block-block-buffer)
+(define index:pc-sample/heathen-code-block-offset-buffer)
+(define index:pc-sample/interp-proc-buffer)
+(define index:pc-sample/prob-comp-table)
+(define index:pc-sample/UFO-table)
+
+(define (install-indices) ; see utabmd.scm
+ (set! index:pc-sample/builtin-table
+ (fixed-objects-vector-slot 'PC-Sample/Builtin-Table))
+ (set! index:pc-sample/utility-table
+ (fixed-objects-vector-slot 'PC-Sample/Utility-Table))
+ (set! index:pc-sample/primitive-table
+ (fixed-objects-vector-slot 'PC-Sample/Primitive-Table))
+ (set! index:pc-sample/code-block-table
+ (fixed-objects-vector-slot 'PC-Sample/Code-Block-Table))
+ (set! index:pc-sample/purified-code-block-block-buffer
+ (fixed-objects-vector-slot 'PC-Sample/Purified-Code-Block-Block-Buffer))
+ (set! index:pc-sample/purified-code-block-offset-buffer
+ (fixed-objects-vector-slot 'PC-Sample/Purified-Code-Block-Offset-Buffer))
+ (set! index:pc-sample/heathen-code-block-block-buffer
+ (fixed-objects-vector-slot 'PC-Sample/Heathen-Code-Block-Block-Buffer))
+ (set! index:pc-sample/heathen-code-block-offset-buffer
+ (fixed-objects-vector-slot 'PC-Sample/Heathen-Code-Block-Offset-Buffer))
+ (set! index:pc-sample/interp-proc-buffer
+ (fixed-objects-vector-slot 'PC-Sample/Interp-Proc-Buffer))
+ (set! index:pc-sample/prob-comp-table
+ (fixed-objects-vector-slot 'PC-Sample/Prob-Comp-Table))
+ (set! index:pc-sample/UFO-table
+ (fixed-objects-vector-slot 'PC-Sample/UFO-Table))
+ )
+\f
+;; Sample while running pc-sample interrupt handling code?
+
+(define *pc-sample/sample-sampler?* #F) ; Ziggy wants to, but nobody else...
+
+;; Sample Interval
+
+(define *pc-sample/sample-interval*)
+(define pc-sample/default-sample-interval 20) ; milliseconds (i.e. 50Hz-ish)
+
+(define (pc-sample/sample-interval)
+ "()\n\
+ Returns the interval (in milliseconds) between the completion of one\n\
+ PC sampling and the initiation of the next PC sampling.\n\
+ This value may be changed by invoking:\n\
+ (PC-SAMPLE/SET-SAMPLE-INTERVAL <interval>)\n\
+ where <interval> is an exact positive integer expressing milliseconds.\n\
+ The initial value for this implicit system state variable is determined\n\
+ by the value returned by the expression: (PC-SAMPLE/DEFAULT-SAMPLE-INTERVAL)\
+ "
+ *pc-sample/sample-interval*) ; Fear not: package inits to default
+
+(define (pc-sample/set-sample-interval #!optional interval)
+ "(#!OPTIONAL interval)\n\
+ Sets the interval between the completion of one PC sampling and the\n\
+ initiation of the next PC sampling to be roughly INTERVAL milliseconds.\n\
+ If no INTERVAL argument is supplied, it defaults to the value returned by\n\
+ the expression (PC-SAMPLE/DEFAULT-SAMPLE-INTERVAL).\
+ "
+ (set! *pc-sample/sample-interval*
+ (cond ((default-object? interval)
+ pc-sample/default-sample-interval)
+ ((zero? interval)
+ (cond (*pc-sample/noisy?*
+ (display
+ (string-append "\n;; PC Sampling has been disabled "
+ "via a 0 msec sampling interval."))))
+ 0)
+ ((negative? interval) ; Smart ass.
+ (display (string-append
+ "\n"
+ ";;-----------\n"
+ ";; WARNING --\n"
+ ";;-----------\n"
+ ";;\n"
+ ";; Your hardware configuration cannot "
+ "support negative PC sampling intervals.\n"
+ ";; Consult your local hardware distributor for an "
+ "FTL co-processor upgrade kit.\n"
+ ";;\n"
+ ";; In the meantime, a sample interval of 1 msec "
+ "will be used instead.\n"
+ ";;\n"
+ ";; Have a nice day, " (current-user-name) ".\n"))
+ 1)
+ ((not (integer? interval))
+ (error "PC Sampling interval must be a non-negative integer."
+ interval))
+ (else
+ interval)))
+ unspecific)
+
+(define *current-user-name-promise*)
+(define (current-user-name) (force *current-user-name-promise*))
+
+(define (install-current-user-name-promise)
+ (cond (*pc-sample/install-verbosity?*
+ (newline)
+ (display "Installing current user name promise...")
+ (newline)))
+ (set! *current-user-name-promise* (delay (unix/current-user-name)))
+ unspecific)
+
+;; Sample State Regulation
+
+(define *pc-sample/state*)
+(define (pc-sample/state)
+ *pc-sample/state*)
+(define (pc-sample/set-state! new-state)
+ (set! *pc-sample/state* new-state))
+
+(define (pc-sample/uninitialized?)
+ (eq? (pc-sample/state) 'UNINITIALIZED))
+
+(define (pc-sample/init #!optional start?)
+ "(#!OPTIONAL start?)\n\
+ Resets all PC sampling tables and sets the sampling interval to the\n\
+ system default sampling interval.\n\
+ This is the preferred way to initialize PC sampling in the system.\n\
+ If the optional START? argument is supplied, PC sampling commences ASAP.\n\
+ Otherwise, (PC-SAMPLE/START) may be invoked to commence sampling, whereupon\n\
+ the evolving state of the PC sampling tables and counters may be monitored\n\
+ by invoking: (PC-SAMPLE/STATUS).\
+ "
+ (pc-sample/reset)
+ (pc-sample/set-state! 'INITIALIZED)
+ (if (or (default-object? start?) (not start?))
+ (pc-sample/set-sample-interval)
+ (pc-sample/start))
+ unspecific)
+
+(define (pc-sample/initialized?)
+ (not (pc-sample/uninitialized?)))
+
+
+(define *pc-sample/noisy?* #F)
+
+(define (pc-sample/start #!optional interval)
+ "(#!OPTIONAL interval)\n\
+ Enables periodic sampling of the virtual Program Counter by starting the\n\
+ PC sampling interrupt timer. Note that this does *not* initialize the PC\n\
+ sampling tables into which the sampling profile information is gathered.\n\
+ Unless/until these tables are initialized, no gathering of sampling info\n\
+ will be recorded, although the PC sampling interrupts will be issued and\n\
+ processed: the data will just not be recorded. To initiate sampling, refer\n\
+ to (PC-SAMPLE/INIT) instead. By contrast, PC-SAMPLE/START serves two pur-\n\
+ poses: 1) it is useful for unsuspending PC sampling after one has issued\n\
+ a (PC-SAMPLE/STOP), and 2) it is useful for debuggering the interrupt/trap\n\
+ mechanism for processing periodic PC sampling.\n\
+ \n\
+ The optional INTERVAL argument specifies how many milliseconds after a\n\
+ PC sample completes should the next PC sample be attempted.\n\
+ The evolving state of the PC sampling tables and counters may be monitored\n\
+ by invoking: (PC-SAMPLE/STATUS).\
+ "
+ (cond ((not (default-object? interval))
+ (pc-sample/set-sample-interval interval)))
+ (let ((real-interval (pc-sample/sample-interval)))
+ (cond ((zero? real-interval)
+ (pc-sample/timer-clear)
+ (pc-sample/disable)
+ (cond (*pc-sample/noisy?*
+ (display
+ "\n;; PC Sampling DISABLED: by virtue of 0 msec interval")))
+ )
+ ((pc-sample/uninitialized?)
+ (pc-sample/init 'START))
+ (else
+ (cond (*pc-sample/noisy?*
+ (display (string-append "\n;; PC Sampling starting: "
+ (number->string real-interval)
+ " millisecond period."))))
+ (pc-sample/set-state! 'RUNNING)
+ (pc-sample/timer-set *ASAP* real-interval)))
+ )
+ unspecific)
+
+(define *ASAP* 1) ; cannot be 0... that would disable the timer.
+
+(define-integrable (pc-sample/running?)
+ (not (%pc-sample/halted?)))
+
+(define-integrable (pc-sample/started?)
+ (pc-sample/running?))
+
+
+(define (pc-sample/stop)
+ "()\n\
+ Halts PC sampling by disabling the sampling interrupt timer.\n\
+ No profiling state is reset so invoking (PC-SAMPLE/START <interval>)\n\
+ afterward will re-start profiling by accumulating into the existing state.\n\
+ By contrast, see PC-SAMPLE/ENABLE and PC-SAMPLE/DISABLE.\n\
+ The state of the PC sampling tables and counters existent at the time when\n\
+ the sampling was stopped may be monitored by invoking: (PC-SAMPLE/STATUS).\
+ "
+ (pc-sample/timer-clear)
+ (pc-sample/set-state! 'STOPPED)
+ (cond (*pc-sample/noisy?*
+ (display "\n;; PC Sampling stopped.")))
+ unspecific)
+
+(define-integrable (pc-sample/stopped?)
+ (%pc-sample/halted?))
+
+;; Status/Accessors
+
+;; Returns a structure of PC sampling profile information.
+;; This is useful for monitoring the evolving histogram of PC sampling data.
+
+(define-structure (pc-sample/status-record
+ (conc-name pc-sample/status/)
+ (constructor pc-sample/status
+ (#!optional builtin-table
+ utility-table
+ primitive-table
+ code-block-table
+ code-block-buffer/status
+ interp-proc-table
+ interp-proc-buffer/status
+ prob-comp-table
+ UFO-table)))
+ (builtin-table (pc-sample/builtin-table))
+ (utility-table (pc-sample/utility-table))
+ (primitive-table (pc-sample/primitive-table))
+ (code-block-table (pc-sample/code-block-table))
+ (code-block-buffer/status (pc-sample/code-block-buffer/status))
+ (interp-proc-table (pc-sample/interp-proc-table))
+ (interp-proc-buffer/status (pc-sample/interp-proc-buffer/status))
+ (prob-comp-table (pc-sample/prob-comp-table))
+ (UFO-table (pc-sample/UFO-table))
+ )
+
+(define pc-sample/builtin-table)
+(define pc-sample/utility-table)
+(define pc-sample/primitive-table)
+(define pc-sample/purified-code-block-block-buffer)
+(define pc-sample/purified-code-block-offset-buffer)
+(define pc-sample/heathen-code-block-block-buffer)
+(define pc-sample/heathen-code-block-offset-buffer)
+(define pc-sample/interp-proc-buffer)
+(define pc-sample/prob-comp-table)
+(define pc-sample/UFO-table)
+
+(define (pc-sample/code-block-table) (code-block-profile-table))
+(define (pc-sample/code-block-buffer/status) (code-block-profile-buffer/status))
+(define (pc-sample/interp-proc-table) (interp-proc-profile-table))
+(define (pc-sample/interp-proc-buffer/status)(interp-proc-profile-buffer/status))
+
+;; Exportable naming scheme
+(define (pc-sample/builtin/status)
+ (pc-sample/builtin-table))
+(define (pc-sample/utility/status)
+ (pc-sample/utility-table))
+(define (pc-sample/primitive/status)
+ (pc-sample/primitive-table))
+(define (pc-sample/code-block/status)
+ (pc-sample/code-block-table))
+(define (pc-sample/interp-proc/status)
+ (pc-sample/interp-proc-table))
+(define (pc-sample/prob-comp/status)
+ (pc-sample/prob-comp-table))
+(define (pc-sample/UFO/status)
+ (pc-sample/UFO-table))
+
+(define (generate:pc-sample/table-accessor index)
+ (lambda ()
+ (cond ((eq? index index:pc-sample/primitive-table)
+ (pc-sample/spill-GC-samples-into-primitive-table)))
+ (vector-ref (get-fixed-objects-vector) index)))
+
+(define (install-accessors)
+ (set! pc-sample/builtin-table
+ (generate:pc-sample/table-accessor index:pc-sample/builtin-table))
+ (set! pc-sample/utility-table
+ (generate:pc-sample/table-accessor index:pc-sample/utility-table))
+ (set! pc-sample/primitive-table
+ (generate:pc-sample/table-accessor index:pc-sample/primitive-table))
+ (set! pc-sample/purified-code-block-block-buffer
+ (generate:pc-sample/table-accessor index:pc-sample/purified-code-block-block-buffer))
+ (set! pc-sample/purified-code-block-offset-buffer
+ (generate:pc-sample/table-accessor index:pc-sample/purified-code-block-offset-buffer))
+ (set! pc-sample/heathen-code-block-block-buffer
+ (generate:pc-sample/table-accessor index:pc-sample/heathen-code-block-block-buffer))
+ (set! pc-sample/heathen-code-block-offset-buffer
+ (generate:pc-sample/table-accessor index:pc-sample/heathen-code-block-offset-buffer))
+ (set! pc-sample/interp-proc-buffer
+ (generate:pc-sample/table-accessor index:pc-sample/interp-proc-buffer))
+ (set! pc-sample/prob-comp-table
+ (generate:pc-sample/table-accessor index:pc-sample/prob-comp-table))
+ (set! pc-sample/UFO-table
+ (generate:pc-sample/table-accessor index:pc-sample/UFO-table))
+ )
+
+(define-structure (pc-sample/fixed-objects-record
+ (conc-name pc-sample/fixed-objects/)
+ (constructor pc-sample/fixed-objects
+ (#!optional builtin-table
+ utility-table
+ primitive-table
+ purified-cobl-block-buffer
+ purified-cobl-offset-buffer
+ heathen-cobl-block-buffer
+ heathen-cobl-offset-buffer
+ interp-proc-buffer
+ prob-comp-table
+ UFO-table)))
+ (builtin-table (pc-sample/builtin-table))
+ (utility-table (pc-sample/utility-table))
+ (primitive-table (pc-sample/primitive-table))
+ (purified-cobl-block-buffer (pc-sample/purified-code-block-block-buffer))
+ (purified-cobl-offset-buffer (pc-sample/purified-code-block-offset-buffer))
+ (heathen-cobl-block-buffer (pc-sample/heathen-code-block-block-buffer))
+ (heathen-cobl-offset-buffer (pc-sample/heathen-code-block-offset-buffer))
+ (interp-proc-buffer (pc-sample/interp-proc-buffer))
+ (prob-comp-table (pc-sample/prob-comp-table))
+ (UFO-table (pc-sample/UFO-table))
+ )
+
+;; Makers
+
+(define pc-sample/builtin-table/make)
+(define pc-sample/utility-table/make)
+(define pc-sample/primitive-table/make)
+(define pc-sample/code-block-buffer/make/purified-blocks)
+(define pc-sample/code-block-buffer/make/purified-offsets)
+(define pc-sample/code-block-buffer/make/heathen-blocks)
+(define pc-sample/code-block-buffer/make/heathen-offsets)
+(define pc-sample/interp-proc-buffer/make)
+(define pc-sample/prob-comp-table/make)
+(define pc-sample/UFO-table/make)
+
+(define (generate:pc-sample/table-maker length-thunk init-value-thunk)
+ (lambda ()
+ (make-initialized-vector (length-thunk)
+ (lambda (i) i (init-value-thunk)))))
+
+(define (generate:pc-sample/buffer-maker length-thunk)
+ (lambda ()
+ (make-vector (length-thunk)
+ ;; interp-proc-buffer is a buffer of interp-procs,
+ ;; not a table of counters.
+ #F)))
+
+(define (generate:pc-sample/counter-maker init-value-thunk)
+ (lambda ()
+ (vector (init-value-thunk) ; happy count
+ (init-value-thunk) ; sad count
+ )))
+
+(define (install-makers)
+ (set! pc-sample/builtin-table/make
+ (generate:pc-sample/table-maker get-builtin-count
+ pc-sample/init-datum))
+ (set! pc-sample/utility-table/make
+ (generate:pc-sample/table-maker get-utility-count
+ pc-sample/init-datum))
+ (set! pc-sample/primitive-table/make
+ (generate:pc-sample/table-maker get-primitive-count
+ pc-sample/init-datum))
+ (set! pc-sample/code-block-buffer/make/purified-blocks
+ (generate:pc-sample/buffer-maker code-block-profile-buffer/purified/length))
+ (set! pc-sample/code-block-buffer/make/purified-offsets
+ (generate:pc-sample/buffer-maker code-block-profile-buffer/purified/length))
+ (set! pc-sample/code-block-buffer/make/heathen-blocks
+ (generate:pc-sample/buffer-maker code-block-profile-buffer/heathen/length))
+ (set! pc-sample/code-block-buffer/make/heathen-offsets
+ (generate:pc-sample/buffer-maker code-block-profile-buffer/heathen/length))
+ (set! pc-sample/interp-proc-buffer/make
+ (generate:pc-sample/buffer-maker interp-proc-profile-buffer/length))
+ (set! pc-sample/prob-comp-table/make
+ (generate:pc-sample/counter-maker pc-sample/init-datum))
+ (set! pc-sample/UFO-table/make
+ (generate:pc-sample/counter-maker pc-sample/init-datum))
+ )
+
+(define (code-block-profile-buffer/purified/length) ; annoying alias
+ (purified-code-block-profile-buffer/length))
+(define (code-block-profile-buffer/heathen/length) ; disturbing alias
+ ( heathen-code-block-profile-buffer/length))
+
+(define (pc-sample/init-datum)
+ "()\n\
+ The initial PC sampling profile datum for each profiling table entry.\n\
+ This is a convenient data abstraction for later extending profiling\n\
+ data to be more than mere counts. More elaborate histograms are envisioned,\
+ including gathering of timing and type statistics.\
+ "
+;------------------------------------------------------------------------------
+; HORROR! When I used a constant 0.0, I found it shared throughout the
+; profile data structures... I think maybe my C manipulation is
+; updating in place rather than storing back into the vector(s).
+; Dr.Adams assisted me in defining this adorable little work around
+; as a means of confusing the compiler into CONS-ing up a bunch o'
+; floating point 0.0's.
+;------------------------------------------------------------------------------
+ (massive-kludge *kludgey-constant*)) ; for now, just a count
+
+(define *kludgey-constant* (flo:+ 37. 42.))
+
+(define (massive-kludge x)
+ (flo:- x *kludgey-constant*))
+;--------------------------------END-OF-HORROR---------------------------------
+
+;; Profile hashtables (for interp-procs [pcsiproc] & code blocks [pcscobl])
+
+(define make-profile-hash-table )
+(define profile-hash-table-car)
+(define profile-hash-table-cdr)
+
+(define (install-profile-hash-table)
+ (load-option 'hash-table) ; For code block profile tables
+
+;;;(set! make-profile-hash-table make-eq-hash-table); weakly held
+;;;(set! profile-hash-table-car weak-car)
+;;;(set! profile-hash-table-cdr weak-cdr)
+
+ (set! make-profile-hash-table ; strongly held
+ (strong-hash-table/constructor (lambda (obj modulus)
+ (modulo (object-hash obj) modulus))
+ eq?
+ #T))
+ (set! profile-hash-table-car car)
+ (set! profile-hash-table-cdr cdr)
+ )
+
+;; Old value caches
+
+;; Returns the profiling status in effect just before the last reset of any\n\
+;; PC sampling profile table.\
+
+(define-structure (pc-sample/status/previous-record
+ (conc-name pc-sample/status/previous/)
+ (constructor pc-sample/status/previous
+ (#!optional builtin-table
+ utility-table
+ primitive-table
+ code-block-table
+ code-block-buffer/status
+ interp-proc-table
+ interp-proc-buffer/status
+ prob-comp-table
+ UFO-table)))
+ (builtin-table (pc-sample/builtin-table/old))
+ (utility-table (pc-sample/utility-table/old))
+ (primitive-table (pc-sample/primitive-table/old))
+ (code-block-table (pc-sample/code-block-table/old))
+ (code-block-buffer/status (pc-sample/code-block-buffer/status/previous))
+ (interp-proc-table (pc-sample/interp-proc-table/old))
+ (interp-proc-buffer/status (pc-sample/interp-proc-buffer/status/previous))
+ (prob-comp-table (pc-sample/prob-comp-table/old))
+ (UFO-table (pc-sample/UFO-table/old))
+ )
+
+(define *pc-sample/builtin-table/old* #F)
+(define (pc-sample/builtin-table/old)
+ *pc-sample/builtin-table/old*)
+
+(define *pc-sample/utility-table/old* #F)
+(define (pc-sample/utility-table/old)
+ *pc-sample/utility-table/old*)
+
+(define *pc-sample/primitive-table/old* #F)
+(define (pc-sample/primitive-table/old)
+ *pc-sample/primitive-table/old*)
+
+(define (pc-sample/code-block-table/old)
+ (code-block-profile-table/old))
+
+(define (pc-sample/code-block-buffer/status/previous)
+ (code-block-profile-buffer/status/previous))
+
+(define (pc-sample/interp-proc-table/old)
+ (interp-proc-profile-table/old))
+
+(define (pc-sample/interp-proc-buffer/status/previous)
+ (interp-proc-profile-buffer/status/previous))
+
+(define *pc-sample/prob-comp-table/old* #F)
+(define (pc-sample/prob-comp-table/old)
+ *pc-sample/prob-comp-table/old*)
+
+(define *pc-sample/UFO-table/old* #F)
+(define (pc-sample/UFO-table/old)
+ *pc-sample/UFO-table/old*)
+
+;; quirk... synchronize C buffer state w/ Scheme buffer state
+
+(define-integrable (fixed-interp-proc-profile-buffer/disable)
+ (interp-proc-profile-buffer/disable))
+(define-integrable (fixed-interp-proc-profile-buffer/install buffer)
+ (interp-proc-profile-buffer/install buffer))
+
+;; quirks... for export to pcscobl.scm [temporary kludges]
+
+(define-integrable (fixed-purified-code-block-profile-buffers/disable)
+ (purified-code-block-profile-buffers/disable))
+(define-integrable ( fixed-heathen-code-block-profile-buffers/disable)
+ ( heathen-code-block-profile-buffers/disable))
+
+(define-integrable (fixed-purified-code-block-profile-buffers/install buff1
+ buff2)
+ (purified-code-block-profile-buffers/install buff1
+ buff2))
+(define-integrable ( fixed-heathen-code-block-profile-buffers/install buff1
+ buff2)
+ ( heathen-code-block-profile-buffers/install buff1
+ buff2))
+
+;; Resetters TODO: Worry about disabling while copying? Not for now.
+;; Maybe employ W/O-INTERRUPTS later. Maybe not.
+
+(define (pc-sample/reset #!optional disable?)
+ "(#!OPTIONAL disable?)\n\
+ Resets all the PC Sampling profile tables and counters, initializing them\n\
+ if they have never yet been initialized.\n\
+ If the optional DISABLE? argument is supplied, PC Sampling is then\n\
+ disabled by virtue of disabling the PC sampling timer interrupt.\n\
+ PC sampling can be re-enabled by typing: (PC-SAMPLE/ENABLE)\n\
+ \n\
+ For more fine grained enabling/disabling of various kinds of sampling data\n\
+ consider:\n\
+ \n\
+ PC-SAMPLE/BUILTIN/ENABLE, PC-SAMPLE/BUILTIN/DISABLE,\n\
+ PC-SAMPLE/UTILITY/ENABLE, PC-SAMPLE/UTILITY/DISABLE,\n\
+ PC-SAMPLE/PRIMITIVE/ENABLE, PC-SAMPLE/PRIMITIVE/DISABLE,\n\
+ PC-SAMPLE/CODE-BLOCK/ENABLE, PC-SAMPLE/CODE-BLOCK/DISABLE,\n\
+ PC-SAMPLE/PURIFIED-CODE-BLOCK/ENABLE, PC-SAMPLE/PURIFIED-CODE-BLOCK/DISABLE,\n\
+ PC-SAMPLE/HEATHEN-CODE-BLOCK/ENABLE, PC-SAMPLE/HEATHEN-CODE-BLOCK/DISABLE,\n\
+ PC-SAMPLE/INTERP-PROC/ENABLE, PC-SAMPLE/INTERP-PROC/DISABLE,\n\
+ PC-SAMPLE/PROB-COMP/ENABLE, PC-SAMPLE/PROB-COMP/DISABLE,\n\
+ PC-SAMPLE/UFO/ENABLE, PC-SAMPLE/UFO/DISABLE\
+ "
+ (cond ((or (default-object? disable?) (not disable?))
+ (pc-sample/builtin/reset)
+ (pc-sample/utility/reset)
+ (pc-sample/primitive/reset)
+ (pc-sample/code-block/reset)
+ (pc-sample/interp-proc/reset)
+ (pc-sample/prob-comp/reset)
+ (pc-sample/UFO/reset)
+ ;; resetting in itself does not alter the state of the pc-sampling...
+ 'RESET)
+ (else
+ (pc-sample/builtin/reset disable?)
+ (pc-sample/utility/reset disable?)
+ (pc-sample/primitive/reset disable?)
+ (pc-sample/code-block/reset disable?)
+ (pc-sample/interp-proc/reset disable?)
+ (pc-sample/prob-comp/reset disable?)
+ (pc-sample/UFO/reset disable?)
+ (cond ((pc-sample/initialized?)
+ (pc-sample/set-state! 'DISABLED)
+ 'RESET-AND-DISABLED)
+ (else
+ 'STILL-UNINITIALIZED)))))
+
+(define pc-sample/builtin/reset)
+(define pc-sample/utility/reset)
+(define pc-sample/primitive/reset)
+(define (pc-sample/code-block/reset #!optional disable?) ; alias
+ (if (or (default-object? disable?) (not disable?))
+ (code-block-profile-tables/reset)
+ (code-block-profile-tables/reset disable?)))
+(define (pc-sample/purified-code-block/reset #!optional disable?) ; alias
+ (if (or (default-object? disable?) (not disable?))
+ (purified-code-block-profile-tables/reset)
+ (purified-code-block-profile-tables/reset disable?)))
+(define (pc-sample/heathen-code-block/reset #!optional disable?) ; alias
+ (if (or (default-object? disable?) (not disable?))
+ (heathen-code-block-profile-tables/reset)
+ (heathen-code-block-profile-tables/reset disable?)))
+(define (pc-sample/interp-proc/reset #!optional disable?) ; alias
+ (if (or (default-object? disable?) (not disable?))
+ (interp-proc-profile-table/reset)
+ (interp-proc-profile-table/reset disable?)))
+(define pc-sample/prob-comp/reset)
+(define pc-sample/UFO/reset)
+
+;; TODO: Would be very nice to maintain a bit-vector of the states of the
+;; sundry profiling tables: enabled/disabled
+
+(define (generate:pc-sample/table-resetter index save-oldy default-table-maker)
+ (lambda (#!optional disable?)
+ (save-oldy)
+ (let ((enabling? (or (default-object? disable?) (not disable?))))
+ (vector-set! (get-fixed-objects-vector)
+ index
+ (if enabling?
+ (default-table-maker)
+ #F))
+ (cond (enabling?
+ (cond ((pc-sample/uninitialized?)
+ (pc-sample/set-state! 'RESET)))
+ 'RESET-AND-ENABLED)
+ ((pc-sample/uninitialized?)
+ 'STILL-UNINITIALIZED)
+ (else
+ ;; TODO: should recognize when the last is disabled and mark
+ ;; overall sampling state as disabled then.
+ 'RESET-AND-DISABLED)))))
+
+;; TODO: To avoid gratuitous cons-ing, really should always maintain two
+;; of each table (current and old) then flip the two on reset, re-
+;; initializing the new current (former old). [double buffer]
+
+(define (install-resetters)
+ (set! pc-sample/builtin/reset
+ (generate:pc-sample/table-resetter
+ index:pc-sample/builtin-table
+ (lambda () (set! *pc-sample/builtin-table/old*
+ (pc-sample/builtin-table)))
+ pc-sample/builtin-table/make))
+ (set! pc-sample/utility/reset
+ (generate:pc-sample/table-resetter
+ index:pc-sample/utility-table
+ (lambda () (set! *pc-sample/utility-table/old*
+ (pc-sample/utility-table)))
+ pc-sample/utility-table/make))
+ (set! pc-sample/primitive/reset
+ (generate:pc-sample/table-resetter
+ index:pc-sample/primitive-table
+ (lambda () (set! *pc-sample/primitive-table/old*
+ (pc-sample/primitive-table)))
+ pc-sample/primitive-table/make))
+ (set! pc-sample/prob-comp/reset
+ (generate:pc-sample/table-resetter
+ index:pc-sample/prob-comp-table
+ (lambda () (set! *pc-sample/prob-comp-table/old*
+ (pc-sample/prob-comp-table)))
+ pc-sample/prob-comp-table/make))
+ (set! pc-sample/UFO/reset
+ (generate:pc-sample/table-resetter
+ index:pc-sample/UFO-table
+ (lambda () (set! *pc-sample/UFO-table/old*
+ (pc-sample/UFO-table)))
+ pc-sample/UFO-table/make))
+ )
+
+;; Enablers/Disablers
+
+(define (pc-sample/enable)
+ "()\n\
+ Resets all PC sampling tables and counters and re-starts the PC\n\
+ sampling periodic interrupt timer.\n\
+ The old state/status of the PC sampling tables and counters can be\n\
+ monitored by invoking: (PC-SAMPLE/STATUS/PREVIOUS).\n\
+ The evolving state of the PC sampling tables and counters may be monitored\n\
+ by invoking: (PC-SAMPLE/STATUS).\n\
+ \n\
+ For more fine grained enabling/disabling of various kinds of sampling data\n\
+ consider:\n\
+ \n\
+ PC-SAMPLE/BUILTIN/ENABLE, PC-SAMPLE/BUILTIN/DISABLE,\n\
+ PC-SAMPLE/UTILITY/ENABLE, PC-SAMPLE/UTILITY/DISABLE,\n\
+ PC-SAMPLE/PRIMITIVE/ENABLE, PC-SAMPLE/PRIMITIVE/DISABLE,\n\
+ PC-SAMPLE/CODE-BLOCK/ENABLE, PC-SAMPLE/CODE-BLOCK/DISABLE,\n\
+ PC-SAMPLE/PURIFIED-CODE-BLOCK/ENABLE, PC-SAMPLE/PURIFIED-CODE-BLOCK/DISABLE,\n\
+ PC-SAMPLE/HEATHEN-CODE-BLOCK/ENABLE, PC-SAMPLE/HEATHEN-CODE-BLOCK/DISABLE,\n\
+ PC-SAMPLE/INTERP-PROC/ENABLE, PC-SAMPLE/INTERP-PROC/DISABLE,\n\
+ PC-SAMPLE/PROB-COMP/ENABLE, PC-SAMPLE/PROB-COMP/DISABLE,\n\
+ PC-SAMPLE/UFO/ENABLE, PC-SAMPLE/UFO/DISABLE\
+ "
+ (pc-sample/reset))
+
+(define (pc-sample/disable)
+ "()\n\
+ Resets all the PC sampling tables and counters then disables the PC\n\
+ sampling periodic interrupt timer.\n\
+ The old state/status of the PC sampling tables and counters can be\n\
+ monitored by invoking: (PC-SAMPLE/STATUS/PREVIOUS).\n\
+ \n\
+ For more fine grained enabling/disabling of various kinds of sampling data\n\
+ consider:\n\
+ \n\
+ PC-SAMPLE/BUILTIN/ENABLE, PC-SAMPLE/BUILTIN/DISABLE,\n\
+ PC-SAMPLE/UTILITY/ENABLE, PC-SAMPLE/UTILITY/DISABLE,\n\
+ PC-SAMPLE/PRIMITIVE/ENABLE, PC-SAMPLE/PRIMITIVE/DISABLE,\n\
+ PC-SAMPLE/CODE-BLOCK/ENABLE, PC-SAMPLE/CODE-BLOCK/DISABLE,\n\
+ PC-SAMPLE/PURIFIED-CODE-BLOCK/ENABLE, PC-SAMPLE/PURIFIED-CODE-BLOCK/DISABLE,\n\
+ PC-SAMPLE/HEATHEN-CODE-BLOCK/ENABLE, PC-SAMPLE/HEATHEN-CODE-BLOCK/DISABLE,\n\
+ PC-SAMPLE/INTERP-PROC/ENABLE, PC-SAMPLE/INTERP-PROC/DISABLE,\n\
+ PC-SAMPLE/PROB-COMP/ENABLE, PC-SAMPLE/PROB-COMP/DISABLE,\n\
+ PC-SAMPLE/UFO/ENABLE, PC-SAMPLE/UFO/DISABLE\
+ "
+ (pc-sample/reset 'DISABLE))
+
+
+(define (pc-sample/builtin/enable) (pc-sample/builtin/reset))
+(define (pc-sample/builtin/disable) (pc-sample/builtin/reset 'DISABLE))
+
+(define (pc-sample/utility/enable) (pc-sample/utility/reset))
+(define (pc-sample/utility/disable) (pc-sample/utility/reset 'DISABLE))
+
+(define (pc-sample/primitive/enable) (pc-sample/primitive/reset))
+(define (pc-sample/primitive/disable) (pc-sample/primitive/reset 'DISABLE))
+
+(define (pc-sample/code-block/enable) (code-block-profile-tables/enable)) ;cob
+(define (pc-sample/code-block/disable) (code-block-profile-tables/disable));cob
+
+(define (pc-sample/purified-code-block/enable) (purified-code-block-profile-tables/enable)) ;cob
+(define (pc-sample/purified-code-block/disable)(purified-code-block-profile-tables/disable));cob
+
+(define (pc-sample/heathen-code-block/enable) (heathen-code-block-profile-tables/enable)) ;cob
+(define (pc-sample/heathen-code-block/disable) (heathen-code-block-profile-tables/disable));cob
+
+(define (pc-sample/interp-proc/enable) (interp-proc-profile-table/enable)) ;clo
+(define (pc-sample/interp-proc/disable) (interp-proc-profile-table/disable)) ;clo
+
+(define (pc-sample/prob-comp/enable) (pc-sample/prob-comp/reset))
+(define (pc-sample/prob-comp/disable) (pc-sample/prob-comp/reset 'DISABLE))
+
+(define (pc-sample/UFO/enable) (pc-sample/UFO/reset))
+(define (pc-sample/UFO/disable) (pc-sample/UFO/reset 'DISABLE))
+\f
+#|
+ |
+ | --------------------------------------------------
+ | --------------------------------------------------
+ |
+ | THIS PAGE INTENTIONALLY LEFT VERY NEARLY BLANK
+ |
+ | --------------------------------------------------
+ | --------------------------------------------------
+ |
+ | Seriously, though, user interface hacks moved to a separate file 'cause
+ | I could not decide on a stable set of basic display mechanisms... I leave
+ | it to the SWAT Team to deal with all that rot. For now, see PCDISP.SCM.
+ |
+ |#
+\f
+;;; Call-with-pc-sampling
+
+(define *pc-sample/top-level?* #T)
+(define *pc-sample/wan-sampling?* #F) ; With-Absolutely-No-PC-Sampling
+(define *pc-sample/timing?* #F)
+(define *pc-sample/timing-deficit?* #F)
+
+(define *pc-sample/last-sampling-duration-deficit* 0 )
+(define *pc-sample/last-sampling-duration-deficit/no-gc* 0.)
+(define *pc-sample/last-sampling-duration-deficit/real* 0 )
+
+
+(define (call-with-pc-sampling thunk #!optional untimed? displayer)
+ (let ((restart? (and (pc-sample/running?)
+ (begin (pc-sample/stop) ; stop sampling until in d-wind
+ #T))))
+ (dynamic-wind
+ (lambda () 'restart-sampling-even-when-thunk-craps-out)
+ (lambda ()
+ (let* ((tople? *pc-sample/top-level?*)
+ (defle? *pc-sample/timing-deficit?*)
+ (timing? *pc-sample/timing?*)
+ (timing-up? (and timing? (not defle?)))
+ (wanna-time? (or (default-object? untimed?) (not untimed?)))
+ (time-it? (and wanna-time? (not timing?)))
+ (deficit? (and (not wanna-time?) timing? ))
+ (neficit? (and time-it? defle?)) ; nix enclosing deficit charge
+ )
+ (cond (tople? ; tolerate nesting of cwpcs
+ (pc-sample/reset))) ; start afresh inside thunk
+ (cond ((and tople? time-it?) ; erase deficit...
+ ;;... by first killing all the liberals
+ '(for-each (lambda (x) (kill x)) *liberals*)
+ (set! *pc-sample/last-sampling-duration-deficit* 0 )
+ (set! *pc-sample/last-sampling-duration-deficit/no-gc* 0.)
+ (set! *pc-sample/last-sampling-duration-deficit/real* 0 )))
+ (with-values
+ (lambda ()
+ ;; Uhm... would wrap fluid-let around d-wind body but then it
+ ;; would be included in the sample/timing: not desirable.
+ (fluid-let ((*pc-sample/top-level?* #F)
+ (*pc-sample/timing?* (or time-it? timing?))
+ (*pc-sample/timing-deficit?* (or deficit? defle?)))
+ (dynamic-wind (lambda () (or *pc-sample/wan-sampling?*
+ (pc-sample/start)))
+ (if (eq? wanna-time? timing-up?)
+ (lambda () (values (thunk)
+ 'runtime-fnord!
+ 'process-time-fnord!
+ 'real-time-fnord!))
+ (lambda ()
+ (let* ((start-rt ( runtime ))
+ (start-ptc (process-time-clock))
+ (start-rtc ( real-time-clock))
+ (result (thunk))
+ ( end-rt ( runtime ))
+ ( end-ptc (process-time-clock))
+ ( end-rtc ( real-time-clock)))
+ (pc-sample/stop) ; dun sample following
+ (let ((p-s/no-gc (- end-rt start-rt ))
+ (p-ticks (- end-ptc start-ptc))
+ (r-ticks (- end-rtc start-rtc)))
+ (values result
+ p-s/no-gc
+ p-ticks
+ r-ticks)))))
+ (lambda () (pc-sample/stop)))))
+ (lambda (result process-secs/no-gc process-ticks real-ticks)
+ ;; Probably not the best control paradigm in the world.
+ ;; If you know of a more elegant solution, I'd sure like
+ ;; to hear it. -ziggy@ai.mit.edu
+ (cond
+ ((or deficit? neficit?)
+ (let ((t:mixin (if deficit? int:+ int:-))
+ (s:mixin (if deficit? flo:+ flo:-)))
+ (set! *pc-sample/last-sampling-duration-deficit*
+ (t:mixin *pc-sample/last-sampling-duration-deficit*
+ process-ticks))
+ (set! *pc-sample/last-sampling-duration-deficit/no-gc*
+ (s:mixin *pc-sample/last-sampling-duration-deficit/no-gc*
+ process-secs/no-gc))
+ (set! *pc-sample/last-sampling-duration-deficit/real*
+ (t:mixin *pc-sample/last-sampling-duration-deficit/real*
+ real-ticks)))))
+ (cond ((and tople? time-it?)
+ (time-display thunk
+ process-ticks
+ process-secs/no-gc
+ real-ticks)))
+ (cond (tople?
+ (cond ((default-object? displayer)
+ (*pc-sample/default-status-displayer*))
+ (displayer
+ (displayer)))))
+ result))))
+ (lambda ()
+ (cond (restart?
+ (pc-sample/start)))))))
+\f
+;;; Time Display
+
+(define *pc-sample/time-display?* #T)
+(define *pc-sample/time-display/running-time-too?* #T)
+(define *pc-sample/time-display/non-gc-time-too?* #T)
+
+(define *pc-sample/time-display/real-time-too?* #F)
+
+(define (time-display thunk p-ticks p-secs/no-gc r-ticks)
+ ;; not integrable so customizable
+ (cond
+ (*pc-sample/time-display?*
+ (let ((stealth-t *pc-sample/last-sampling-duration-deficit* )
+ (stealth-s/no-gc *pc-sample/last-sampling-duration-deficit/no-gc*)
+ (stealth-t/real *pc-sample/last-sampling-duration-deficit/real* ))
+ (let (( delta-t (int:- p-ticks stealth-t ))
+ ( delta-s/no-gc (flo:- p-secs/no-gc stealth-s/no-gc))
+ ( delta-t/real (int:- r-ticks stealth-t/real )))
+ (let ((delta-s
+ (flo:round-to-magnification
+ (internal-time/ticks->seconds delta-t )
+ *flo:round-to-magnification/scale*))
+ (delta-s/real
+ (flo:round-to-magnification
+ (internal-time/ticks->seconds delta-t/real)
+ *flo:round-to-magnification/scale*)))
+ (let ((delta-s/gc-only (flo:- delta-s delta-s/no-gc)))
+ (for-each
+ display
+ `("\n;;;"
+ "\n;;; Timed funcall of " ,thunk
+ "\n;;; took (in secs) " ,delta-s
+ ,@(if *pc-sample/time-display/running-time-too?*
+ `("\n;;; running: " ,delta-s/no-gc)
+ '())
+ ,@(if *pc-sample/time-display/non-gc-time-too?*
+ `("\n;;; GC time: " ,delta-s/gc-only)
+ '())
+ ,@(if *pc-sample/time-display/real-time-too?*
+ `("\n;;; wall clock time: " ,delta-s/real)
+ '())
+ "\n;;;\n"
+ ,@(if (fix:zero? stealth-t)
+ '()
+ (let ((stealth-s
+ (flo:round-to-magnification
+ (internal-time/ticks->seconds stealth-t )
+ *flo:round-to-magnification/scale*))
+ (stealth-s/real
+ (flo:round-to-magnification
+ (internal-time/ticks->seconds stealth-t/real)
+ *flo:round-to-magnification/scale*)))
+ (let ((stealth-s/gc-only
+ (flo:- stealth-s stealth-s/gc-only)))
+ "\n;;; discounting " ,stealth-s
+ ,@(if *pc-sample/time-display/running-time-too?*
+ `("\n;;; running: " ,stealth-s/no-gc)
+ '())
+ ,@(if *pc-sample/time-display/non-gc-time-too?*
+ `("\n;;; GC time: " ,stealth-s/gc-only)
+ '())
+ ,@(if *pc-sample/time-display/real-time-too?*
+ `("\n;;; wall clock time: " ,stealth-s/real)
+ '())
+ "\n;;; seconds spent in clandestine activities."
+ "\n;;;\n"))))
+ ))))))))
+
+(define-integrable (flo:round-to-magnification num magnification)
+ (flo:/ (flo:round (flo:* num magnification)) magnification))
+
+(define *flo:round-to-magnification/scale* 1000000.)
+\f
+
+(define (call-with-builtin-pc-sampling thunk)
+ (call-with-pc-sampling thunk pc-sample/builtin/status/display))
+
+(define (call-with-utility-pc-sampling thunk)
+ (call-with-pc-sampling thunk pc-sample/utility/status/display))
+
+(define (call-with-primitive-pc-sampling thunk)
+ (call-with-pc-sampling thunk pc-sample/primitive/status/display))
+
+(define (call-with-code-block-pc-sampling thunk)
+ (call-with-pc-sampling thunk pc-sample/code-block/status/display))
+
+(define (call-with-interp-proc-pc-sampling thunk)
+ (call-with-pc-sampling thunk pc-sample/interp-proc/status/display))
+
+(define (call-with-prob-comp-pc-sampling thunk)
+ (call-with-pc-sampling thunk pc-sample/prob-comp/status/display))
+
+(define (call-with-UFO-pc-sampling thunk)
+ (call-with-pc-sampling thunk pc-sample/UFO/status/display))
+
+;;; With-pc-sampling
+
+(define (with-pc-sampling proc . args)
+ (call-with-pc-sampling (lambda () (apply proc args))))
+(define (with-builtin-pc-sampling proc . args)
+ (call-with-builtin-pc-sampling (lambda () (apply proc args))))
+(define (with-utility-pc-sampling proc . args)
+ (call-with-utility-pc-sampling (lambda () (apply proc args))))
+(define (with-primitive-pc-sampling proc . args)
+ (call-with-primitive-pc-sampling (lambda () (apply proc args))))
+(define (with-code-block-pc-sampling proc . args)
+ (call-with-code-block-pc-sampling (lambda () (apply proc args))))
+(define (with-interp-proc-pc-sampling proc . args)
+ (call-with-interp-proc-pc-sampling (lambda () (apply proc args))))
+(define (with-prob-comp-pc-sampling proc . args)
+ (call-with-prob-comp-pc-sampling (lambda () (apply proc args))))
+(define (with-UFO-pc-sampling proc . args)
+ (call-with-UFO-pc-sampling (lambda () (apply proc args))))
+\f
+;;; Call-without-pc-sampling
+
+(define (call-without-pc-sampling thunk #!optional untimed?)
+ ;; If UNTIMED? then subtract time in thunk from total time.
+ (let ((restart? (and (pc-sample/running?)
+ (begin (pc-sample/stop) ; stop ASAP
+ #T))))
+ (dynamic-wind
+ (lambda () 'restart-sampling-even-when-thunk-craps-out)
+ (lambda ()
+ (let* ((tople? *pc-sample/top-level?*)
+ (defle? *pc-sample/timing-deficit?*)
+ (timing? *pc-sample/timing?*)
+ (timing-up? (and timing? (not defle?)))
+ (wanna-time? (or (default-object? untimed?) (not untimed?)))
+ (time-it? (and wanna-time? (not timing?)))
+ (deficit? (and (not wanna-time?) timing? ))
+ (neficit? (and time-it? defle?)) ; nix enclosing deficit charge
+ )
+ (cond ((and tople? time-it?) ; erase deficit...
+ ;;... by first killing all the liberals
+ '(for-each (lambda (x) (kill x)) *liberals*)
+ (set! *pc-sample/last-sampling-duration-deficit* 0 )
+ (set! *pc-sample/last-sampling-duration-deficit/no-gc* 0.)
+ (set! *pc-sample/last-sampling-duration-deficit/real* 0 )))
+ ;; Really just want fluid-let around THUNK calls, but what the hay.
+ (fluid-let ((*pc-sample/top-level?* #F)
+ (*pc-sample/timing?* (or time-it? timing?))
+ (*pc-sample/timing-deficit?* (or deficit? defle?)))
+ (if (eq? wanna-time? timing-up?)
+ (thunk)
+ (let* ((start-rt ( runtime ))
+ (start-ptc (process-time-clock))
+ (start-rtc ( real-time-clock))
+ (result (thunk))
+ ( end-rt ( runtime ))
+ ( end-ptc (process-time-clock))
+ ( end-rtc ( real-time-clock)))
+ (let ((process-secs/no-gc (- end-rt start-rt ))
+ (process-ticks (- end-ptc start-ptc))
+ (real-ticks (- end-rtc start-rtc)))
+ (cond
+ ((or deficit? neficit?)
+ (let ((t:mixin (if deficit? int:+ int:-))
+ (s:mixin (if deficit? flo:+ flo:-)))
+ (set! *pc-sample/last-sampling-duration-deficit*
+ (t:mixin *pc-sample/last-sampling-duration-deficit*
+ process-ticks))
+ (set! *pc-sample/last-sampling-duration-deficit/no-gc*
+ (s:mixin *pc-sample/last-sampling-duration-deficit/no-gc*
+ process-secs/no-gc))
+ (set! *pc-sample/last-sampling-duration-deficit/real*
+ (t:mixin *pc-sample/last-sampling-duration-deficit/real*
+ real-ticks)))))
+ (cond ((and tople? time-it?)
+ (time-display thunk
+ process-ticks
+ process-secs/no-gc
+ real-ticks))))
+ result)))))
+ (lambda ()
+ (cond (restart?
+ (pc-sample/start)))))))
+
+(define (call-without-builtin-pc-sampling thunk)
+ (call-without-pc-sampling thunk pc-sample/builtin/status/display))
+
+(define (call-without-utility-pc-sampling thunk)
+ (call-without-pc-sampling thunk pc-sample/utility/status/display))
+
+(define (call-without-primitive-pc-sampling thunk)
+ (call-without-pc-sampling thunk pc-sample/primitive/status/display))
+
+(define (call-without-code-block-pc-sampling thunk)
+ (call-without-pc-sampling thunk pc-sample/code-block/status/display))
+
+(define (call-without-interp-proc-pc-sampling thunk)
+ (call-without-pc-sampling thunk pc-sample/interp-proc/status/display))
+
+(define (call-without-prob-comp-pc-sampling thunk)
+ (call-without-pc-sampling thunk pc-sample/prob-comp/status/display))
+
+(define (call-without-UFO-pc-sampling thunk)
+ (call-without-pc-sampling thunk pc-sample/UFO/status/display))
+
+;;; Without-pc-sampling
+
+(define (without-pc-sampling proc . args)
+ (call-without-pc-sampling (lambda () (apply proc args))))
+(define (without-builtin-pc-sampling proc . args)
+ (call-without-builtin-pc-sampling (lambda () (apply proc args))))
+(define (without-utility-pc-sampling proc . args)
+ (call-without-utility-pc-sampling (lambda () (apply proc args))))
+(define (without-primitive-pc-sampling proc . args)
+ (call-without-primitive-pc-sampling (lambda () (apply proc args))))
+(define (without-code-block-pc-sampling proc . args)
+ (call-without-code-block-pc-sampling (lambda () (apply proc args))))
+(define (without-interp-proc-pc-sampling proc . args)
+ (call-without-interp-proc-pc-sampling (lambda () (apply proc args))))
+(define (without-prob-comp-pc-sampling proc . args)
+ (call-without-prob-comp-pc-sampling (lambda () (apply proc args))))
+(define (without-UFO-pc-sampling proc . args)
+ (call-without-UFO-pc-sampling (lambda () (apply proc args))))
+\f
+;;; Call-with-absolutely-no-pc-sampling
+
+(define (call-with-absolutely-no-pc-sampling thunk #!optional untimed?)
+ (let ((restart? (and (pc-sample/running?)
+ (begin (pc-sample/stop) ; stop ASAP
+ #T))))
+ (dynamic-wind
+ (lambda () 'restart-sampling-even-when-thunk-craps-out)
+ (lambda () (let ((untimed-arg (and (not (default-object? untimed?))
+ untimed?)))
+ (fluid-let ((*pc-sample/wan-sampling?* #T))
+ (call-without-pc-sampling thunk untimed-arg))))
+ (lambda () (cond (restart?
+ (pc-sample/start)))))))
+
+(define (call-with-absolutely-no-builtin-pc-sampling thunk)
+ (call-with-absolutely-no-pc-sampling thunk
+ pc-sample/builtin/status/display))
+
+(define (call-with-absolutely-no-utility-pc-sampling thunk)
+ (call-with-absolutely-no-pc-sampling thunk
+ pc-sample/utility/status/display))
+
+(define (call-with-absolutely-no-primitive-pc-sampling thunk)
+ (call-with-absolutely-no-pc-sampling thunk
+ pc-sample/primitive/status/display))
+
+(define (call-with-absolutely-no-code-block-pc-sampling thunk)
+ (call-with-absolutely-no-pc-sampling thunk
+ pc-sample/code-block/status/display))
+
+(define (call-with-absolutely-no-interp-proc-pc-sampling thunk)
+ (call-with-absolutely-no-pc-sampling thunk
+ pc-sample/interp-proc/status/display))
+
+(define (call-with-absolutely-no-prob-comp-pc-sampling thunk)
+ (call-with-absolutely-no-pc-sampling thunk
+ pc-sample/prob-comp/status/display))
+
+(define (call-with-absolutely-no-UFO-pc-sampling thunk)
+ (call-with-absolutely-no-pc-sampling thunk
+ pc-sample/UFO/status/display))
+
+;;; With-absolutely-no-pc-sampling
+
+(define (with-absolutely-no-pc-sampling proc . args)
+ (call-with-absolutely-no-pc-sampling (lambda () (apply proc args))))
+(define (with-absolutely-no-builtin-pc-sampling proc . args)
+ (call-with-absolutely-no-builtin-pc-sampling (lambda () (apply proc args))))
+(define (with-absolutely-no-utility-pc-sampling proc . args)
+ (call-with-absolutely-no-utility-pc-sampling (lambda () (apply proc args))))
+(define (with-absolutely-no-primitive-pc-sampling proc . args)
+ (call-with-absolutely-no-primitive-pc-sampling (lambda () (apply proc args))))
+(define (with-absolutely-no-code-block-pc-sampling proc . args)
+ (call-with-absolutely-no-code-block-pc-sampling (lambda () (apply proc args))))
+(define (with-absolutely-no-interp-proc-pc-sampling proc . args)
+ (call-with-absolutely-no-interp-proc-pc-sampling (lambda () (apply proc args))))
+(define (with-absolutely-no-prob-comp-pc-sampling proc . args)
+ (call-with-absolutely-no-prob-comp-pc-sampling (lambda () (apply proc args))))
+(define (with-absolutely-no-UFO-pc-sampling proc . args)
+ (call-with-absolutely-no-UFO-pc-sampling (lambda () (apply proc args))))
+\f
+;;; Install
+
+(define *pc-sample/install-verbosity?* #F)
+
+(define (install-dynamic-microcode)
+ (let ((pcs-directory (system-library-directory-pathname "pcsample")))
+ (cond (*pc-sample/install-verbosity?*
+ (newline)
+ (display "Installing dynamic microcode...")
+ (newline)))
+ (cond ((not (implemented-primitive-procedure? ; avoid ucode re-loads
+ (make-primitive-procedure '%pc-sample/install-microcode 0)))
+ (let ((filename
+ (->namestring (merge-pathnames "pcsdld.sl" pcs-directory))))
+ (newline)
+ (write-string ";Loading ")
+ (write-string filename)
+ (let* ((handle ((make-primitive-procedure 'load-object-file)
+ filename))
+ (cth ((make-primitive-procedure 'object-lookup-symbol)
+ handle "initialize_pcsample_primitives" 0)))
+ (write-string " -- done")
+ ((make-primitive-procedure 'invoke-c-thunk) cth)))))))
+
+(define (pc-sample/install-microcode-frobs)
+ (cond (*pc-sample/install-verbosity?*
+ (newline)
+ (display "Installing microcode frobs...")
+ (newline)))
+ (let ((win? (%pc-sample/install-microcode)))
+ (cond ((not win?)
+ (error "\nCould not install PC Sample GC synch hooks.\
+ \nGame over."))))
+ unspecific)
+
+(define (pc-sample/disable-microcode-frobs)
+ (cond (*pc-sample/install-verbosity?*
+ (newline)
+ (display "Disabling microcode frobs...")
+ (newline)))
+ (let ((win? (%pc-sample/disable-microcode)))
+ (cond ((not win?)
+ (error "\nCould not disable PC Sample GC synch hooks.\
+ \nGame over."))))
+ unspecific)
+
+(define (install)
+ ;; Dynamically load microcode
+ (install-dynamic-microcode)
+ (add-event-receiver! event:after-restore install-dynamic-microcode)
+ ;; Install runtime stuff...
+ (install-indices)
+ (install-accessors)
+ (install-makers)
+ (install-resetters)
+ (install-profile-hash-table)
+ ;; Install microcode structures
+ (pc-sample/install-microcode-frobs)
+ (add-event-receiver! event:after-restore pc-sample/install-microcode-frobs)
+ (add-event-receiver! event:before-exit pc-sample/disable-microcode-frobs)
+ ;; HACK: reinitialize the variable when this code is disk-restored so
+ ;; we can post way-cool bands to the Internet News servers.
+ (install-current-user-name-promise)
+ (add-event-receiver! event:after-restore install-current-user-name-promise)
+ ;; Stop sampling at inauspicious occassions...
+ (add-event-receiver! event:after-restore pc-sample/stop)
+ (add-event-receiver! event:before-exit pc-sample/stop)
+ )
+
+;;; fini
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: pcsboot.scm,v 1.1 1995/07/28 14:14:08 adams Exp $
+
+Copyright (c) 1988-1993 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; PC Sample Interrupt Bits (for consistency w/ .../runtime/boot.scm)
+;;; package: (pc-sample interrupt-handler)
+
+(declare (usual-integrations))
+
+(define-integrable interrupt-bit/IPPB-flush #x0200) ; pc-sample
+(define-integrable interrupt-bit/IPPB-extend #x0400) ; pc-sample
+(define-integrable interrupt-bit/PCBPB-flush #x0800) ; pc-sample
+(define-integrable interrupt-bit/PCBPB-extend #x1000) ; pc-sample
+(define-integrable interrupt-bit/HCBPB-flush #x2000) ; pc-sample
+(define-integrable interrupt-bit/HCBPB-extend #x4000) ; pc-sample
+
+
+;;; fini
+
--- /dev/null
+/* -*-C-*-
+
+$Id: pcscobl.c,v 1.1 1995/07/28 14:14:08 adams Exp $
+
+Copyright (c) 1990-1995 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+/* PCSCOBL.C -- PC Sample subroutines for profiling code blocks *\
+\* (a.k.a. compiled procs) within pcsample.c */
+
+/** **\
+|*** BASED VERY HEAVILY ON PCSIPROC.C ***|
+\** **/
+
+/*****************************************************************************/
+#ifdef REALLY_INCLUDE_PROFILE_CODE /* scan_defines concession */
+\f
+/*!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*\
+ * TODO:
+ *
+ * - Maybe flatten number of primitives?
+ *
+\*!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*/
+\f
+/*****************************************************************************\
+ * Code Block Profile Buffers are used for code blocks to serve the same end *
+ * that the Interp-Proc Profile Buffer serves for interpreted procedures. *
+ * See pcsiproc.[ch]. *
+\*****************************************************************************/
+
+/*===========================================================================*\
+ *
+ * Code Block Profile Buffers consist of vectors of slots and a handfull of
+ * state variables...
+ *
+ * There are two distinct Code Block Profile Buffers:
+ *
+ * PCBPB - ``Purified'' Code Block Profile Buffer: for code blocks in constant
+ * space, hence non-relocating
+ * HCBPB - ``Heathen'' Code Block Profile Buffer: for nomadic code blocks
+ *
+ * Each conceptual buffer actually corresponds to two distinguishable buffers:
+ * the first being a buffer of (Scheme) pointers to code block objects and the
+ * second being a buffer of corresponding offsets. This is done because we want
+ * to record not just the code block we are in but also the offset into it in
+ * case a code block contains multiple procedure bodies. We cannot record a
+ * CONS pair of code block/offset since the low level signal system must not
+ * allocate heap storage. So, we maintain a synch'd pair of vectors, one for
+ * what would be the CARs (blocks) and the other for the CDRs (offsets).
+ *
+ * << C'est la guerre. >>
+ *
+\*===========================================================================*/
+
+/* block and offset buffers are synch'd wrt nxt-mt, slack & slack incr */
+
+static struct profile_buffer_state purified_cobl_profile_buffer_state;
+static struct profile_buffer_state heathen_cobl_profile_buffer_state;
+
+static void
+DEFUN_VOID (init_CBPB_profile_buffer_states)
+{
+ init_profile_bi_buffer_state (&purified_cobl_profile_buffer_state,
+ "PCBPB", /* name */
+ PC_Sample_PCB_Block_Buffer, /* ID */
+ PC_Sample_PCB_Offset_Buffer, /* ID_aux */
+ 8*128, /* slack */
+ 128, /* slack_inc */
+ INT_PCBPB_Flush, /* flush_INT */
+ INT_PCBPB_Extend /* extnd_INT */
+ );
+
+ init_profile_bi_buffer_state (& heathen_cobl_profile_buffer_state,
+ "HCBPB", /* name */
+ PC_Sample_HCB_Block_Buffer, /* ID */
+ PC_Sample_HCB_Offset_Buffer, /* ID_aux */
+ 8*128, /* slack */
+ 128, /* slack_inc */
+ INT_HCBPB_Flush, /* flush_INT */
+ INT_HCBPB_Extend /* extnd_INT */
+ );
+}
+
+
+
+/* convenient shorthand for use in primitives below... */
+
+#define PCBPB_name \
+ (purified_cobl_profile_buffer_state . name)
+#define HCBPB_name \
+ ( heathen_cobl_profile_buffer_state . name)
+#define PCBPB_ID \
+ (purified_cobl_profile_buffer_state . ID)
+#define HCBPB_ID \
+ ( heathen_cobl_profile_buffer_state . ID)
+#define PCBPB_enabled \
+ (purified_cobl_profile_buffer_state . enabled_flag)
+#define HCBPB_enabled \
+ ( heathen_cobl_profile_buffer_state . enabled_flag)
+
+ /* ... continued on next page ... */
+\f
+ /* ... convenient shorthand: continued from previous page ... */
+
+
+#define PCBPB_buffer \
+ (purified_cobl_profile_buffer_state . buffer)
+#define HCBPB_buffer \
+ ( heathen_cobl_profile_buffer_state . buffer)
+#define PCBPB_buffer_aux \
+ (purified_cobl_profile_buffer_state . buffer_aux)
+#define HCBPB_buffer_aux \
+ ( heathen_cobl_profile_buffer_state . buffer_aux)
+#define PCBPB_length \
+ (purified_cobl_profile_buffer_state . length)
+#define HCBPB_length \
+ ( heathen_cobl_profile_buffer_state . length)
+#define PCBPB_next_empty_slot_index \
+ (purified_cobl_profile_buffer_state . next_empty_slot_index)
+#define HCBPB_next_empty_slot_index \
+ ( heathen_cobl_profile_buffer_state . next_empty_slot_index)
+#define PCBPB_slack \
+ (purified_cobl_profile_buffer_state . slack)
+#define HCBPB_slack \
+ ( heathen_cobl_profile_buffer_state . slack)
+#define PCBPB_slack_increment \
+ (purified_cobl_profile_buffer_state . slack_increment)
+#define HCBPB_slack_increment \
+ ( heathen_cobl_profile_buffer_state . slack_increment)
+#define PCBPB_flush_INT \
+ (purified_cobl_profile_buffer_state . flush_INT)
+#define HCBPB_flush_INT \
+ ( heathen_cobl_profile_buffer_state . flush_INT)
+#define PCBPB_extend_INT \
+ (purified_cobl_profile_buffer_state . extend_INT)
+#define HCBPB_extend_INT \
+ ( heathen_cobl_profile_buffer_state . extend_INT)
+#define PCBPB_flush_noisy \
+ (purified_cobl_profile_buffer_state . flush_noisy_flag)
+#define HCBPB_flush_noisy \
+ ( heathen_cobl_profile_buffer_state . flush_noisy_flag)
+#define PCBPB_extend_noisy \
+ (purified_cobl_profile_buffer_state . extend_noisy_flag)
+#define HCBPB_extend_noisy \
+ ( heathen_cobl_profile_buffer_state . extend_noisy_flag)
+#define PCBPB_overflow_noisy \
+ (purified_cobl_profile_buffer_state . overflow_noisy_flag)
+#define HCBPB_overflow_noisy \
+ ( heathen_cobl_profile_buffer_state . overflow_noisy_flag)
+#define PCBPB_flush_immediate \
+ (purified_cobl_profile_buffer_state . flush_immed_flag)
+#define HCBPB_flush_immediate \
+ ( heathen_cobl_profile_buffer_state . flush_immed_flag)
+#define PCBPB_debugging \
+ (purified_cobl_profile_buffer_state . debug_flag)
+#define HCBPB_debugging \
+ (purified_cobl_profile_buffer_state . debug_flag)
+#define PCBPB_monitoring \
+ (purified_cobl_profile_buffer_state . monitor_flag)
+#define HCBPB_monitoring \
+ (purified_cobl_profile_buffer_state . monitor_flag)
+#define PCBPB_flush_count \
+ (purified_cobl_profile_buffer_state . flush_count)
+#define HCBPB_flush_count \
+ (purified_cobl_profile_buffer_state . flush_count)
+#define PCBPB_extend_count \
+ (purified_cobl_profile_buffer_state . extend_count)
+#define HCBPB_extend_count \
+ (purified_cobl_profile_buffer_state . extend_count)
+#define PCBPB_overflow_count \
+ (purified_cobl_profile_buffer_state . overflow_count)
+#define HCBPB_overflow_count \
+ (purified_cobl_profile_buffer_state . overflow_count)
+#define PCBPB_extra_info \
+ (purified_cobl_profile_buffer_state . extra_buffer_state_info)
+#define HCBPB_extra_info \
+ ( heathen_cobl_profile_buffer_state . extra_buffer_state_info)
+\f
+/*---------------------------------------------------------------------------*/
+#define PCBPB_disable() do \
+{ \
+ Set_Fixed_Obj_Slot (PC_Sample_PCB_Block_Buffer, SHARP_F); \
+ Set_Fixed_Obj_Slot (PC_Sample_PCB_Offset_Buffer, SHARP_F); \
+ PCBPB_buffer = SHARP_F ; \
+ PCBPB_buffer_aux = SHARP_F ; \
+ PCBPB_enabled = false ; \
+ PCBPB_next_empty_slot_index = 0 ; \
+ PCBPB_length = 0 ; /* Paranoia */ \
+} while (FALSE)
+/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
+DEFINE_PRIMITIVE ("PURIFIED-CODE-BLOCK-PROFILE-BUFFERS/DISABLE",
+ Prim_PCBPB_disable, 0, 0,
+ "()\n\
+ Disables the purified code block profile buffers hence disabling purified\n\
+ code block profiling (unless and until new buffers are installed).\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PCBPB_disable ();
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+/*...........................................................................*/
+#define HCBPB_disable() do \
+{ \
+ Set_Fixed_Obj_Slot (PC_Sample_HCB_Block_Buffer, SHARP_F); \
+ Set_Fixed_Obj_Slot (PC_Sample_HCB_Offset_Buffer, SHARP_F); \
+ HCBPB_buffer = SHARP_F ; \
+ HCBPB_buffer_aux = SHARP_F ; \
+ HCBPB_enabled = false ; \
+ HCBPB_next_empty_slot_index = 0 ; \
+ HCBPB_length = 0 ; /* Paranoia */ \
+} while (FALSE)
+/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
+DEFINE_PRIMITIVE ( "HEATHEN-CODE-BLOCK-PROFILE-BUFFERS/DISABLE",
+ Prim_HCBPB_disable, 0, 0,
+ "()\n\
+ Disables the heathen code block profile buffers hence disabling heathen\n\
+ code block profiling (unless and until new buffers are installed).\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ HCBPB_disable ();
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+/*****************************************************************************/
+static void
+DEFUN_VOID (CBPBs_disable)
+{
+ PCBPB_disable ();
+ HCBPB_disable ();
+}
+\f
+/*---------------------------------------------------------------------------*/
+#define CHECK_VECTORS_SAME_LENGTH_P(v1, v2) do \
+{ \
+ if ((VECTOR_LENGTH (v1)) != (VECTOR_LENGTH (v2))) \
+ { \
+ outf_error ("Vector arguments must be of the same length (%d != %d).\n", \
+ (VECTOR_LENGTH (v1)), (VECTOR_LENGTH (v2))) ; \
+ outf_flush_error () ; \
+ error_external_return () ; \
+ } \
+} while (FALSE)
+/*---------------------------------------------------------------------------*/
+/*---------------------------------------------------------------------------*/
+#define PCBPB_install(buffer_arg_1, buffer_arg_2) do \
+{ \
+ Set_Fixed_Obj_Slot (PC_Sample_PCB_Block_Buffer, buffer_arg_1) ; \
+ Set_Fixed_Obj_Slot (PC_Sample_PCB_Offset_Buffer, buffer_arg_2) ; \
+ PCBPB_buffer = buffer_arg_1 ; \
+ PCBPB_buffer_aux = buffer_arg_2 ; \
+ PCBPB_enabled = true ; \
+ PCBPB_length = (VECTOR_LENGTH (buffer_arg_1)) ; \
+} while (FALSE)
+/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
+DEFINE_PRIMITIVE ("PURIFIED-CODE-BLOCK-PROFILE-BUFFERS/INSTALL",
+ Prim_PCBPB_install, 2, 2,
+ "(block-vector offset-vector)\n\
+ Installs BLOCK-VECTOR and OFFSET-VECTOR as the purified code block profile\n\
+ buffers.\
+ ")
+{
+ SCHEME_OBJECT buffer_arg_1 ;
+ SCHEME_OBJECT buffer_arg_2 ;
+
+ PRIMITIVE_HEADER(2);
+ CHECK_ARG(1, VECTOR_P);
+ CHECK_ARG(2, VECTOR_P);
+ buffer_arg_1 = (ARG_REF (1)) ;
+ buffer_arg_2 = (ARG_REF (2)) ;
+ CHECK_VECTORS_SAME_LENGTH_P(buffer_arg_1, buffer_arg_2) ;
+ PCBPB_install(buffer_arg_1, buffer_arg_2) ;
+ /* NB: Do NOT reset next_empty_slot_index since may be extending */
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+/*...........................................................................*/
+#define HCBPB_install(buffer_arg_1, buffer_arg_2) do \
+{ \
+ Set_Fixed_Obj_Slot (PC_Sample_HCB_Block_Buffer, buffer_arg_1) ; \
+ Set_Fixed_Obj_Slot (PC_Sample_HCB_Offset_Buffer, buffer_arg_2) ; \
+ HCBPB_buffer = buffer_arg_1 ; \
+ HCBPB_buffer_aux = buffer_arg_2 ; \
+ HCBPB_enabled = true ; \
+ HCBPB_length = (VECTOR_LENGTH (buffer_arg_1)) ; \
+} while (FALSE)
+/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
+DEFINE_PRIMITIVE ( "HEATHEN-CODE-BLOCK-PROFILE-BUFFERS/INSTALL",
+ Prim_HCBPB_install, 2, 2,
+ "(block-vector offset-vector)\n\
+ Installs BLOCK-VECTOR and OFFSET-VECTOR as the heathen code block profile\n\
+ buffers.\
+ ")
+{
+ SCHEME_OBJECT buffer_arg_1 ;
+ SCHEME_OBJECT buffer_arg_2 ;
+
+ PRIMITIVE_HEADER(2);
+ CHECK_ARG(1, VECTOR_P);
+ CHECK_ARG(2, VECTOR_P);
+ buffer_arg_1 = (ARG_REF (1)) ;
+ buffer_arg_2 = (ARG_REF (2)) ;
+ CHECK_VECTORS_SAME_LENGTH_P(buffer_arg_1, buffer_arg_2) ;
+ HCBPB_install(buffer_arg_1, buffer_arg_2);
+ /* NB: Do NOT reset next_empty_slot_index since may be extending */
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+\f
+/*---------------------------------------------------------------------------*/
+/*---------------------------------------------------------------------------*/
+static void
+DEFUN_VOID(resynch_CBPBs_post_gc_hook)
+{
+ if PCBPB_enabled
+ PCBPB_install ((Get_Fixed_Obj_Slot (PC_Sample_PCB_Block_Buffer)),
+ (Get_Fixed_Obj_Slot (PC_Sample_PCB_Offset_Buffer))) ;
+ if HCBPB_enabled
+ HCBPB_install ((Get_Fixed_Obj_Slot (PC_Sample_HCB_Block_Buffer)),
+ (Get_Fixed_Obj_Slot (PC_Sample_HCB_Offset_Buffer))) ;
+}
+/*---------------------------------------------------------------------------*/
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/SLACK", Prim_PCBPB_slack,
+ 0, 0,
+ "()\n\
+ Returns the `slack' by which the near-fullness of the profile buffer for\n\
+ purified code blocks is determined and by which increment the buffer is\n\
+ extended when full.\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PRIMITIVE_RETURN (ulong_to_integer(PCBPB_slack));
+}
+/*...........................................................................*/
+DEFINE_PRIMITIVE ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/SLACK", Prim_HCBPB_slack,
+ 0, 0,
+ "()\n\
+ Returns the `slack' by which the near-fullness of the profile buffer for\n\
+ heathen (i.e., non-purified) code blocks is determined and by which\n\
+ increment the buffer is extended when full.\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PRIMITIVE_RETURN (ulong_to_integer(HCBPB_slack));
+}
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/SET-SLACK",
+ Prim_PCBPB_set_slack, 1, 1,
+ "(positive-fixnum)\n\
+ Sets the `slack' by which the near-fullness of the PCBPB is determined and\n\
+ by which increment the buffer is extended when full.\n\
+ \n\
+ Note that the slack must be a positive fixnum.\
+ ")
+{
+ PRIMITIVE_HEADER(1);
+ CHECK_ARG (1, FIXNUM_POSITIVE_P);
+ PCBPB_slack = (integer_to_ulong (ARG_REF (1)));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+/*...........................................................................*/
+DEFINE_PRIMITIVE ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/SET-SLACK",
+ Prim_HCBPB_set_slack, 1, 1,
+ "(positive-fixnum)\n\
+ Sets the `slack' by which the near-fullness of the HCBPB is determined and\n\
+ by which increment the buffer is extended when full.\n\
+ \n\
+ Note that the slack must be a positive fixnum.\
+ ")
+{
+ PRIMITIVE_HEADER(1);
+ CHECK_ARG (1, FIXNUM_POSITIVE_P);
+ HCBPB_slack = (integer_to_ulong (ARG_REF (1)));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+\f
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/SLACK-INCREMENT",
+ Prim_PCBPB_slack_increment, 0, 0,
+ "()\n\
+ Returns the amount by which the PCBPB slack is incremented when a buffer\n\
+ overflow occurs. In this sense it cuts the slack more slack.\n\
+ \n\
+ Note that the slack increment will always be a fixnum, but it can be negative\n\
+ (in which case it functions as a slack decrement).\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PRIMITIVE_RETURN (long_to_integer(PCBPB_slack_increment));
+}
+/*...........................................................................*/
+DEFINE_PRIMITIVE ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/SLACK-INCREMENT",
+ Prim_HCBPB_slack_increment, 0, 0,
+ "()\n\
+ Returns the amount by which the HCBPB slack is incremented when a buffer\n\
+ overflow occurs. In this sense it cuts the slack more slack.\n\
+ \n\
+ Note that the slack increment will always be a fixnum, but it can be negative\n\
+ (in which case it functions as a slack decrement).\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PRIMITIVE_RETURN (long_to_integer(HCBPB_slack_increment));
+}
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/SET-SLACK-INCREMENT",
+ Prim_PCBPB_set_slack_increment, 1, 1,
+ "(fixnum)\n\
+ Sets the amount by which the PCBPB slack is incremented when a buffer\n\
+ overflow occurs.\n\
+ \n\
+ Note that the slack increment must be a fixnum, but it can be negative\n\
+ (in which case it functions as a slack decrement).\
+ ")
+{
+ PRIMITIVE_HEADER(1);
+ CHECK_ARG (1, INTEGER_P);
+ PCBPB_slack_increment = (integer_to_long (ARG_REF (1)));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+/*...........................................................................*/
+DEFINE_PRIMITIVE ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/SET-SLACK-INCREMENT",
+ Prim_HCBPB_set_slack_increment, 1, 1,
+ "(fixnum)\n\
+ Sets the amount by which the HCBPB slack is incremented when a buffer\n\
+ overflow occurs.\n\
+ \n\
+ Note that the slack increment must be a fixnum, but it can be negative\n\
+ (in which case it functions as a slack decrement).\
+ ")
+{
+ PRIMITIVE_HEADER(1);
+ CHECK_ARG (1, INTEGER_P);
+ HCBPB_slack_increment = (integer_to_long (ARG_REF (1)));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+\f
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/EXTEND-NOISY?",
+ Prim_PCBPB_extend_noisy_p, 0, 0,
+ "()\n\
+ Specifies whether notification of PCBPB buffer extensions is enabled.\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (PCBPB_extend_noisy)) ;
+}
+/*...........................................................................*/
+DEFINE_PRIMITIVE ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/EXTEND-NOISY?",
+ Prim_HCBPB_extend_noisy_p, 0, 0,
+ "()\n\
+ Specifies whether notification of HCBPB buffer extensions is enabled.\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (HCBPB_extend_noisy)) ;
+}
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/FLUSH-NOISY?",
+ Prim_PCBPB_flush_noisy_p, 0, 0,
+ "()\n\
+ Specifies whether notification of PCBPB buffer extensions is enabled.\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (PCBPB_flush_noisy)) ;
+}
+/*...........................................................................*/
+DEFINE_PRIMITIVE ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/FLUSH-NOISY?",
+ Prim_HCBPB_flush_noisy_p, 0, 0,
+ "()\n\
+ Specifies whether notification of HCBPB buffer extensions is enabled.\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (HCBPB_flush_noisy)) ;
+}
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/OVERFLOW-NOISY?",
+ Prim_PCBPB_overflow_noisy_p, 0, 0,
+ "()\n\
+ Specifies whether notification of PCBPB buffer extensions is enabled.\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (PCBPB_overflow_noisy)) ;
+}
+/*...........................................................................*/
+DEFINE_PRIMITIVE ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/OVERFLOW-NOISY?",
+ Prim_HCBPB_overflow_noisy_p, 0, 0,
+ "()\n\
+ Specifies whether notification of HCBPB buffer extensions is enabled.\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (HCBPB_overflow_noisy)) ;
+}
+\f
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/EXTEND-NOISY?/TOGGLE!",
+ Prim_PCBPB_extend_noisy_p_toggle_bang, 0, 0,
+ "()\n\
+ Toggles the Boolean sense of whether to notify of PCBPB buffer extensions.\n\
+ \n\
+ It returns the newly installed sense of the flag.\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PCBPB_extend_noisy = (! PCBPB_extend_noisy) ;
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (PCBPB_flush_noisy)) ;
+}
+/*...........................................................................*/
+DEFINE_PRIMITIVE ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/EXTEND-NOISY?/TOGGLE!",
+ Prim_HCBPB_extend_noisy_p_toggle_bang, 0, 0,
+ "()\n\
+ Toggles the Boolean sense of whether to notify of HCBPB buffer extensions.\n\
+ \n\
+ It returns the newly installed sense of the flag.\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ HCBPB_extend_noisy = (! HCBPB_extend_noisy) ;
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (HCBPB_flush_noisy)) ;
+}
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/FLUSH-NOISY?/TOGGLE!",
+ Prim_PCBPB_flush_noisy_p_toggle_bang, 0, 0,
+ "()\n\
+ Toggles the Boolean sense of whether to notify of PCBPB buffer flushes.\n\
+ \n\
+ It returns the newly installed sense of the flag.\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PCBPB_flush_noisy = (! PCBPB_flush_noisy) ;
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (PCBPB_flush_noisy)) ;
+}
+/*...........................................................................*/
+DEFINE_PRIMITIVE ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/FLUSH-NOISY?/TOGGLE!",
+ Prim_HCBPB_flush_noisy_p_toggle_bang, 0, 0,
+ "()\n\
+ Toggles the Boolean sense of whether to notify of HCBPB buffer flushes.\n\
+ \n\
+ It returns the newly installed sense of the flag.\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ HCBPB_flush_noisy = (! HCBPB_flush_noisy) ;
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (HCBPB_flush_noisy)) ;
+}
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/OVERFLOW-NOISY?/TOGGLE!",
+ Prim_PCBPB_overflow_noisy_p_toggle_bang, 0, 0,
+ "()\n\
+ Toggles the Boolean sense of whether to notify of PCBPB buffer overflowes.\n\
+ \n\
+ It returns the newly installed sense of the flag.\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PCBPB_overflow_noisy = (! PCBPB_overflow_noisy) ;
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (PCBPB_overflow_noisy)) ;
+}
+/*...........................................................................*/
+DEFINE_PRIMITIVE ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/OVERFLOW-NOISY?/TOGGLE!",
+ Prim_HCBPB_overflow_noisy_p_toggle_bang, 0, 0,
+ "()\n\
+ Toggles the Boolean sense of whether to notify of HCBPB buffer overflowes.\n\
+ \n\
+ It returns the newly installed sense of the flag.\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ HCBPB_overflow_noisy = (! HCBPB_overflow_noisy) ;
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (HCBPB_overflow_noisy)) ;
+}
+\f
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/EMPTY?",
+ Prim_PCBPB_empty_p, 0, 0,
+ "()\n\
+ Returns a boolean indicating whether or not the profile buffer for\n\
+ purified code blocks is empty.\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PRIMITIVE_RETURN(BOOLEAN_TO_OBJECT (PCBPB_next_empty_slot_index == 0));
+}
+/*...........................................................................*/
+DEFINE_PRIMITIVE ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/EMPTY?",
+ Prim_HCBPB_empty_p, 0, 0,
+ "()\n\
+ Returns a boolean indicating whether or not the profile buffer for\n\
+ heathen (i.e., unpurified) code blocks is empty.\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PRIMITIVE_RETURN(BOOLEAN_TO_OBJECT (HCBPB_next_empty_slot_index == 0));
+}
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/NEXT-EMPTY-SLOT-INDEX",
+ Prim_PCBPB_next_empty_slot_index, 0, 0,
+ "()\n\
+ Returns the index of the next `free' slot of the profile buffer for\n\
+ purified code blocks.\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PRIMITIVE_RETURN(ulong_to_integer(PCBPB_next_empty_slot_index));
+}
+/*...........................................................................*/
+DEFINE_PRIMITIVE ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/NEXT-EMPTY-SLOT-INDEX",
+ Prim_HCBPB_next_empty_slot_index, 0, 0,
+ "()\n\
+ Returns the index of the next `free' slot of the profile buffer for\n\
+ heathen (i.e., unpurified) code blocks.\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PRIMITIVE_RETURN(ulong_to_integer(HCBPB_next_empty_slot_index));
+}
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("%PURIFIED-CODE-BLOCK-PROFILE-BUFFER/NEXT-EMPTY-SLOT-INDEX/RESET",
+ Prim_PCBPB_next_empty_slot_index_reset, 0, 0,
+ "()\n\
+ Resets the index of the next `free' slot of the profile buffer for\n\
+ purified code blocks.\
+ \n\
+ Only officially designated wizards should even think of using this\n\
+ super secret primitive. FNORD!\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PCBPB_next_empty_slot_index = ((unsigned long) 0);
+ PRIMITIVE_RETURN(UNSPECIFIC);
+}
+/*...........................................................................*/
+DEFINE_PRIMITIVE ("%HEATHEN-CODE-BLOCK-PROFILE-BUFFER/NEXT-EMPTY-SLOT-INDEX/RESET",
+ Prim_HCBPB_next_empty_slot_index_reset, 0, 0,
+ "()\n\
+ Resets the index of the next `free' slot of the profile buffer for\n\
+ heathen (i.e., unpurified) code blocks.\
+ \n\
+ Only officially designated wizards should even think of using this\n\
+ super secret primitive. FNORD!\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ HCBPB_next_empty_slot_index = ((unsigned long) 0);
+ PRIMITIVE_RETURN(UNSPECIFIC);
+}
+\f
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("%PC-SAMPLE/PCBPB-FLUSH-IMMEDIATE?",
+ Prim_pc_sample_PCBPB_flush_immediate_p, 0, 0,
+ "()\n\
+ Specifies whether the Purified Code Block Profile Buffer is flushed upon\n\
+ each entry.\n\
+ \n\
+ Only officially designated wizards should even think of using this\n\
+ super secret primitive. FNORD!\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (PCBPB_flush_immediate)) ;
+}
+/*...........................................................................*/
+DEFINE_PRIMITIVE ("%PC-SAMPLE/HCBPB-FLUSH-IMMEDIATE?",
+ Prim_pc_sample_HCBPB_flush_immediate_p, 0, 0,
+ "()\n\
+ Specifies whether the Heathen Code Block Profile Buffer is flushed upon\n\
+ each entry.\n\
+ \n\
+ Only officially designated wizards should even think of using this\n\
+ super secret primitive. FNORD!\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (HCBPB_flush_immediate)) ;
+}
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("%PC-SAMPLE/PCBPB-FLUSH-IMMEDIATE?/TOGGLE!",
+ Prim_pc_sample_PCBPB_flush_immediate_p_toggle_bang, 0, 0,
+ "()\n\
+ Toggles the Boolean sense of whether the Purified Code Block Profile Buffer\n\
+ is flushed upon each entry.\n\
+ \n\
+ It returns the newly installed sense of the flag.\n\
+ \n\
+ This is for mondo bizarro sampler debugging purposes only.\n\
+ \n\
+ Only officially designated moby wizards should even think of thinking of\n\
+ using this most ultra super duper secret primitive. FNORD!\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ IPPB_flush_immediate = (! (PCBPB_flush_immediate)) ;
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (PCBPB_flush_immediate)) ;
+}
+/*...........................................................................*/
+DEFINE_PRIMITIVE ("%PC-SAMPLE/HCBPB-FLUSH-IMMEDIATE?/TOGGLE!",
+ Prim_pc_sample_HCBPB_flush_immediate_p_toggle_bang, 0, 0,
+ "()\n\
+ Toggles the Boolean sense of whether the Heathen Code Block Profile Buffer\n\
+ is flushed upon each entry.\n\
+ \n\
+ It returns the newly installed sense of the flag.\n\
+ \n\
+ This is for mondo bizarro sampler debugging purposes only.\n\
+ \n\
+ Only officially designated moby wizards should even think of thinking of\n\
+ using this most ultra super duper secret primitive. FNORD!\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ IPPB_flush_immediate = (! (HCBPB_flush_immediate)) ;
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (HCBPB_flush_immediate)) ;
+}
+\f
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("%PC-SAMPLE/PCBPB-DEBUGGING?",
+ Prim_pc_sample_PCBPB_debugging_p, 0, 0,
+ "()\n\
+ Specifies whether the Purified Code Block Profile Buffer is in debugging mode.\n\
+ \n\
+ Only officially designated wizards should even think of using this\n\
+ super secret primitive. FNORD!\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (PCBPB_debugging)) ;
+}
+/*...........................................................................*/
+DEFINE_PRIMITIVE ("%PC-SAMPLE/HCBPB-DEBUGGING?",
+ Prim_pc_sample_HCBPB_debugging_p, 0, 0,
+ "()\n\
+ Specifies whether the Heathen Code Block Profile Buffer is in debugging mode.\n\
+ \n\
+ Only officially designated wizards should even think of using this\n\
+ super secret primitive. FNORD!\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (HCBPB_debugging)) ;
+}
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("%PC-SAMPLE/PCBPB-DEBUGGING?/TOGGLE!",
+ Prim_pc_sample_PCBPB_debugging_p_toggle_bang, 0, 0,
+ "()\n\
+ Toggles the Boolean sense of whether the Purified Code Block Profile Buffer\n\
+ is in debugging mode.\n\
+ \n\
+ It returns the newly installed sense of the flag.\n\
+ \n\
+ This is for mondo bizarro sampler debugging purposes only.\n\
+ \n\
+ Only officially designated moby wizards should even think of thinking of\n\
+ using this most ultra super duper secret primitive. FNORD!\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PCBPB_debugging = (! (PCBPB_debugging)) ;
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (PCBPB_debugging)) ;
+}
+/*...........................................................................*/
+DEFINE_PRIMITIVE ("%PC-SAMPLE/HCBPB-DEBUGGING?/TOGGLE!",
+ Prim_pc_sample_HCBPB_debugging_p_toggle_bang, 0, 0,
+ "()\n\
+ Toggles the Boolean sense of whether the Heathen Code Block Profile Buffer\n\
+ is in debugging mode.\n\
+ \n\
+ It returns the newly installed sense of the flag.\n\
+ \n\
+ This is for mondo bizarro sampler debugging purposes only.\n\
+ \n\
+ Only officially designated moby wizards should even think of thinking of\n\
+ using this most ultra super duper secret primitive. FNORD!\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ HCBPB_debugging = (! (HCBPB_debugging)) ;
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (HCBPB_debugging)) ;
+}
+\f
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("%PC-SAMPLE/PCBPB-MONITORING?",
+ Prim_pc_sample_PCBPB_monitoring_p, 0, 0,
+ "()\n\
+ Specifies whether the PCBPB is in monitoring mode.\n\
+ \n\
+ This, for instance, is how a count of buffer overflows is accumulated.\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (PCBPB_monitoring)) ;
+}
+/*...........................................................................*/
+DEFINE_PRIMITIVE ("%PC-SAMPLE/HCBPB-MONITORING?",
+ Prim_pc_sample_HCBPB_monitoring_p, 0, 0,
+ "()\n\
+ Specifies whether the HCBPB is in monitoring mode.\n\
+ \n\
+ This, for instance, is how a count of buffer overflows is accumulated.\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (HCBPB_monitoring)) ;
+}
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("%PC-SAMPLE/PCBPB-MONITORING?/TOGGLE!",
+ Prim_pc_sample_PCBPB_monitoring_p_toggle_bang, 0, 0,
+ "()\n\
+ Toggles the Boolean sense of whether the Purified Code Block Profile Buffer\n\
+ is in monitoring mode.\n\
+ \n\
+ It returns the newly installed sense of the flag.\n\
+ \n\
+ This is for mondo bizarro sampler monitoring purposes only.\n\
+ For instance, toggling this monitor flag to true triggers accumulating\n\
+ a count of buffer overflows.\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PCBPB_monitoring = (! (PCBPB_monitoring)) ;
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (PCBPB_monitoring)) ;
+}
+/*...........................................................................*/
+DEFINE_PRIMITIVE ("%PC-SAMPLE/HCBPB-MONITORING?/TOGGLE!",
+ Prim_pc_sample_HCBPB_monitoring_p_toggle_bang, 0, 0,
+ "()\n\
+ Toggles the Boolean sense of whether the Heathen Code Block Profile Buffer\n\
+ is in monitoring mode.\n\
+ \n\
+ It returns the newly installed sense of the flag.\n\
+ \n\
+ This is for mondo bizarro sampler monitoring purposes only.\n\
+ For instance, toggling this monitor flag to true triggers accumulating\n\
+ a count of buffer overflows.\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ HCBPB_monitoring = (! (HCBPB_monitoring)) ;
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (HCBPB_monitoring)) ;
+}
+\f
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("%PC-SAMPLE/PCBPB-FLUSH-COUNT",
+ Prim_pc_sample_PCBPB_flush_count, 0, 0,
+ "()\n\
+ Returns the number of PCBPB flush requests that have been issued since the\n\
+ last PC-SAMPLE/PCBPB-FLUSH-COUNT/RESET was issued (or since booting if no\n\
+ resets issued).\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PRIMITIVE_RETURN(ulong_to_integer (PCBPB_flush_count));
+}
+/*...........................................................................*/
+DEFINE_PRIMITIVE ("%PC-SAMPLE/HCBPB-FLUSH-COUNT",
+ Prim_pc_sample_HCBPB_flush_count, 0, 0,
+ "()\n\
+ Returns the number of HCBPB flush requests that have been issued since the\n\
+ last PC-SAMPLE/HCBPB-FLUSH-COUNT/RESET was issued (or since booting if no\n\
+ resets issued).\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PRIMITIVE_RETURN(ulong_to_integer (HCBPB_flush_count));
+}
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("%PC-SAMPLE/PCBPB-FLUSH-COUNT/RESET",
+ Prim_pc_sample_PCBPB_flush_count_reset, 0, 0,
+ "()\n\
+ Resets the PCBPB flush count (obviously... sheesh!).\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PCBPB_flush_count = ((unsigned long) 0);
+ PRIMITIVE_RETURN(UNSPECIFIC);
+}
+/*...........................................................................*/
+DEFINE_PRIMITIVE ("%PC-SAMPLE/HCBPB-FLUSH-COUNT/RESET",
+ Prim_pc_sample_HCBPB_flush_count_reset, 0, 0,
+ "()\n\
+ Resets the HCBPB flush count (obviously... sheesh!).\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ HCBPB_flush_count = ((unsigned long) 0);
+ PRIMITIVE_RETURN(UNSPECIFIC);
+}
+\f
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("%PC-SAMPLE/PCBPB-EXTEND-COUNT",
+ Prim_pc_sample_PCBPB_extend_count, 0, 0,
+ "()\n\
+ Returns the number of PCBPB extend requests that have been issued since the\n\
+ last PC-SAMPLE/PCBPB-EXTEND-COUNT/RESET was issued (or since booting if no\n\
+ resets issued).\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PRIMITIVE_RETURN(ulong_to_integer (PCBPB_extend_count));
+}
+/*...........................................................................*/
+DEFINE_PRIMITIVE ("%PC-SAMPLE/HCBPB-EXTEND-COUNT",
+ Prim_pc_sample_HCBPB_extend_count, 0, 0,
+ "()\n\
+ Returns the number of HCBPB extend requests that have been issued since the\n\
+ last PC-SAMPLE/HCBPB-EXTEND-COUNT/RESET was issued (or since booting if no\n\
+ resets issued).\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PRIMITIVE_RETURN(ulong_to_integer (HCBPB_extend_count));
+}
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("%PC-SAMPLE/PCBPB-EXTEND-COUNT/RESET",
+ Prim_pc_sample_PCBPB_extend_count_reset, 0, 0,
+ "()\n\
+ Resets the PCBPB extend count (obviously... sheesh!).\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PCBPB_extend_count = ((unsigned long) 0);
+ PRIMITIVE_RETURN(UNSPECIFIC);
+}
+/*...........................................................................*/
+DEFINE_PRIMITIVE ("%PC-SAMPLE/HCBPB-EXTEND-COUNT/RESET",
+ Prim_pc_sample_HCBPB_extend_count_reset, 0, 0,
+ "()\n\
+ Resets the HCBPB extend count (obviously... sheesh!).\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ HCBPB_extend_count = ((unsigned long) 0);
+ PRIMITIVE_RETURN(UNSPECIFIC);
+}
+\f
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("%PC-SAMPLE/PCBPB-OVERFLOW-COUNT",
+ Prim_pc_sample_PCBPB_overflow_count, 0, 0,
+ "()\n\
+ Returns the number of PCBPB overflows that have been issued since the last\n\
+ PC-SAMPLE/PCBPB-OVERFLOW-COUNT/RESET was issued (or since booting if no\n\
+ resets issued).\n\
+ \n\
+ Each overflow indicates a sample that was punted into the bit bucket.\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PRIMITIVE_RETURN(ulong_to_integer (PCBPB_overflow_count));
+}
+/*...........................................................................*/
+DEFINE_PRIMITIVE ("%PC-SAMPLE/HCBPB-OVERFLOW-COUNT",
+ Prim_pc_sample_HCBPB_overflow_count, 0, 0,
+ "()\n\
+ Returns the number of HCBPB overflows that have been issued since the last\n\
+ PC-SAMPLE/HCBPB-OVERFLOW-COUNT/RESET was issued (or since booting if no\n\
+ resets issued).\n\
+ \n\
+ Each overflow indicates a sample that was punted into the bit bucket.\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PRIMITIVE_RETURN(ulong_to_integer (HCBPB_overflow_count));
+}
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("%PC-SAMPLE/PCBPB-OVERFLOW-COUNT/RESET",
+ Prim_pc_sample_PCBPB_overflow_count_reset, 0, 0,
+ "()\n\
+ Resets the PCBPB overflow count (obviously... sheesh!).\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PCBPB_overflow_count = ((unsigned long) 0);
+ PRIMITIVE_RETURN(UNSPECIFIC);
+}
+/*...........................................................................*/
+DEFINE_PRIMITIVE ("%PC-SAMPLE/HCBPB-OVERFLOW-COUNT/RESET",
+ Prim_pc_sample_HCBPB_overflow_count_reset, 0, 0,
+ "()\n\
+ Resets the HCBPB overflow count (obviously... sheesh!).\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ HCBPB_overflow_count = ((unsigned long) 0);
+ PRIMITIVE_RETURN(UNSPECIFIC);
+}
+\f
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("%PC-SAMPLE/PCBPB-EXTRA-INFO",
+ Prim_pc_sample_PCBPB_extra_info, 0, 0,
+ "()\n\
+ Returns the extra info entry associated with the Purified Code Block\n\
+ Profile Buffer.\n\
+ \n\
+ Only officially designated wizards should even think of using this\n\
+ super secret primitive. FNORD!\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PRIMITIVE_RETURN (PCBPB_extra_info) ;
+}
+/*...........................................................................*/
+DEFINE_PRIMITIVE ("%PC-SAMPLE/HCBPB-EXTRA-INFO",
+ Prim_pc_sample_HCBPB_extra_info, 0, 0,
+ "()\n\
+ Returns the extra info entry associated with the Heathen Code Block\n\
+ Profile Buffer.\n\
+ \n\
+ Only officially designated wizards should even think of using this\n\
+ super secret primitive. FNORD!\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PRIMITIVE_RETURN (HCBPB_extra_info) ;
+}
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("%PC-SAMPLE/SET-PCBPB-EXTRA-INFO!",
+ Prim_pc_sample_set_PCBPB_extra_info, 1, 1,
+ "(object)\n\
+ Stores OBJECT in the extra info entry of the Purified Code Block\n\
+ Profile Buffer.\n\
+ \n\
+ This is for mondo bizarro sampler frobnication purposes only.\n\
+ \n\
+ Only officially designated moby wizards should even think of thinking of\n\
+ using this most ultra super duper secret primitive. FNORD!\
+ ")
+{
+ PRIMITIVE_HEADER(1);
+ PCBPB_extra_info = ARG_REF(1);
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+/*...........................................................................*/
+DEFINE_PRIMITIVE ("%PC-SAMPLE/SET-HCBPB-EXTRA-INFO!",
+ Prim_pc_sample_set_HCBPB_extra_info, 1, 1,
+ "(object)\n\
+ Stores OBJECT in the extra info entry of the Heathen Code Block\n\
+ Profile Buffer.\n\
+ \n\
+ This is for mondo bizarro sampler frobnication purposes only.\n\
+ \n\
+ Only officially designated moby wizards should even think of thinking of\n\
+ using this most ultra super duper secret primitive. FNORD!\
+ ")
+{
+ PRIMITIVE_HEADER(1);
+ HCBPB_extra_info = ARG_REF(1);
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+/*---------------------------------------------------------------------------*/
+\f
+/*****************************************************************************/
+#define pc_sample_record_cobl(trinfo, buffer_state) do \
+{ \
+ /* pc_info_1 = code block \
+ * pc_info_2 = offset into block \
+ */ \
+ \
+ SCHEME_OBJECT block = (trinfo -> pc_info_1) ; \
+ SCHEME_OBJECT offset = (trinfo -> pc_info_2) ; \
+ \
+ /* Hurumph... since the lambda may never have been hashed (and trap \
+ * handlers are forbidden to do the CONSing necessary to generate new hash \
+ * numbers), and since there is no microcode/scheme interface for hashing \
+ * microcode objects (i.e., C data) anyway, we just pass the buck up to the \
+ * interrupt handler mechanism: interrupt handlers are called at delicately \
+ * perspicatious moments so they are permitted to CONS. This buck is passed \
+ * by buffering lambdas until we have enough of them that it is worth issu- \
+ * ing a request to spill the buffer into the lambda hashtable. For more \
+ * details, see pcsiproc.scm in the runtime directory. \
+ */ \
+ \
+ pc_sample_record_bi_buffer_entry (block, offset, buffer_state) ; \
+ \
+} while (FALSE)
+
+/*---------------------------------------------------------------------------*/
+static void
+DEFUN (pc_sample_record_purified_cobl, (trinfo), struct trap_recovery_info * trinfo)
+{
+ pc_sample_record_cobl (trinfo, &purified_cobl_profile_buffer_state) ;
+
+#if ( defined(PCS_LOG) /* Sample console logging */ \
+ || defined(PCS_LOG_COBL) \
+ || defined(PCS_LOG_PURE_COBL) \
+ )
+ log_cobl_sample (trinfo) ;
+#endif
+
+}
+/*---------------------------------------------------------------------------*/
+static void
+DEFUN (pc_sample_record_heathen_cobl, (trinfo), struct trap_recovery_info * trinfo)
+{
+ pc_sample_record_cobl (trinfo, & heathen_cobl_profile_buffer_state) ;
+
+#if ( defined(PCS_LOG) /* Sample console logging */ \
+ || defined(PCS_LOG_COBL) \
+ || defined(PCS_LOG_HEATHEN_COBL) \
+ )
+ log_cobl_sample (trinfo) ;
+#endif
+
+}
+
+
+
+
+/*****************************************************************************/
+#endif /* REALLY_INCLUDE_PROFILE_CODE */
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/pcsample/pcscobl.scm,v 1.1 1995/07/28 14:14:08 adams Exp $
+
+Copyright (c) 1993 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; PC Sampling Code Blocks (i.e., compiled procedure profiling)
+;;; package: (pc-sample code-blocks)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; ;;;
+;;;;; THIS CODE IS HEAVILY SNARFED FROM PCSIPROC.SCM ;;;;;
+;;; ;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;; Of course, this means I really should ;;;;;;;;;
+;;;;;;;;; abstract all this common structure out ;;;;;;;;;
+;;;;;;;;; but first, let's just make it work, OK ;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+#|
+ |=============================================================================
+ | TODO:
+ | - DBG info should be groveled only at display time, not at hash time.
+ |
+ |=============================================================================
+ |#
+
+(declare (usual-integrations))
+\f
+(define (initialize-package!)
+ (set! *purified-proc-cobl-profile-table* ( proc-cobl-profile-table/make))
+ (set! *heathen-proc-cobl-profile-table* ( proc-cobl-profile-table/make))
+ (set! *purified-dbg-cobl-profile-table* ( dbg-cobl-profile-table/make))
+ (set! *heathen-dbg-cobl-profile-table* ( dbg-cobl-profile-table/make))
+ (set! *purified-raw-cobl-profile-table* ( raw-cobl-profile-table/make))
+ (set! *heathen-raw-cobl-profile-table* ( raw-cobl-profile-table/make))
+ (set! *purified-trampoline-profile-table* (trampoline-profile-table/make))
+ (set! *heathen-trampoline-profile-table* (trampoline-profile-table/make))
+ ;; microlevel buffer install
+ (install-code-block-profile-buffers/length)
+ ;; Bozo test
+ (if (not (compiled-code-address? reconstruct-compiled-procedure))
+ (warn
+ "pcscobl is unhappy: reconstruct-compiled-procedure is interpreted")))
+
+(define-primitives
+ (purified-code-block-profile-buffer/empty? 0)
+ ( heathen-code-block-profile-buffer/empty? 0)
+ (purified-code-block-profile-buffer/next-empty-slot-index 0)
+ ( heathen-code-block-profile-buffer/next-empty-slot-index 0)
+ (purified-code-block-profile-buffer/slack 0)
+ ( heathen-code-block-profile-buffer/slack 0)
+ (purified-code-block-profile-buffer/slack-increment 0)
+ ( heathen-code-block-profile-buffer/slack-increment 0)
+ (purified-code-block-profile-buffer/set-slack 1)
+ ( heathen-code-block-profile-buffer/set-slack 1)
+ (purified-code-block-profile-buffer/set-slack-increment 1)
+ ( heathen-code-block-profile-buffer/set-slack-increment 1)
+ (purified-code-block-profile-buffer/extend-noisy? 0)
+ ( heathen-code-block-profile-buffer/extend-noisy? 0)
+ (purified-code-block-profile-buffer/flush-noisy? 0)
+ ( heathen-code-block-profile-buffer/flush-noisy? 0)
+ (purified-code-block-profile-buffer/overflow-noisy? 0)
+ ( heathen-code-block-profile-buffer/overflow-noisy? 0)
+ (purified-code-block-profile-buffer/extend-noisy?/toggle! 0)
+ ( heathen-code-block-profile-buffer/extend-noisy?/toggle! 0)
+ (purified-code-block-profile-buffer/flush-noisy?/toggle! 0)
+ ( heathen-code-block-profile-buffer/flush-noisy?/toggle! 0)
+ (purified-code-block-profile-buffer/overflow-noisy?/toggle! 0)
+ ( heathen-code-block-profile-buffer/overflow-noisy?/toggle! 0)
+ ;; microcode magic: don't look. Fnord!
+ (%pc-sample/PCBPB-overflow-count 0)
+ (%pc-sample/HCBPB-overflow-count 0)
+ (%pc-sample/PCBPB-overflow-count/reset 0)
+ (%pc-sample/HCBPB-overflow-count/reset 0)
+ (%pc-sample/PCBPB-monitoring? 0)
+ (%pc-sample/HCBPB-monitoring? 0)
+ (%pc-sample/PCBPB-monitoring?/toggle! 0)
+ (%pc-sample/HCBPB-monitoring?/toggle! 0)
+ )
+
+(define (profile-buffer/with-mumble-notification! noise? thunk
+ x/f-noisy? toggle-noise!)
+ (let ((already-noisy? (x/f-noisy?))
+ (want-no-noise? (not noise?))) ; coerce to Boolean
+ (if (eq? already-noisy? want-no-noise?) ; xor want and got
+ (dynamic-wind toggle-noise! thunk toggle-noise!)
+ (thunk))))
+
+(define (purified-code-block-profile-buffer/with-extend-notification! noise?
+ thunk)
+ (profile-buffer/with-mumble-notification! noise? thunk
+ purified-code-block-profile-buffer/extend-noisy?
+ purified-code-block-profile-buffer/extend-noisy?/toggle!))
+
+(define ( heathen-code-block-profile-buffer/with-extend-notification! noise?
+ thunk)
+ (profile-buffer/with-mumble-notification! noise? thunk
+ heathen-code-block-profile-buffer/extend-noisy?
+ heathen-code-block-profile-buffer/extend-noisy?/toggle!))
+
+(define (purified-code-block-profile-buffer/with-flush-notification! noise?
+ thunk)
+ (profile-buffer/with-mumble-notification! noise? thunk
+ purified-code-block-profile-buffer/flush-noisy?
+ purified-code-block-profile-buffer/flush-noisy?/toggle!))
+
+(define ( heathen-code-block-profile-buffer/with-flush-notification! noise?
+ thunk)
+ (profile-buffer/with-mumble-notification! noise? thunk
+ heathen-code-block-profile-buffer/flush-noisy?
+ heathen-code-block-profile-buffer/flush-noisy?/toggle!))
+
+(define (purified-code-block-profile-buffer/with-overflow-notification! noise?
+ thunk)
+ (profile-buffer/with-mumble-notification! noise? thunk
+ purified-code-block-profile-buffer/overflow-noisy?
+ purified-code-block-profile-buffer/overflow-noisy?/toggle!))
+
+(define ( heathen-code-block-profile-buffer/with-overflow-notification! noise?
+ thunk)
+ (profile-buffer/with-mumble-notification! noise? thunk
+ heathen-code-block-profile-buffer/overflow-noisy?
+ heathen-code-block-profile-buffer/overflow-noisy?/toggle!))
+\f
+;;; Code Block Profile Buffers buffer up sightings of compiled procs
+;;; that are not yet hashed into the Code Block Profile (Hash) Tables
+;;;
+;;; Purified code blocks are distinguished from non-purified (``heathen'') ones
+;;; because, well, it seemd like the thing to do at the time and I couldn't
+;;; think of a very good reason not to.
+
+(define *purified-code-block-profile-block-buffer* #F) ; software cache o' FOV
+(define *heathen-code-block-profile-block-buffer* #F) ; software cache o' FOV
+
+(define *purified-code-block-profile-offset-buffer* #F) ; software cache o' FOV
+(define *heathen-code-block-profile-offset-buffer* #F) ; software cache o' FOV
+
+(define (code-block-profiling-disabled?)
+ (not (or *purified-code-block-profile-block-buffer* ; should all be synch'd
+ *heathen-code-block-profile-block-buffer*
+ *purified-code-block-profile-offset-buffer*
+ *heathen-code-block-profile-offset-buffer*)))
+
+(define *purified-code-block-profile-buffer/length/initial*)
+(define *heathen-code-block-profile-buffer/length/initial*)
+
+(define (install-code-block-profile-buffers/length/initial)
+ (set! *purified-code-block-profile-buffer/length/initial*
+ (* 4 (purified-code-block-profile-buffer/slack)))
+ (set! *heathen-code-block-profile-buffer/length/initial*
+ (* 4 ( heathen-code-block-profile-buffer/slack)))
+ )
+
+(define *purified-code-block-profile-buffer/length*)
+(define *heathen-code-block-profile-buffer/length*)
+
+(define (install-code-block-profile-buffers/length)
+ ( install-code-block-profile-buffers/length/initial)
+ (set! *purified-code-block-profile-buffer/length*
+ *purified-code-block-profile-buffer/length/initial*)
+ (set! *heathen-code-block-profile-buffer/length*
+ *heathen-code-block-profile-buffer/length/initial*)
+ )
+
+(define (purified-code-block-profile-buffer/length)
+ *purified-code-block-profile-buffer/length*)
+(define ( heathen-code-block-profile-buffer/length)
+ *heathen-code-block-profile-buffer/length*)
+
+(define (purified-code-block-profile-buffer/length/set! new-value)
+ (set! *purified-code-block-profile-buffer/length* new-value))
+(define ( heathen-code-block-profile-buffer/length/set! new-value)
+ (set! *heathen-code-block-profile-buffer/length* new-value))
+
+(define (code-block-profile-buffer/status)
+ "()\n\
+ Returns a list of two elements:\n\
+ 0) the purified code block profile buffer status, and\n\
+ 1) the heathen code block profile buffer status\n\
+ each of which is a dotted pair of buffer length cross buffer slack.\
+ "
+ (list (purified-code-block-profile-buffer/status)
+ ( heathen-code-block-profile-buffer/status)))
+
+(define (purified-code-block-profile-buffer/status)
+ "()\n\
+ Returns a CONS pair of the length and `slack' of the profile buffer for\n\
+ purified code blocks.\
+ "
+ (cons (purified-code-block-profile-buffer/length)
+ (purified-code-block-profile-buffer/slack)))
+(define ( heathen-code-block-profile-buffer/status)
+ "()\n\
+ Returns a CONS pair of the length and `slack' of the profile buffer for\n\
+ heathen code blocks.\
+ "
+ (cons ( heathen-code-block-profile-buffer/length)
+ ( heathen-code-block-profile-buffer/slack)))
+
+
+(define (code-block-profile-buffer/status/previous)
+ "()\n\
+ Returns the status of the profile buffer before the last modification to\n\
+ its length and/or slack.\n\
+ \n\
+ This status is a list of two elements:\n\
+ 0) the purified code block profile buffer status, and\n\
+ 1) the heathen code block profile buffer status\n\
+ each of which is a dotted pair of buffer length cross buffer slack.\
+ "
+ (list (purified-code-block-profile-buffer/status/previous)
+ ( heathen-code-block-profile-buffer/status/previous)))
+
+(define *purified-code-block-profile-buffer/status/old* '(0 . 0))
+(define (purified-code-block-profile-buffer/status/previous)
+ "()\n\
+ Returns the status of the profile buffer before the last modification to\n\
+ its length and/or slack.\
+ "
+ *purified-code-block-profile-buffer/status/old*)
+(define *heathen-code-block-profile-buffer/status/old* '(0 . 0))
+(define ( heathen-code-block-profile-buffer/status/previous)
+ "()\n\
+ Returns the status of the profile buffer before the last modification to\n\
+ its length and/or slack.\
+ "
+ *heathen-code-block-profile-buffer/status/old*)
+\f
+;;; Purified Code Blocks
+
+;;; TODO: flush/reset/spill/extend should all employ double buffering of the
+;;; code block profile buffers.
+
+(define *purified-code-block-profile-buffer/extend-count?* #F)
+(define-integrable (purified-code-block-profile-buffer/extend-count?)
+ *purified-code-block-profile-buffer/extend-count?*)
+(define-integrable (purified-code-block-profile-buffer/extend-count?/toggle!)
+ (set! *purified-code-block-profile-buffer/extend-count?*
+ (not *purified-code-block-profile-buffer/extend-count?*)))
+(define (purified-code-block-profile-buffer/with-extend-count! count?
+ thunk)
+ (fluid-let ((*purified-code-block-profile-buffer/extend-count?* count?))
+ (thunk)))
+(define *purified-code-block-profile-buffer/extend-count* 0)
+(define-integrable (purified-code-block-profile-buffer/extend-count)
+ *purified-code-block-profile-buffer/extend-count*)
+(define-integrable (purified-code-block-profile-buffer/extend-count/reset)
+ (set! *purified-code-block-profile-buffer/extend-count* 0))
+(define-integrable (purified-code-block-profile-buffer/extend-count/1+)
+ (set! *purified-code-block-profile-buffer/extend-count*
+ (1+ *purified-code-block-profile-buffer/extend-count*)))
+
+(define (purified-code-block-profile-buffer/extend)
+ (let ((stop/restart-sampler? (and (not *pc-sample/sample-sampler?*)
+ (pc-sample/started?))))
+ ;; stop if need be
+ (cond (stop/restart-sampler? (fluid-let ((*pc-sample/noisy?* #F))
+ (pc-sample/stop))))
+ ;; count if willed to
+ (cond ((purified-code-block-profile-buffer/extend-count?)
+ (purified-code-block-profile-buffer/extend-count/1+)))
+ ;; No need to disable during extend since we build an extended copy of the
+ ;; buffers then install them in one swell foop...
+ ;; Of course, any profile samples made during the extend will be discarded.
+ ;; For this reason, we go ahead and disable buffering anyway since
+ ;; it would be a waste of time.
+ (fixed-purified-code-block-profile-buffers/disable)
+ (cond ((purified-code-block-profile-buffer/extend-noisy?)
+ (with-output-to-port console-output-port ; in case we're in Edwin
+ (lambda ()
+ (display "\n;> > > > > PCBPB Extend Request being serviced.")))
+ (output-port/flush-output console-output-port)))
+ (let* ((slack (purified-code-block-profile-buffer/slack ))
+ (old-buffer-length (purified-code-block-profile-buffer/length))
+ (new-buffer-length (+ old-buffer-length slack) )
+ (new-block-buffer
+ (vector-grow *purified-code-block-profile-block-buffer*
+ new-buffer-length))
+ (new-offset-buffer
+ (vector-grow *purified-code-block-profile-offset-buffer*
+ new-buffer-length)))
+ ;; INVARIANT: unused slots o purified-code-block-profile-buffer must = #F
+ (do ((index old-buffer-length (1+ index)))
+ ((= index new-buffer-length))
+ (vector-set! new-block-buffer index #F)
+ (vector-set! new-offset-buffer index #F)
+ )
+ ;; Install new-buffers
+ (set! *purified-code-block-profile-block-buffer* new-block-buffer)
+ (set! *purified-code-block-profile-offset-buffer* new-offset-buffer)
+ ;; synch length cache
+ (purified-code-block-profile-buffer/length/set! new-buffer-length))
+ ;; Re-enable... synch kludge
+ (fixed-purified-code-block-profile-buffers/install
+ *purified-code-block-profile-block-buffer*
+ *purified-code-block-profile-offset-buffer*)
+ ;; restart if need be
+ (cond (stop/restart-sampler? (fluid-let ((*pc-sample/noisy?* #F))
+ (pc-sample/start)))))
+ unspecific)
+
+(define *purified-code-block-profile-buffer/flush-count?* #F)
+(define-integrable (purified-code-block-profile-buffer/flush-count?)
+ *purified-code-block-profile-buffer/flush-count?*)
+(define-integrable (purified-code-block-profile-buffer/flush-count?/toggle!)
+ (set! *purified-code-block-profile-buffer/flush-count?*
+ (not *purified-code-block-profile-buffer/flush-count?*)))
+(define (purified-code-block-profile-buffer/with-flush-count! count?
+ thunk)
+ (fluid-let ((*purified-code-block-profile-buffer/flush-count?* count?))
+ (thunk)))
+(define *purified-code-block-profile-buffer/flush-count* 0)
+(define-integrable (purified-code-block-profile-buffer/flush-count)
+ *purified-code-block-profile-buffer/flush-count*)
+(define-integrable (purified-code-block-profile-buffer/flush-count/reset)
+ (set! *purified-code-block-profile-buffer/flush-count* 0))
+(define-integrable (purified-code-block-profile-buffer/flush-count/1+)
+ (set! *purified-code-block-profile-buffer/flush-count*
+ (1+ *purified-code-block-profile-buffer/flush-count*)))
+
+(define-integrable (purified-code-block-profile-buffer/flush)
+ (cond
+ ((and *purified-code-block-profile-block-buffer* ; not disabled
+ *purified-code-block-profile-offset-buffer* ; (should be synch'd)
+ (purified-code-block-profile-buffer/flush?))
+ (purified-code-block-profile-buffer/spill-into-code-block-profile-tables)))
+ unspecific)
+
+(define (purified-code-block-profile-buffer/reset)
+ ;; It is important to disable the buffers during reset so we don't have any
+ ;; random ignored samples dangling in the buffer.
+ (let ((next-mt-slot-index
+ ;; Bletch: need to disable buffers but must sniff next-mt-slot-index
+ ;; first, then must ensure nothing new is buffered.
+ (without-interrupts
+ (lambda ()
+ (let ((nmtsi
+ (purified-code-block-profile-buffer/next-empty-slot-index)))
+ ;; NB: No interrupts between LET rhs and following assignments
+ (fixed-purified-code-block-profile-buffers/disable)
+ nmtsi)))))
+ ;; It is useful to keep a global var as a handle on this object.
+ (cond ((and *purified-code-block-profile-block-buffer*
+ *purified-code-block-profile-offset-buffer*) ;(should B synchd)
+ ;; Already initialized so avoid CONS-ing
+ (subvector-fill! *purified-code-block-profile-block-buffer*
+ 0 next-mt-slot-index #F)
+ (subvector-fill! *purified-code-block-profile-offset-buffer*
+ 0 next-mt-slot-index #F)
+ )
+ (else
+ ;; Else initialize them
+ (set! *purified-code-block-profile-block-buffer*
+ (pc-sample/code-block-buffer/make/purified-blocks))
+ (set! *purified-code-block-profile-offset-buffer*
+ (pc-sample/code-block-buffer/make/purified-offsets))
+ )))
+ ;; Re-enable... synch kludge
+ (fixed-purified-code-block-profile-buffers/install
+ *purified-code-block-profile-block-buffer*
+ *purified-code-block-profile-offset-buffer*)
+ (cond ((pc-sample/uninitialized?)
+ (pc-sample/set-state! 'RESET)))
+ 'RESET)
+
+(define (purified-code-block-profile-buffer/flush?)
+ (not (purified-code-block-profile-buffer/empty?)))
+
+(define (purified-code-block-profile-buffer/spill-into-code-block-profile-tables)
+ (let ((stop/restart-sampler? (and (not *pc-sample/sample-sampler?*)
+ (pc-sample/started?))))
+ ;; stop if need be
+ (cond (stop/restart-sampler? (fluid-let ((*pc-sample/noisy?* #F))
+ (pc-sample/stop))))
+ ;; count if willed to
+ (cond ((purified-code-block-profile-buffer/flush-count?)
+ (purified-code-block-profile-buffer/flush-count/1+)))
+ ;; It is important to disable the buffers during spillage so we don't have
+ ;; random ignored samples dangling in the buffer.
+ (let ((next-mt-slot-index
+ ;; Bletch: need to disable buffers but must sniff next-mt-slot-index
+ ;; first, then must ensure nothing new is buffered.
+ (without-interrupts
+ (lambda ()
+ (let
+ ((nmtsi
+ (purified-code-block-profile-buffer/next-empty-slot-index)))
+ ;; NB: No interrupts between LET rhs and following assignments
+ (fixed-purified-code-block-profile-buffers/disable)
+ nmtsi)))))
+ (cond ((purified-code-block-profile-buffer/flush-noisy?)
+ (with-output-to-port console-output-port ; in case we're in Edwin
+ (lambda ()
+ (display "\n;> > > > > PCBPB Flush Request being serviced.")))
+ (output-port/flush-output console-output-port)))
+ (do ((index 0 (1+ index)))
+ ((= index next-mt-slot-index))
+ ;; copy from buffer into hash table
+ (purified-code-block-profile-tables/hash-entry
+ (vector-ref *purified-code-block-profile-block-buffer* index)
+ (vector-ref *purified-code-block-profile-offset-buffer* index))
+ ;; Adios, amigos
+ (vector-set! *purified-code-block-profile-block-buffer* index #F)
+ (vector-set! *purified-code-block-profile-offset-buffer* index #F)
+ ))
+ ;; Re-enable... synch kludge
+ (fixed-purified-code-block-profile-buffers/install
+ *purified-code-block-profile-block-buffer*
+ *purified-code-block-profile-offset-buffer*)
+ ;; restart if need be
+ (cond (stop/restart-sampler? (fluid-let ((*pc-sample/noisy?* #F))
+ (pc-sample/start)))))
+ unspecific)
+
+
+
+(define-integrable (purified-code-block-profile-buffer/overflow-count?)
+ (%pc-sample/PCBPB-monitoring?))
+(define-integrable (purified-code-block-profile-buffer/overflow-count?/toggle!)
+ (%pc-sample/PCBPB-monitoring?/toggle!))
+
+(define (purified-code-block-profile-buffer/with-overflow-count! count? thunk)
+ (let ((counting? (purified-code-block-profile-buffer/overflow-count?))
+ (want-no-count? (not count?))) ; coerce to Boolean
+ (if (eq? counting? want-no-count?) ; xor want and got
+ (dynamic-wind purified-code-block-profile-buffer/overflow-count?/toggle!
+ thunk
+ purified-code-block-profile-buffer/overflow-count?/toggle!)
+ (thunk))))
+
+(define-integrable (purified-code-block-profile-buffer/overflow-count )
+ (%pc-sample/PCBPB-overflow-count ))
+(define-integrable (purified-code-block-profile-buffer/overflow-count/reset)
+ (%pc-sample/PCBPB-overflow-count/reset))
+\f
+;;; Heathen Code Blocks
+
+;;; TODO: flush/reset/spill/extend should all employ double buffering of the
+;;; code block profile buffers.
+
+(define *heathen-code-block-profile-buffer/extend-count?* #F)
+(define-integrable (heathen-code-block-profile-buffer/extend-count?)
+ *heathen-code-block-profile-buffer/extend-count?*)
+(define-integrable (heathen-code-block-profile-buffer/extend-count?/toggle!)
+ (set! *heathen-code-block-profile-buffer/extend-count?*
+ (not *heathen-code-block-profile-buffer/extend-count?*)))
+(define (heathen-code-block-profile-buffer/with-extend-count! count?
+ thunk)
+ (fluid-let ((*heathen-code-block-profile-buffer/extend-count?* count?))
+ (thunk)))
+(define *heathen-code-block-profile-buffer/extend-count* 0)
+(define-integrable (heathen-code-block-profile-buffer/extend-count)
+ *heathen-code-block-profile-buffer/extend-count*)
+(define-integrable (heathen-code-block-profile-buffer/extend-count/reset)
+ (set! *heathen-code-block-profile-buffer/extend-count* 0))
+(define-integrable (heathen-code-block-profile-buffer/extend-count/1+)
+ (set! *heathen-code-block-profile-buffer/extend-count*
+ (1+ *heathen-code-block-profile-buffer/extend-count*)))
+
+(define (heathen-code-block-profile-buffer/extend)
+ (let ((stop/restart-sampler? (and (not *pc-sample/sample-sampler?*)
+ (pc-sample/started?))))
+ ;; stop if need be
+ (cond (stop/restart-sampler? (fluid-let ((*pc-sample/noisy?* #F))
+ (pc-sample/stop))))
+ ;; count if willed to
+ (cond ((heathen-code-block-profile-buffer/extend-count?)
+ (heathen-code-block-profile-buffer/extend-count/1+)))
+ ;; No need to disable during extend since we build an extended copy of the
+ ;; buffers then install them in one swell foop...
+ ;; Of course, any profile samples made during the extend will be discarded.
+ ;; For this reason, we go ahead and disable buffering anyway since
+ ;; it would be a waste of time.
+ (fixed-heathen-code-block-profile-buffers/disable)
+ (cond ((heathen-code-block-profile-buffer/extend-noisy?)
+ (with-output-to-port console-output-port ; in case we're in Edwin
+ (lambda ()
+ (display "\n;> > > > > HCBPB Extend Request being serviced.")))
+ (output-port/flush-output console-output-port)))
+ (let* ((slack (heathen-code-block-profile-buffer/slack ))
+ (old-buffer-length (heathen-code-block-profile-buffer/length))
+ (new-buffer-length (+ old-buffer-length slack) )
+ (new-block-buffer
+ (vector-grow *heathen-code-block-profile-block-buffer*
+ new-buffer-length))
+ (new-offset-buffer
+ (vector-grow *heathen-code-block-profile-offset-buffer*
+ new-buffer-length)))
+ ;; INVARIANT: unused slots o heathen-code-block-profile-buffer must be #F
+ (do ((index old-buffer-length (1+ index)))
+ ((= index new-buffer-length))
+ (vector-set! new-block-buffer index #F)
+ (vector-set! new-offset-buffer index #F)
+ )
+ ;; Install new-buffers
+ (set! *heathen-code-block-profile-block-buffer* new-block-buffer)
+ (set! *heathen-code-block-profile-offset-buffer* new-offset-buffer)
+ ;; synch length cache
+ (heathen-code-block-profile-buffer/length/set! new-buffer-length))
+ ;; Re-enable ... synch kludge
+ (fixed-heathen-code-block-profile-buffers/install
+ *heathen-code-block-profile-block-buffer*
+ *heathen-code-block-profile-offset-buffer*)
+ ;; restart if need be
+ (cond (stop/restart-sampler? (fluid-let ((*pc-sample/noisy?* #F))
+ (pc-sample/start)))))
+ unspecific)
+
+(define *heathen-code-block-profile-buffer/flush-count?* #F)
+(define-integrable (heathen-code-block-profile-buffer/flush-count?)
+ *heathen-code-block-profile-buffer/flush-count?*)
+(define-integrable (heathen-code-block-profile-buffer/flush-count?/toggle!)
+ (set! *heathen-code-block-profile-buffer/flush-count?*
+ (not *heathen-code-block-profile-buffer/flush-count?*)))
+(define (heathen-code-block-profile-buffer/with-flush-count! count?
+ thunk)
+ (fluid-let ((*heathen-code-block-profile-buffer/flush-count?* count?))
+ (thunk)))
+(define *heathen-code-block-profile-buffer/flush-count* 0)
+(define-integrable (heathen-code-block-profile-buffer/flush-count)
+ *heathen-code-block-profile-buffer/flush-count*)
+(define-integrable (heathen-code-block-profile-buffer/flush-count/reset)
+ (set! *heathen-code-block-profile-buffer/flush-count* 0))
+(define-integrable (heathen-code-block-profile-buffer/flush-count/1+)
+ (set! *heathen-code-block-profile-buffer/flush-count*
+ (1+ *heathen-code-block-profile-buffer/flush-count*)))
+
+(define-integrable (heathen-code-block-profile-buffer/flush)
+ (cond
+ ((and *heathen-code-block-profile-block-buffer* ; not disabled
+ *heathen-code-block-profile-offset-buffer* ; (should be synch'd)
+ (heathen-code-block-profile-buffer/flush?))
+ (heathen-code-block-profile-buffer/spill-into-code-block-profile-tables)))
+ unspecific)
+
+(define (heathen-code-block-profile-buffer/reset)
+ ;; It is important to disable the buffers during reset so we don't have any
+ ;; random ignored samples dangling in the buffer.
+ (let ((next-mt-slot-index
+ ;; Bletch: need to disable buffers but must sniff next-mt-slot-index
+ ;; first, then must ensure nothing new is buffered.
+ (without-interrupts
+ (lambda ()
+ (let ((nmtsi
+ (heathen-code-block-profile-buffer/next-empty-slot-index)))
+ ;; NB: No interrupts between LET rhs and following assignments
+ (fixed-heathen-code-block-profile-buffers/disable)
+ nmtsi)))))
+ ;; It is useful to keep a global var as a handle on this object.
+ (cond ((and *heathen-code-block-profile-block-buffer*
+ *heathen-code-block-profile-offset-buffer*) ;(should B synch'd)
+ ;; Already initialized so avoid CONS-ing
+ (subvector-fill! *heathen-code-block-profile-block-buffer*
+ 0 next-mt-slot-index #F)
+ (subvector-fill! *heathen-code-block-profile-offset-buffer*
+ 0 next-mt-slot-index #F)
+ )
+ (else
+ ;; Else initialize them
+ (set! *heathen-code-block-profile-block-buffer*
+ (pc-sample/code-block-buffer/make/heathen-blocks))
+ (set! *heathen-code-block-profile-offset-buffer*
+ (pc-sample/code-block-buffer/make/heathen-offsets))
+ )))
+ ;; Re-enable ... synch kludge
+ (fixed-heathen-code-block-profile-buffers/install
+ *heathen-code-block-profile-block-buffer*
+ *heathen-code-block-profile-offset-buffer*)
+ (cond ((pc-sample/uninitialized?)
+ (pc-sample/set-state! 'RESET)))
+ 'RESET)
+
+(define (heathen-code-block-profile-buffer/flush?)
+ (not (heathen-code-block-profile-buffer/empty?)))
+
+(define (heathen-code-block-profile-buffer/spill-into-code-block-profile-tables)
+ (let ((stop/restart-sampler? (and (not *pc-sample/sample-sampler?*)
+ (pc-sample/started?))))
+ ;; stop if need be
+ (cond (stop/restart-sampler? (fluid-let ((*pc-sample/noisy?* #F))
+ (pc-sample/stop))))
+ ;; count if willed to
+ (cond ((heathen-code-block-profile-buffer/flush-count?)
+ (heathen-code-block-profile-buffer/flush-count/1+)))
+ ;; It is important to disable the buffers during spillage so we don't have
+ ;; any random ignored samples dangling in the buffer.
+ (let ((next-mt-slot-index
+ ;; Bletch: need to disable buffers but must sniff next-mt-slot-index
+ ;; first, then must ensure nothing new is buffered.
+ (without-interrupts
+ (lambda ()
+ (let
+ ((nmtsi
+ (heathen-code-block-profile-buffer/next-empty-slot-index)))
+ ;; NB: No interrupts between LET rhs and following assignments
+ (fixed-heathen-code-block-profile-buffers/disable)
+ nmtsi)))))
+ (cond ((heathen-code-block-profile-buffer/flush-noisy?)
+ (with-output-to-port console-output-port ; in case we're in Edwin
+ (lambda ()
+ (display "\n;> > > > > HCBPB Flush Request being serviced.")))
+ (output-port/flush-output console-output-port)))
+ (do ((index 0 (1+ index)))
+ ((= index next-mt-slot-index))
+ ;; copy from buffer into hash table
+ (heathen-code-block-profile-tables/hash-entry
+ (vector-ref *heathen-code-block-profile-block-buffer* index)
+ (vector-ref *heathen-code-block-profile-offset-buffer* index))
+ ;; Siyonara, Banzai!
+ (vector-set! *heathen-code-block-profile-block-buffer* index #F)
+ (vector-set! *heathen-code-block-profile-offset-buffer* index #F)
+ ))
+ ;; Re-enable... synch kludge
+ (fixed-heathen-code-block-profile-buffers/install
+ *heathen-code-block-profile-block-buffer*
+ *heathen-code-block-profile-offset-buffer*)
+ ;; restart if need be
+ (cond (stop/restart-sampler? (fluid-let ((*pc-sample/noisy?* #F))
+ (pc-sample/start)))))
+ unspecific)
+
+
+
+(define-integrable (heathen-code-block-profile-buffer/overflow-count?)
+ (%pc-sample/HCBPB-monitoring?))
+(define-integrable (heathen-code-block-profile-buffer/overflow-count?/toggle!)
+ (%pc-sample/HCBPB-monitoring?/toggle!))
+
+(define (heathen-code-block-profile-buffer/with-overflow-count! count? thunk)
+ (let ((counting? (heathen-code-block-profile-buffer/overflow-count?))
+ (want-no-count? (not count?))) ; coerce to Boolean
+ (if (eq? counting? want-no-count?) ; xor want and got
+ (dynamic-wind heathen-code-block-profile-buffer/overflow-count?/toggle!
+ thunk
+ heathen-code-block-profile-buffer/overflow-count?/toggle!)
+ (thunk))))
+
+(define-integrable (heathen-code-block-profile-buffer/overflow-count )
+ (%pc-sample/HCBPB-overflow-count ))
+(define-integrable (heathen-code-block-profile-buffer/overflow-count/reset)
+ (%pc-sample/HCBPB-overflow-count/reset))
+\f
+;;; Code Block Profile (Hash) Tables are where compiled procs are profiled...
+;;; but the profile trap handler cannot CONS so if the current profiled
+;;; proc is not already hashed, we must buffer it in the Code Block Profile
+;;; Buffer until the GC Daemon gets around to hashing it.
+;;;
+;;; Notice too that we maintain four distinct profile tables for each of the
+;;; two kinds of code blocks (purified and heathen). These four tables
+;;; are:
+;;; proc-cobl - code-block proc was completely isolated and identified
+;;; dbg-cobl - code-block proc not isolated but found debugging info
+;;; raw-cobl - code-block proc was not isolated and no debugging info
+;;; trampoline - trampoline code (e.g., manifest
+;;;
+;;; This is because we may occasionally be unable to determine just which cobl
+;;; proc within a code block we were about to execute (e.g., may have been
+;;; in the head of the code block just when we sampled so did not yet jump
+;;; to proc in the code block). In such cases, we cannot profile the precise
+;;; cobl proc we were about to enter, so we just profile the code block as a
+;;; whole. These instances should be statistically fairly improbable.
+;;; The cases were we could not isolate the proc because the debugging info
+;;; was not available will be nil if all the ducky inf files are around...
+;;; but if some bozo deletes them all, we should at least not crash.
+;;; And until we teach the trampoline code to be more accomodating we will
+;;; keep it around after class to torture it at our leisure.
+
+(define *purified-proc-cobl-profile-table*)
+(define *heathen-proc-cobl-profile-table*)
+(define *purified-dbg-cobl-profile-table*)
+(define *heathen-dbg-cobl-profile-table*)
+(define *purified-raw-cobl-profile-table*)
+(define *heathen-raw-cobl-profile-table*)
+(define *purified-trampoline-profile-table*)
+(define *heathen-trampoline-profile-table*)
+
+(define ( proc-cobl-profile-table/make) (make-profile-hash-table 4096))
+(define ( dbg-cobl-profile-table/make) (make-profile-hash-table 1024))
+(define ( raw-cobl-profile-table/make) (make-profile-hash-table 2048))
+(define (trampoline-profile-table/make) (make-profile-hash-table 512))
+
+(define (code-block-profile-table)
+ (vector ( purified-proc-cobl-profile-table)
+ ( purified-dbg-cobl-profile-table)
+ ( purified-raw-cobl-profile-table)
+ (purified-trampoline-profile-table)
+ ( heathen-proc-cobl-profile-table)
+ ( heathen-dbg-cobl-profile-table)
+ ( heathen-raw-cobl-profile-table)
+ ( heathen-trampoline-profile-table)
+ ))
+
+(define (purified-proc-cobl-profile-table)
+ (purified-code-block-profile-buffer/flush)
+ (hash-table/entries-vector *purified-proc-cobl-profile-table*))
+(define ( heathen-proc-cobl-profile-table)
+ ( heathen-code-block-profile-buffer/flush)
+ (hash-table/entries-vector *heathen-proc-cobl-profile-table*))
+
+(define (purified-dbg-cobl-profile-table)
+ (purified-code-block-profile-buffer/flush)
+ (hash-table/entries-vector *purified-dbg-cobl-profile-table*))
+(define ( heathen-dbg-cobl-profile-table)
+ ( heathen-code-block-profile-buffer/flush)
+ (hash-table/entries-vector *heathen-dbg-cobl-profile-table*))
+
+(define (purified-raw-cobl-profile-table)
+ (purified-code-block-profile-buffer/flush)
+ (hash-table/entries-vector *purified-raw-cobl-profile-table*))
+(define ( heathen-raw-cobl-profile-table)
+ ( heathen-code-block-profile-buffer/flush)
+ (hash-table/entries-vector *heathen-raw-cobl-profile-table*))
+
+(define (purified-trampoline-profile-table)
+ (purified-code-block-profile-buffer/flush)
+ (hash-table/entries-vector *purified-trampoline-profile-table*))
+(define ( heathen-trampoline-profile-table)
+ ( heathen-code-block-profile-buffer/flush)
+ (hash-table/entries-vector *heathen-trampoline-profile-table*))
+
+
+(define (code-block-profile-table/old)
+ (vector ( purified-proc-cobl-profile-table/old)
+ ( purified-dbg-cobl-profile-table/old)
+ ( purified-raw-cobl-profile-table/old)
+ (purified-trampoline-profile-table/old)
+ ( heathen-proc-cobl-profile-table/old)
+ ( heathen-dbg-cobl-profile-table/old)
+ ( heathen-raw-cobl-profile-table/old)
+ ( heathen-trampoline-profile-table/old)
+ ))
+
+(define *purified-proc-cobl-profile-table/old* #F)
+(define (purified-proc-cobl-profile-table/old)
+ *purified-proc-cobl-profile-table/old*)
+(define *heathen-proc-cobl-profile-table/old* #F)
+(define ( heathen-proc-cobl-profile-table/old)
+ *heathen-proc-cobl-profile-table/old*)
+
+(define *purified-dbg-cobl-profile-table/old* #F)
+(define (purified-dbg-cobl-profile-table/old)
+ *purified-dbg-cobl-profile-table/old*)
+(define *heathen-dbg-cobl-profile-table/old* #F)
+(define ( heathen-dbg-cobl-profile-table/old)
+ *heathen-dbg-cobl-profile-table/old*)
+
+(define *purified-raw-cobl-profile-table/old* #F)
+(define (purified-raw-cobl-profile-table/old)
+ *purified-raw-cobl-profile-table/old*)
+(define *heathen-raw-cobl-profile-table/old* #F)
+(define ( heathen-raw-cobl-profile-table/old)
+ *heathen-raw-cobl-profile-table/old*)
+
+(define *purified-trampoline-profile-table/old* #F)
+(define (purified-trampoline-profile-table/old)
+ *purified-trampoline-profile-table/old*)
+(define *heathen-trampoline-profile-table/old* #F)
+(define ( heathen-trampoline-profile-table/old)
+ *heathen-trampoline-profile-table/old*)
+
+
+(define (code-block-profile-tables/reset #!optional disable?)
+ (cond ((or (default-object? disable?) (not disable?))
+ (purified-code-block-profile-tables/reset)
+ ( heathen-code-block-profile-tables/reset))
+ (else
+ (purified-code-block-profile-tables/reset disable?)
+ ( heathen-code-block-profile-tables/reset disable?))))
+
+(define (purified-code-block-profile-tables/reset #!optional disable?)
+ (set! *purified-proc-cobl-profile-table/old*
+ ( purified-proc-cobl-profile-table))
+ (set! *purified-dbg-cobl-profile-table/old*
+ (purified-dbg-cobl-profile-table))
+ (set! *purified-raw-cobl-profile-table/old*
+ (purified-raw-cobl-profile-table))
+ (set! *purified-trampoline-profile-table/old*
+ (purified-trampoline-profile-table))
+ (hash-table/clear! *purified-proc-cobl-profile-table*)
+ (hash-table/clear! *purified-dbg-cobl-profile-table*)
+ (hash-table/clear! *purified-raw-cobl-profile-table*)
+ (hash-table/clear! *purified-trampoline-profile-table*)
+ (set! *purified-code-block-profile-buffer/status/old*
+ (purified-code-block-profile-buffer/status))
+ (cond ((and (not (default-object? disable?)) disable?)
+ ;; Disabling buffer disables table
+ (set! *purified-code-block-profile-block-buffer* #F)
+ (set! *purified-code-block-profile-offset-buffer* #F)
+ (fixed-purified-code-block-profile-buffers/disable)
+ (if (pc-sample/initialized?)
+ 'RESET-AND-DISABLED
+ 'STILL-UNINITIALIZED))
+ ;; Disabled but wanna enable?
+ ((or (not *purified-code-block-profile-block-buffer*);(should B synchd)
+ (not *purified-code-block-profile-offset-buffer*))
+ (purified-code-block-profile-buffer/reset))
+ (else
+ 'RESET)))
+
+(define (heathen-code-block-profile-tables/reset #!optional disable?)
+ (set! *heathen-proc-cobl-profile-table/old*
+ ( heathen-proc-cobl-profile-table))
+ (set! *heathen-dbg-cobl-profile-table/old*
+ (heathen-dbg-cobl-profile-table))
+ (set! *heathen-raw-cobl-profile-table/old*
+ (heathen-raw-cobl-profile-table))
+ (set! *heathen-trampoline-profile-table/old*
+ (heathen-trampoline-profile-table))
+ (hash-table/clear! *heathen-proc-cobl-profile-table*)
+ (hash-table/clear! *heathen-dbg-cobl-profile-table*)
+ (hash-table/clear! *heathen-raw-cobl-profile-table*)
+ (hash-table/clear! *heathen-trampoline-profile-table*)
+ (set! *heathen-code-block-profile-buffer/status/old*
+ (heathen-code-block-profile-buffer/status))
+ (cond ((and (not (default-object? disable?)) disable?)
+ ;; Disabling buffer disables table
+ (set! *heathen-code-block-profile-block-buffer* #F)
+ (set! *heathen-code-block-profile-offset-buffer* #F)
+ (fixed-heathen-code-block-profile-buffers/disable)
+ (if (pc-sample/initialized?)
+ 'RESET-AND-DISABLED
+ 'STILL-UNINITIALIZED))
+ ;; Disabled but wanna enable?
+ ((or (not *heathen-code-block-profile-block-buffer*);(should be synchd)
+ (not *heathen-code-block-profile-offset-buffer*))
+ (heathen-code-block-profile-buffer/reset))
+ (else
+ 'RESET)))
+
+(define (code-block-profile-tables/enable)
+ (purified-code-block-profile-tables/enable)
+ ( heathen-code-block-profile-tables/enable))
+
+(define (purified-code-block-profile-tables/enable)
+ (purified-code-block-profile-tables/reset))
+(define ( heathen-code-block-profile-tables/enable)
+ ( heathen-code-block-profile-tables/reset))
+
+
+(define (code-block-profile-tables/disable)
+ (purified-code-block-profile-tables/disable)
+ ( heathen-code-block-profile-tables/disable))
+
+(define (purified-code-block-profile-tables/disable)
+ (purified-code-block-profile-tables/reset 'DISABLE))
+(define ( heathen-code-block-profile-tables/disable)
+ ( heathen-code-block-profile-tables/reset 'DISABLE))
+
+
+;; Following three abstractions belong in udata.scm
+
+(define-integrable (compiled-code-block/trampoline? block)
+ (or (not (compiled-code-block/normal? block))
+ (trampoline/return-to-interpreter? block)))
+
+(define-integrable (compiled-code-block/normal? block)
+ (object-type?
+ (ucode-type manifest-vector)
+ ;; This combination returns an unsafe object, but since it
+ ;; is used as an argument to a primitive, I can get away
+ ;; with not turning off the garbage collector.
+ ((ucode-primitive primitive-object-ref 2) block 0)))
+
+(define-integrable (trampoline/return-to-interpreter? block)
+ ;;
+ ;; Format of special magic return_to_interpreter trampoline:
+ ;; looks normal at first glance but really isn't... two constants in
+ ;; linkage section are small positive integers.. hence typecode 0
+ ;;
+ (and (fix:zero? (object-type (compiled-code-block/debugging-info block)))
+ (fix:zero? (object-type (compiled-code-block/environment block)))))
+
+
+(define (purified-code-block-profile-tables/hash-entry cobl offset)
+ "(code-block offset)\n\
+ Hashes a purified code block and offset into the purified code block\n\
+ profile table (actually, one of four: proc-cobl, dbg-cobl, raw-cobl, or\n\
+ trampoline---\n\
+ The proc-cobl hashes a compiled-procedure, dbg-cobl hashes debugging-info\n\
+ descriptor [see runtime/infutl.scm read-debugging-info], and raw-cobl\n\
+ hashes code block objects as does trampoline.\
+ "
+ ;; ``Purified'' code blocks are those which have been moved into constant
+ ;; space and therefore will not be moved by the garbage collector. Thus,
+ ;; it is possible to hash them by their absolute address. This can be more
+ ;; efficient than resorting to the underlying Scheme object hashing.
+ (if (compiled-code-block/trampoline? cobl)
+ (profile-hash-table/update-entry cobl
+ *purified-trampoline-profile-table*)
+ (let ((cobl-dbg-info (compiled-code-block/dbg-info cobl 'demand-load)))
+ (if (not cobl-dbg-info) ; Sigh. Debug info not accessible
+ (if (not (compiled-code-block/debugging-info? cobl))
+ (profile-hash-table/update-entry
+ cobl
+ *purified-raw-cobl-profile-table*)
+ (let ((debugging-key
+ ;; NB: Currently, the debugging info is stored in the
+ ;; cobl so repeated accesses return EQ structures:
+ ;; Hash on it
+ (compiled-code-block/debugging-info cobl)))
+ (profile-hash-table/update-entry
+ debugging-key
+ *purified-dbg-cobl-profile-table*)))
+ (let* ((cobl-procv (dbg-info/procedures cobl-dbg-info))
+ ;; Invariant: cobl-procv is a non-null vector
+ (cobl-proc
+ (let ((last-index (-1+ (vector-length cobl-procv))))
+ (do ((index 0 (1+ index)))
+ ((or (= index last-index) ; last proc is it
+ (let ((next-proc (vector-ref cobl-procv
+ (1+ index))))
+ (> (dbg-procedure/label-offset next-proc)
+ offset)))
+ (vector-ref cobl-procv index))))))
+ ;; Paranoia for tracking down renegade samples
+;;; (pp `(((cobl--- ,cobl)
+;;; (datum-- ,(object-datum cobl))
+;;; (offset- ,offset))
+;;; (cprocv- ,cobl-procv)
+;;; (cproc-- ,cobl-proc )
+;;; ))
+;;; (pp (reconstruct-compiled-procedure cobl cobl-proc))
+ (profile-hash-table/update-entry
+ (reconstruct-compiled-procedure cobl cobl-proc)
+ *purified-proc-cobl-profile-table*)
+ )))))
+
+(define (heathen-code-block-profile-tables/hash-entry cobl offset)
+ "(code-block offset)\n\
+ Hashes a heathen code block and offset into the heathen code block\n\
+ profile table (actually, one of four: proc-cobl, dbg-cobl, raw-cobl,\n\
+ or trampoline---\n\
+ The proc-cobl hashes a compiled-procedure, dbg-cobl hashes debugging-info\n\
+ descriptor [see runtime/infutl.scm read-debugging-info], and raw-cobl\n\
+ hashes code block objects as does trampoline.\
+ "
+ ;; ``Heathen'' code blocks are those which have not been ``purified'' into
+ ;; constant space so they can be moved about by the garbage collector.
+ ;; For that reason we cannot hash them off their absolute address because
+ ;; that can change. Instead, we use the usual hashing method.
+ (if (compiled-code-block/trampoline? cobl)
+ (profile-hash-table/update-entry cobl *heathen-trampoline-profile-table*)
+ (let ((cobl-dbg-info (compiled-code-block/dbg-info cobl 'demand-load)))
+ (if (not cobl-dbg-info) ; Sigh. Debug info not accessible
+ (if (not (compiled-code-block/debugging-info? cobl))
+ (profile-hash-table/update-entry
+ cobl
+ *heathen-raw-cobl-profile-table*)
+ (let ((debugging-key
+ ;; NB: Currently, the debugging info is stored in the
+ ;; cobl so repeated accesses return EQ structures:
+ ;; Hash on it
+ (compiled-code-block/debugging-info cobl)))
+ (profile-hash-table/update-entry
+ debugging-key
+ *heathen-dbg-cobl-profile-table*)))
+ (let* ((cobl-procv (dbg-info/procedures cobl-dbg-info))
+ ;; Invariant: cobl-procv is a non-null vector
+ (cobl-proc
+ (let ((last-index (-1+ (vector-length cobl-procv))))
+ (do ((index 0 (1+ index)))
+ ((or (= index last-index) ; last proc is it
+ (let ((next-proc (vector-ref cobl-procv
+ (1+ index))))
+ (> (dbg-procedure/label-offset next-proc)
+ offset)))
+ (vector-ref cobl-procv index))))))
+ (profile-hash-table/update-entry
+ (reconstruct-compiled-procedure cobl cobl-proc)
+ *heathen-proc-cobl-profile-table*)
+ )))))
+
+;;; *** Warning: This must be compiled to avoid a call to
+;;; *** with-absolutely-no-interrupts
+
+(define (reconstruct-compiled-procedure cobl dbg-proc)
+ (let ((offset (dbg-procedure/label-offset dbg-proc)))
+ (with-absolutely-no-interrupts
+ (lambda ()
+ ((ucode-primitive primitive-object-set-type)
+ (ucode-type compiled-entry)
+ (make-non-pointer-object
+ (+ offset (object-datum cobl))))))))
+
+
+(define (profile-hash-table/update-entry entry-key-obj profile-hash-table)
+ (cond ((hash-table/get profile-hash-table entry-key-obj false)
+ =>
+ (lambda (datum) ; found
+ (code-block-profile-datum/update! datum)))
+ (else ; not found
+ (hash-table/put! profile-hash-table
+ entry-key-obj
+ (code-block-profile-datum/make)))))
+\f
+;;; Code Block Profile Datum
+
+(define-structure (code-block-profile-datum
+ (conc-name code-block-profile-datum/)
+ (constructor code-block-profile-datum/make
+ (#!optional count histogram rank utility)))
+ (count (code-block-profile-datum/count/make))
+ (histogram (code-block-profile-datum/histogram/make))
+ (rank (code-block-profile-datum/rank/make))
+ (utility (code-block-profile-datum/utility/make))
+ ;... more to come (?)
+ )
+
+(define (code-block-profile-datum/count/make) 1.0) ; FLONUM
+(define (code-block-profile-datum/histogram/make) '#())
+(define (code-block-profile-datum/rank/make) 0)
+(define (code-block-profile-datum/utility/make) 0.0) ; FLONUM
+;... more to come (?)
+
+(define (code-block-profile-datum/update! datum)
+ (set-code-block-profile-datum/count!
+ datum
+ (flo:+ 1.0 (code-block-profile-datum/count datum))) ; FLONUM
+ ;; histogram not yet implemented
+ ;; rank not yet implemented
+ ;; utility not yet implemented
+
+ ;; NB: returns datum
+ datum)
+
+;;; fini
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/pcsample/pcsdisp.scm,v 1.1 1995/07/28 14:14:08 adams Exp $
+
+Copyright (c) 1993 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; PC Sampling Display routines (pre-cursor to PC Sample SWAT frobs)
+;;; package: (pc-sample display)
+
+(declare (usual-integrations))
+\f
+(define (initialize-package!)
+ (install))
+
+(define-primitives
+ (get-primitive-name 1)
+ )
+
+;;; Aesthetics
+
+(define (pc-sample/status/display)
+ (pc-sample/status/display/header "")
+ (pc-sample/builtin/status/display 'SUBHEADER)
+ (pc-sample/utility/status/display 'SUBHEADER)
+ (pc-sample/primitive/status/display 'SUBHEADER)
+ (pc-sample/code-block/status/display 'SUBHEADER)
+ (pc-sample/interp-proc/status/display 'SUBHEADER)
+ (pc-sample/prob-comp/status/display 'SUBHEADER)
+ (pc-sample/UFO/status/display 'SUBHEADER)
+ unspecific)
+
+;; Status Displayers
+
+(define pc-sample/builtin/status/display)
+(define pc-sample/utility/status/display)
+(define pc-sample/primitive/status/display)
+(define pc-sample/code-block/status/display)
+(define pc-sample/interp-proc/status/display)
+(define pc-sample/prob-comp/status/display)
+(define pc-sample/UFO/status/display)
+
+(define (generate:pc-sample/status/displayer header-string display-proc)
+ (lambda (#!optional subheader?)
+ ((if (or (default-object? subheader?) (not subheader?)) ; display header
+ pc-sample/status/display/header
+ pc-sample/status/display/subheader)
+ header-string)
+ (display-proc)
+ (pc-sample/status/display/header/delimiter)
+ unspecific))
+
+(define-integrable (pc-sample/status/display/header/delimiter)
+ (display "\n;============================================================="))
+
+(define-integrable (pc-sample/status/display/subheader/delimiter)
+ (display "\n;------------------------------------------------------"))
+
+(define-integrable (pc-sample/status/display/title-root-string)
+ (display " PC Sampling status:"))
+
+(define-integrable (pc-sample/status/display/header title-prefix-string)
+ (pc-sample/status/display/header/delimiter)
+ (display (string-append "\n; " title-prefix-string))
+ (pc-sample/status/display/title-root-string)
+ (pc-sample/status/display/header/delimiter))
+
+(define-integrable (pc-sample/status/display/subheader subheader-title-string)
+ (display (string-append "\n; " subheader-title-string "..."))
+ (pc-sample/status/display/subheader/delimiter))
+
+(define (install-status-displayers)
+ (set! pc-sample/builtin/status/display (generate:pc-sample/status/displayer
+ "Hand Assembled Procedure (a.k.a. ``Built-In'') "
+ pc-sample/builtin/display))
+
+ (set! pc-sample/utility/status/display (generate:pc-sample/status/displayer
+ "Utility System Subroutine "
+ pc-sample/utility/display))
+
+ (set! pc-sample/primitive/status/display (generate:pc-sample/status/displayer
+ "Primitive Procedure "
+ pc-sample/primitive/display))
+
+ (set! pc-sample/code-block/status/display (generate:pc-sample/status/displayer
+ "Compiled Procedure (a.k.a. ``Code Block'') "
+ pc-sample/code-block/display))
+
+ (set! pc-sample/interp-proc/status/display (generate:pc-sample/status/displayer
+ "Interpreted Procedure (a.k.a. ``Interp-Proc'') "
+ pc-sample/interp-proc/display))
+
+ (set! pc-sample/prob-comp/status/display (generate:pc-sample/status/displayer
+ "Probably Compiled Function, Not Observably Residence Designated\n; (a.k.a. ``Prob Comp FNORD!'') "
+ pc-sample/prob-comp/display))
+
+ (set! pc-sample/UFO/status/display (generate:pc-sample/status/displayer
+ "Unidentifiable Function Object (a.k.a. ``UFO'') "
+ pc-sample/UFO/display))
+ )
+
+;; Structure [table] Displayers
+
+(define pc-sample/builtin/display)
+(define pc-sample/utility/display)
+(define pc-sample/primitive/display)
+(define pc-sample/code-block/display)
+(define pc-sample/interp-proc/display)
+(define pc-sample/prob-comp/display)
+(define pc-sample/UFO/display)
+
+(define (generate:pc-sample/table/displayer display-acater)
+ (lambda ()
+ (let ((displayee (display-acater)))
+ (cond ((string? displayee)
+ (newline)
+ (display displayee))
+ ((vector? displayee) ; spec., #(sample-list BTW-string)
+ (display-sample-list (vector-ref displayee 0))
+ (display (vector-ref displayee 1)))
+ (else
+ (display-sample-list displayee))))))
+
+(define (display-sample-list sample-list) ; not integrated so can play w/ it
+ (fluid-let ((*pp-default-as-code?* #T)) ; for now: just pp as code, but
+ (pp sample-list))) ; maybe opt for wizzy graphics later
+
+(define (install-displayers)
+ (set! pc-sample/builtin/display (generate:pc-sample/table/displayer
+ pc-sample/builtin/display-acate))
+
+ (set! pc-sample/utility/display (generate:pc-sample/table/displayer
+ pc-sample/utility/display-acate))
+
+ (set! pc-sample/primitive/display (generate:pc-sample/table/displayer
+ pc-sample/primitive/display-acate))
+
+ (set! pc-sample/code-block/display (generate:pc-sample/table/displayer
+ pc-sample/code-block/display-acate))
+
+ (set! pc-sample/interp-proc/display (generate:pc-sample/table/displayer
+ pc-sample/interp-proc/display-acate))
+
+ (set! pc-sample/prob-comp/display (generate:pc-sample/table/displayer
+ pc-sample/prob-comp/display-acate))
+
+ (set! pc-sample/UFO/display (generate:pc-sample/table/displayer
+ pc-sample/UFO/display-acate))
+ )
+\f
+;; Display-acaters (i.e., make a widget presentable for human readable display)
+;; All display-acaters are presently *not* integrable so we
+;; can interavtively play with them to explore display options.
+
+(define *display-acation-status* #F) ; FLUID optional arg
+
+(define (with-pc-sample-displayacation-status displayacation-status thunk)
+ (fluid-let ((*display-acation-status* displayacation-status))
+ (thunk)))
+
+(define (pc-sample/builtin/display-acate)
+ (pc-sample/indexed-vector-table/display-acate
+ pc-sample/status/builtin-table
+ pc-sample/builtin-table
+ "Built-Ins"
+ 'BUILTIN
+ 'BUILTIN-FNORD!
+ get-builtin-name))
+
+(define (pc-sample/utility/display-acate)
+ (pc-sample/indexed-vector-table/display-acate
+ pc-sample/status/utility-table
+ pc-sample/utility-table
+ "Utilities"
+ 'UTILITY
+ 'UTILITY-FNORD!
+ get-utility-name))
+
+(define (pc-sample/primitive/display-acate)
+ (pc-sample/indexed-vector-table/display-acate
+ pc-sample/status/primitive-table
+ pc-sample/primitive-table
+ "Primitives"
+ 'PRIMITIVE
+ 'PRIMITIVE-FNORD!
+ get-primitive-name))
+
+(define (pc-sample/indexed-vector-table/display-acate
+ pc-sample/status/mumble-table
+ pc-sample/mumble-table
+ mumble-string
+ mumble-ID
+ mumble-ID-fnord!
+ get-mumble-name)
+ (cond ((if *display-acation-status*
+ (pc-sample/status/mumble-table *display-acation-status*)
+ (pc-sample/mumble-table))
+ =>
+ (lambda (mumble-tbl)
+ (let ((count-acc 0.)
+ (disp-stack '()))
+ (do ((index (-1+ (vector-length mumble-tbl)) (-1+ index)))
+ ((negative? index)
+ (if (null? disp-stack)
+ (string-append
+ "; ++++ No " mumble-string "s Sampled Yet ++++")
+ `(,mumble-ID-fnord!
+ ,count-acc
+ ,@(sort-sample-list disp-stack))))
+ (let ((count (vector-ref mumble-tbl index)))
+ (cond ((not (flo:zero? count))
+ (set! count-acc (flo:+ count count-acc))
+ (set! disp-stack
+ `((,count
+ ,mumble-ID ,index ,(get-mumble-name index))
+ . ,disp-stack)))))))))
+ (else
+ (string-append "; **** [" mumble-string " Table Uninitialized]."))))
+
+(define (pc-sample/code-block/display-acate)
+ (let ((BTW-string
+ (string-append
+ "\n"
+ ";..............................................................\n"
+ "; BTW: Code Block Buffer Status --\n"
+ "; "
+ "((plen . pslk)"
+ " (hlen . hslk))\n"
+ "; = "
+ (write-to-string
+ (if *display-acation-status*
+ (pc-sample/status/code-block-buffer/status
+ *display-acation-status*)
+ (pc-sample/code-block-buffer/status))))))
+ (if (code-block-profiling-disabled?)
+ (no-code-blocks-of-sort "" BTW-string #F)
+ (let* ((purified-count-cell (make-cell 0.))
+ ( heathen-count-cell (make-cell 0.))
+ (display-acated-p&h-lists
+ (map (lambda (table label cable) ; 8 tables: 4 purified + 4 not
+ (vector->list
+ (vector-map table
+ (lambda (elt)
+ (let* ((coblx (profile-hash-table-car elt))
+ (datum (profile-hash-table-cdr elt))
+ (count
+ (code-block-profile-datum/count datum))
+ (name-list
+ (code-block/name/display-acate coblx)))
+ (set-cell-contents! cable
+ (flo:+ count
+ (cell-contents cable)))
+ `(,count ,label ,coblx ,@name-list))))))
+ (vector->list
+ (if *display-acation-status*
+ (pc-sample/status/code-block-table
+ *display-acation-status*)
+ (pc-sample/code-block-table)))
+ '((CODE-BLOCK PURIFIED COM-PROC)
+ (CODE-BLOCK PURIFIED DBG-INFO)
+ (CODE-BLOCK PURIFIED RAW-COBL)
+ (CODE-BLOCK PURIFIED TRAMPOLINE)
+ (CODE-BLOCK HEATHEN COM-PROC)
+ (CODE-BLOCK HEATHEN DBG-INFO)
+ (CODE-BLOCK HEATHEN RAW-COBL)
+ (CODE-BLOCK HEATHEN TRAMPOLINE)
+ )
+ `(,purified-count-cell ,purified-count-cell
+ ,purified-count-cell ,purified-count-cell
+ ,heathen-count-cell ,heathen-count-cell
+ ,heathen-count-cell ,heathen-count-cell
+ )
+ ))
+ (display-acated-purified-list
+ `(,@(first display-acated-p&h-lists)
+ ,@(second display-acated-p&h-lists)
+ ,@(third display-acated-p&h-lists)
+ ,@(fourth display-acated-p&h-lists)
+ ))
+ (display-acated-heathen-list
+ `(,@(fifth display-acated-p&h-lists)
+ ,@(sixth display-acated-p&h-lists)
+ ,@(seventh display-acated-p&h-lists)
+ ,@(eighth display-acated-p&h-lists)
+ )))
+ (cond ((and (null? display-acated-purified-list)
+ (null? display-acated-heathen-list))
+ (no-code-blocks-of-sort "" BTW-string #F))
+ ((null? display-acated-heathen-list)
+ `#((PURIFIED-FNORD!
+ ,(cell-contents purified-count-cell)
+ ,@(sort-sample-list display-acated-purified-list))
+ ,(no-code-blocks-of-sort "Heathen" BTW-string 'BTW)))
+ ((null? display-acated-purified-list)
+ `#((HEATHEN-FNORD!
+ ,(cell-contents heathen-count-cell)
+ ,@(sort-sample-list display-acated-heathen-list))
+ ,(no-code-blocks-of-sort "Purified" BTW-string 'BTW)))
+ (else
+ `#(#((PURIFIED-FNORD!
+ ,(cell-contents purified-count-cell)
+ ,@(sort-sample-list display-acated-purified-list))
+ (HEATHEN-FNORD!
+ ,(cell-contents heathen-count-cell)
+ ,@(sort-sample-list display-acated-heathen-list)))
+ ,BTW-string)))))))
+
+(define (compiled-entry-pointer? object) ; should live in /scheme/src/runtime/udata.scm
+ (and (compiled-code-address? object)
+ (eq? (compiled-entry-type object) 'COMPILED-ENTRY)))
+
+(define (compiled-procedure-entry? obj) ; should live in /scheme/src/runtime/udata.scm
+ (and (compiled-code-address? obj)
+ (or (compiled-procedure? obj)
+ (compiled-return-address? obj)
+ (compiled-entry-pointer? obj))))
+
+(define *announce-trampoline-sightings?* #F)
+
+(define (code-block/name/display-acate coblx) ; not integrable so can frob it
+ (with-values
+ (lambda ()
+ (cond ((compiled-code-block? coblx)
+ (if (compiled-code-block/trampoline? coblx)
+ (if (trampoline/return-to-interpreter? coblx)
+ (values 'RETURN_TO_INTERPRETER 69)
+ (values 'ABNORMAL_COMPILED_CODE_BLOCK 42))
+ (compiled-code-block/filename-and-index coblx)))
+ ((compiled-code-address? coblx)
+ (compiled-entry/filename-and-index coblx))
+ (else
+ (values '<--- '<debugging-info>))))
+ (lambda (filename offset)
+ `(,(cond ((compiled-procedure-entry? coblx)
+ (lambda/name/display-acate (compiled-procedure/lambda coblx)))
+ ((compiled-code-block/trampoline? coblx)
+ (cond (*announce-trampoline-sightings?*
+ (newline)
+ (newline)
+ (display ";;;; ========== TRAMPOLINE ========== ")(display filename)
+ (newline)
+ (newline)))
+ '-*-TRAMPOLINE-*-)
+ (else ; compiled-expr [loading], debugging-info, compclo
+ (unsyntax/truthfully/sublist 5 (if (compiled-expression? coblx)
+ (compiled-expression/scode coblx)
+ coblx))))
+ ,(if (null? filename)
+ "[Not file-defined (i.e., interactively defined?)]"
+ filename)
+ ,(if (and (null? filename) (null? offset))
+ 235
+ offset
+ )))))
+
+(define-integrable (no-code-blocks-of-sort ID-string BTW-string BTW?)
+ (string-append
+ (if BTW? "\n" "")
+ (if (string-null? ID-string)
+ (if (code-block-profiling-disabled?)
+ "; **** [Code Block Profile Buffers Uninitialized]."
+ "; +++ No Code Blocks Sampled Yet +++")
+ (string-append
+ ";~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n"
+ "; +++ No " ID-string " Code Blocks Sampled Yet +++"))
+ BTW-string))
+
+
+
+(define (pc-sample/purified-trampoline/display-acate)
+ (pc-sample/trampoline/display-acate 'PURIFIED 'PURIFIED-FNORD! "Purified" 0))
+
+(define (pc-sample/heathen-trampoline/display-acate)
+ (pc-sample/trampoline/display-acate 'HEATHEN 'HEATHEN-FNORD! "Heathen" 1))
+
+(define-integrable (pc-sample/trampoline/display-acate ID ID-fnord! ID-string
+ pure/heathen-index)
+ ;; Straightforwardly derived from full code-block display-ication...
+ (let ((complete-code-block-display-acation
+ (pc-sample/code-block/display-acate)))
+ (cond ((string? complete-code-block-display-acation)
+ (no-trampolines-of-sort ID-string))
+ ((vector? complete-code-block-display-acation)
+ (let* ((samples (vector-ref complete-code-block-display-acation 0))
+ (tramps
+ (cond ((vector? samples) ; #(tagged-pures tagged-heathens)
+ (filter-sorted-sample-list-by-label
+ `(CODE-BLOCK ,ID TRAMPOLINE)
+ (cddr (vector-ref samples pure/heathen-index))))
+ ;; Invariant: samples is tagged pair
+ ((eq? (car samples) ID-fnord!)
+ (filter-sorted-sample-list-by-label
+ `(CODE-BLOCK ,ID TRAMPOLINE)
+ (cddr samples)))
+ (else '())))
+ (tramp-tally (reduce (lambda (elt so-far) ; tally # samples
+ (flo:+ so-far (second elt)))
+ 0.
+ tramps)))
+ (if (null? tramps)
+ (no-trampolines-of-sort ID-string)
+ `(,ID-fnord! ,tramp-tally ,@tramps))))
+ (else
+ (error "Unrecognized format from PC-SAMPLE/CODE-BLOCK/DISPLAY-ACATE"
+ complete-code-block-display-acation)))))
+
+(define-integrable (filter-sorted-sample-list-by-label label sorted-sample-list)
+ (list-transform-positive sorted-sample-list
+ (lambda (elt)
+ (equal? (second elt) label)))) ; (# label ...)
+
+(define-integrable (no-trampolines-of-sort ID-string)
+ (string-append
+ ";~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n"
+ "; +++ No " ID-string " Trampolines Sampled Yet +++\n"
+ ))
+
+
+(define (pc-sample/interp-proc/display-acate)
+ (let ((BTW-string
+ (string-append
+ "\n"
+ ";..............................................................\n"
+ "; BTW: Interp-Proc Buffer Status (length . slack) = "
+ (write-to-string
+ (if *display-acation-status*
+ (pc-sample/status/interp-proc-buffer/status
+ *display-acation-status*)
+ (pc-sample/interp-proc-buffer/status))))))
+ (if (interp-proc-profiling-disabled?)
+ (string-append "; **** [Interp-Proc Profile Buffers Uninitialized]."
+ BTW-string)
+ (let* ((tally 0.)
+ (display-acated-list
+ (vector->list
+ (vector-map
+ (if *display-acation-status*
+ (pc-sample/status/interp-proc-table
+ *display-acation-status*)
+ (pc-sample/interp-proc-table))
+ (lambda (elt)
+ (let* ((lambx (profile-hash-table-car elt))
+ (datum (profile-hash-table-cdr elt))
+ (count (interp-proc-profile-datum/count datum))
+ (name (lambda/name/display-acate lambx)))
+ (set! tally (flo:+ count tally))
+ `(,count INTERP-PROC ,lambx ,name)))))))
+ (if (null? display-acated-list)
+ (string-append "; +++ No Interp-Procs Sampled Yet +++"
+ BTW-string)
+ `#((INTERP-PROC-FNORD! ,tally
+ ,@(sort-sample-list display-acated-list))
+ ,BTW-string))))))
+
+(define (lambda/name/display-acate lambx) ; not integrable so can play w/ it
+ (if (meaningfully-named-lambda? lambx)
+ (lambda-components* lambx
+ (lambda (name required optional rest body)
+ body ; ignore
+ `(,name
+ ,@required
+ ,@(if (null? optional) '() `(#!OPTIONAL ,@optional))
+ . ,(if rest rest '()))))
+ (unsyntax/truthfully/sublist 5 lambx)))
+
+(define (unsyntax/truthfully/sublist lngth scode)
+ (let ((lst (unsyntax/truthfully scode)))
+ (if (not lst)
+ '(-?-)
+ (sublist lst 0 (-1+ (min lngth (length lst)))))))
+
+(define (unsyntax/truthfully scode)
+ (let ((un-env (->environment '(runtime unsyntaxer))))
+ (fluid-let (((access unsyntaxer:macroize? un-env) false)
+ ((access unsyntaxer:show-comments? un-env) false))
+ (unsyntax scode))))
+
+
+
+(define (meaningfully-named-lambda? x) ; not integrated so can play w/ it
+ (and (lambda? x)
+ (not (nonmeaningful-lambda-name? (lambda-name x)))))
+
+(define *nonmeaningful-procedure-names* ; exported for FLUID-LET-itude
+ (list 'LOOP 'DO-LOOP 'ITER 'RECUR 'WALK 'SCAN 'TRAVERSE 'ACCUMULATE 'ACC
+ 'FOO 'BAR 'BAZ 'QUUX 'FOOBAR
+ 'SNAFU 'FROB 'FROBNITZ 'FROBNICATE
+ 'MUMBLE 'GRUMBLE 'FUMBLE 'TUMBLE
+ 'F 'G 'H 'J 'K
+ 'FNORD 'FNORD! 'IGNORE 'PUNT
+ ))
+
+(define (nonmeaningful-lambda-name? raw-name) ; not integrated so can frob
+ (or (uninterned-symbol? raw-name)
+ (special-form-procedure-name? raw-name)
+ (memq raw-name *nonmeaningful-procedure-names*)))
+
+
+(define (pc-sample/prob-comp/display-acate)
+ (trivial-ate-table
+ (if *display-acation-status*
+ (pc-sample/status/prob-comp-table *display-acation-status*)
+ (pc-sample/prob-comp-table))
+ '(PROB-COMP PURIFIED)
+ '(PROB-COMP HEATHEN)
+ 'PROB-COMP-FNORD!
+ "Probably Compiled FNORD!"
+ "; **** [Prob Comp FNORD! Counters Uninitialized]."))
+
+(define (pc-sample/UFO/display-acate)
+ (trivial-ate-table
+ (if *display-acation-status*
+ (pc-sample/status/UFO-table *display-acation-status*)
+ (pc-sample/UFO-table))
+ '(UFO HYPERSPACE)
+ '(UFO CYBERSPACE)
+ 'UFO-FNORD!
+ "UFO"
+ (string-append "; **** [UFO Sightings Uninitialized] "
+ "(Project Blue Book Cancelled?).")))
+
+(define (trivial-ate-table count-vector type-0 type-1 widget-ID-fnord!
+ widget-ID-string
+ uninit-string)
+ (if count-vector
+ (let* ((count-0 (vector-ref count-vector 0))
+ (count-1 (vector-ref count-vector 1))
+ (no-0s? (flo:zero? count-0))
+ (no-1s? (flo:zero? count-1)))
+ (if (and no-0s?
+ no-1s?)
+ (string-append "; +++ No " widget-ID-string "s Sampled Yet +++")
+ (let ((tally (flo:+ count-0 count-1))
+ (display-acated-list
+ (cond (no-0s? `((,count-1 ,type-1)))
+ (no-1s? `((,count-0 ,type-0)))
+ (else `((,count-0 ,type-0)
+ (,count-1 ,type-1))))))
+ `(,widget-ID-fnord! ,tally
+ ,@(sort-sample-list display-acated-list)))))
+ uninit-string))
+
+(declare (integrate-operator trivial-ate-table))
+
+(define-integrable (sort-sample-list sample-list)
+ (sort sample-list ; sample-list := ((flonum ...)...)
+ (lambda (sample1 sample2)
+ (flo:> (car sample1)
+ (car sample2)))))
+\f
+;;; Tabulations
+
+(define (pc-sample/status/table . display-acaters)
+ ;; defaulted optional rest args
+ (let* ((real-display-acaters
+ (if (null? display-acaters) ; no opt rest arg
+ (list pc-sample/builtin/display-acate
+ pc-sample/utility/display-acate
+ pc-sample/primitive/display-acate
+ pc-sample/code-block/display-acate
+ pc-sample/interp-proc/display-acate
+ pc-sample/prob-comp/display-acate
+ pc-sample/UFO/display-acate)
+ display-acaters))
+ ;; Lie: should store sample interval in the table some how. Sigh.
+ (sample-interval (pc-sample/sample-interval))
+ (tally 0.)
+ ;; Do (apply append (map (.\ (dcr-thunk) ...) real-dcrs))
+ (display-acatees
+ (map (lambda (dcr-thunk)
+ (let* ((raw-display-acatee (dcr-thunk))
+ (half-baked-display-acatee
+ (cond ((string? raw-display-acatee)
+ '(FNORD! 0.))
+ ((vector? raw-display-acatee)
+ ;; spec., #(sample-list BTW-string)
+ (vector-ref raw-display-acatee 0))
+ (else raw-display-acatee ))))
+ ;; Cook half-baked display-acatee
+ (cond ((pair? half-baked-display-acatee)
+ (set! tally
+ (+ (second half-baked-display-acatee) tally))
+ (cddr half-baked-display-acatee)) ; de-fnord-ize
+ ((vector? half-baked-display-acatee)
+ ;; e.g., #((purified...)(heathen...))
+ ;; Do (apply append (map cdr lst))
+ (cddr (reduce-right
+ (lambda (l r)
+ (let ((l-count (second l))
+ (r-count (second r)))
+ (set! tally
+ (flo:+ (flo:+ l-count
+ r-count) ; Grrr
+ tally))
+ `(FNORD! 0. ,@(cddr l) ,@(cddr r))))
+ '(FNORD!-TO-CDR-IF-NULL-HALF-BAKED-DISPEES)
+ (vector->list half-baked-display-acatee))))
+ (else
+ (error "Unknown display-acatee format"
+ half-baked-display-acatee)))))
+ real-display-acaters))
+ (merged-status (reduce-right append '() display-acatees)) ; flatten
+ (sorted-status (sort-sample-list merged-status))
+ (percent-sorted-status
+ (map (lambda (ntry)
+ `(,(percenticate (car ntry) tally)
+ ,(relevanticate (car ntry) tally sample-interval)
+ ,@ntry))
+ sorted-status)))
+#|
+ ;; Reality check...
+ ;; Do: (apply + (map car lst))... reality check...
+ (let ((total-count (car (reduce (lambda (stat tacc)
+ `(,(flo:+ (car stat) (car tacc))))
+ '(0.)
+ sorted-status))))
+ (cond ((not (flo:= total-count tally))
+ (warn "; Damned total-count != tally. Foo." total-count tally))))
+|#
+ (display-sample-list percent-sorted-status)))
+
+
+(define *pc-sample/status/table/decimal-pump* 100000.) ; want 5 decimal places
+
+(define-integrable (percenticate numer denom)
+ ;; Standard hack: pump up the numerator, round it, then deflate result.
+ (let ((pumped-percentage
+ (flo:/ (flo:* (flo:* numer 100.) ; percent-icate
+ *pc-sample/status/table/decimal-pump*) ; decimal pump
+ denom)))
+ (flo:/ (flo:round pumped-percentage)
+ *pc-sample/status/table/decimal-pump*)))
+
+(define-integrable (relevanticate numer denom interval)
+ `#(,numer ,denom ,(make-rectangular (/ (flo:round->exact numer)
+ (flo:round->exact denom))
+ interval)))
+
+
+(define-integrable (pc-sample/builtin/status/table)
+ (pc-sample/status/table pc-sample/builtin/display-acate))
+
+(define-integrable (pc-sample/utility/status/table)
+ (pc-sample/status/table pc-sample/utility/display-acate))
+
+(define-integrable (pc-sample/primitive/status/table)
+ (pc-sample/status/table pc-sample/primitive/display-acate))
+
+(define-integrable (pc-sample/code-block/status/table)
+ (pc-sample/status/table pc-sample/code-block/display-acate))
+
+(define-integrable (pc-sample/interp-proc/status/table)
+ (pc-sample/status/table pc-sample/interp-proc/display-acate))
+
+(define-integrable (pc-sample/prob-comp/status/table)
+ (pc-sample/status/table pc-sample/prob-comp/display-acate))
+
+(define-integrable (pc-sample/UFO/status/table)
+ (pc-sample/status/table pc-sample/UFO/display-acate))
+
+
+(define-integrable (pc-sample/purified-trampoline/status/table)
+ (pc-sample/status/table pc-sample/purified-trampoline/display-acate))
+
+(define-integrable (pc-sample/heathen-trampoline/status/table)
+ (pc-sample/status/table pc-sample/heathen-trampoline/display-acate))
+
+
+;;; Default status displayer
+
+(define *pc-sample/default-status-displayer*)
+
+(define (with-pc-sample-default-status-displayer status-displayer thunk)
+ (fluid-let ((*pc-sample/default-status-displayer* status-displayer)) (thunk)))
+
+(define (install-default-status-displayer)
+ (set! *pc-sample/default-status-displayer* pc-sample/status/table)
+ )
+
+;;; Install
+
+(define (install)
+ (install-displayers) ; NB: Must load this before status-disp
+ (install-status-displayers)
+ (install-default-status-displayer)
+ )
+
+;;; fini
--- /dev/null
+/* -*-C-*-
+
+$Id: pcsdld.c,v 1.1 1995/07/28 14:14:08 adams Exp $
+
+Copyright (c) 1990-1993 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+/* PCSDLD.C -- defines the PC Sample dynamic load interface to Scheme */
+\f
+/*!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*\
+ * TODO:
+ * Get a real job. Find a wife, CONS up some progeny. Write a will. Croak.
+ *
+\*!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*/
+\f
+/*****************************************************************************
+ * Uhm... don't forget to pay the piper... must define prims first so known.
+ *****************************************************************************/
+
+#ifndef REALLY_INCLUDE_PROFILE_CODE /* scan_defines concession */
+#define REALLY_INCLUDE_PROFILE_CODE /* scan_defines concession */
+#endif
+
+#include "pcsample.c" /* The PC sampler microcode */
+
+/*****************************************************************************/
+#include <microcode/usrdef.h> /* For declare_primitive */
+
+extern void EXFUN (initialize_pcsample_primitives, (void));
+ void
+DEFUN_VOID (initialize_pcsample_primitives)
+{
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("PC-SAMPLE/TIMER-CLEAR",
+ Prim_pc_sample_timer_clear, 0, 0,
+ "()\n\
+ Turn off the PC sample timer.\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("PC-SAMPLE/TIMER-SET",
+ Prim_pc_sample_timer_set, 2, 2,
+ "(first interval)\n\
+ Set the PC sample timer.\n\
+ First arg FIRST says how long to wait until the first interrupt;\n\
+ second arg INTERVAL says how long to wait between interrupts after that.\n\
+ Both arguments are in units of milliseconds.\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("%PC-SAMPLE/HALTED?",
+ Prim_pc_sample_halted_p, 0, 0,
+ "()\n\
+ Specifies whether PC sampling has been brute forcably disabled.\n\
+ \n\
+ Only officially designated wizards should even think of using this\n\
+ super secret primitive. FNORD!\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("%PC-SAMPLE/HALTED?/TOGGLE!",
+ Prim_pc_sample_halted_p_toggle_bang, 0, 0,
+ "()\n\
+ Toggles the Boolean sense of whether PC sampling is brute forcably disabled.\n\
+ \n\
+ It returns the newly installed sense of the flag.\n\
+ \n\
+ -------\n\
+ WARNING! If pc-sample/init has not been called (to initialize profiling\n\
+ ------- tables) then you will lose big if you naively toggle halted-flag\n\
+ to #F because that will start the profile timer.\n\
+ \n\
+ Only officially designated moby wizards should even think of thinking of\n\
+ using this most ultra super duper secret primitive. FNORD!\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("%PC-SAMPLE/CACHE-GC-PRIMITIVE-INDEX",
+ Prim_pc_sample_cache_GC_primitive_index, 0, 0,
+ "()\n\
+ Signals the microcode to go find the GARBAGE-COLLECT primitive and cache\n\
+ away its index into the Primitive Table.\n\
+ \n\
+ This should be invoked each time the Primitive Table is altered in such a\n\
+ way that existing primitives can shift about.\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("PC-SAMPLE/SPILL-GC-SAMPLES-INTO-PRIMITIVE-TABLE",
+ Prim_pc_sample_spill_GC_samples_into_primitive_table, 0, 0,
+ "()\n\
+ Make sure all samples taken during GC are present and accounted for in the\n\
+ Primitive Sample Table.\
+ ");
+\f
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("%PC-SAMPLE/INSTALL-GC-SYNCH-GC-HOOKS",
+ Prim_pc_sample_install_gc_synch_gc_hooks, 0, 0,
+ "()\n\
+ This must be called once when PC sampling is enabled.\n\
+ \n\
+ If it returns #F then PC sampling must be disabled. You.lose\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("%PC-SAMPLE/INSTALL-MICROCODE",
+ Prim_pc_sample_install_microcode, 0, 0,
+ "()\n\
+ Installs the microcode support structures for PC sampling.\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("%PC-SAMPLE/DISABLE-MICROCODE",
+ Prim_pc_sample_disable_microcode, 0, 0,
+ "()\n\
+ Disables the microcode support structures for PC sampling.\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("INTERP-PROC-PROFILE-BUFFER/DISABLE",
+ Prim_IPPB_disable, 0, 0,
+ "()\n\
+ Disables the interpreted procedure profile buffer hence disabling profiling\n\
+ of interpreted procedures (unless and until a new buffer is installed).\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("INTERP-PROC-PROFILE-BUFFER/INSTALL",
+ Prim_IPPB_install, 1, 1,
+ "(vector)\n\
+ Installs VECTOR as the interpreted procedure profile buffer.\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("INTERP-PROC-PROFILE-BUFFER/SLACK",
+ Prim_IPPB_slack, 0, 0,
+ "()\n\
+ Returns the `slack' by which the near-fullness of the interpreted procedure\n\
+ profile buffer is determined and by which increment the buffer is extended\n\
+ when full.\n\
+ \n\
+ Note that the slack will always be a positive fixnum.\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("INTERP-PROC-PROFILE-BUFFER/SET-SLACK",
+ Prim_IPPB_set_slack, 1, 1,
+ "(positive-fixnum)\n\
+ Sets the `slack' by which the near-fullness of the interpreted procedure\n\
+ profile buffer is determined and by which increment the buffer is extended\n\
+ when full.\n\
+ \n\
+ Note that the slack must be a positive fixnum.\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("INTERP-PROC-PROFILE-BUFFER/SLACK-INCREMENT",
+ Prim_IPPB_slack_increment, 0, 0,
+ "()\n\
+ Returns the amount by which the interpreted procedure profile buffer slack\n\
+ is incremented when a buffer overflow occurs. In this sense it cuts the\n\
+ slack some slack.\n\
+ \n\
+ Note that the slack increment will always be a fixnum, but it can be negative\n\
+ (in which case it functions as a slack decrement).\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("INTERP-PROC-PROFILE-BUFFER/SET-SLACK-INCREMENT",
+ Prim_IPPB_set_slack_increment, 1, 1,
+ "(fixnum)\n\
+ Sets the amount by which the interpreted procedure profile buffer slack is\n\
+ incremented when a buffer overflow occurs.\n\
+ \n\
+ Note that the slack increment must be a fixnum, but it can be negative\n\
+ (in which case it functions as a slack decrement).\
+ ");
+\f
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("INTERP-PROC-PROFILE-BUFFER/EXTEND-NOISY?",
+ Prim_IPPB_extend_noisy_p, 0, 0,
+ "()\n\
+ Specifies whether notification of IPPB extensions is enabled.\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("INTERP-PROC-PROFILE-BUFFER/FLUSH-NOISY?",
+ Prim_IPPB_flush_noisy_p, 0, 0,
+ "()\n\
+ Specifies whether notification of IPPB extensions is enabled.\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("INTERP-PROC-PROFILE-BUFFER/OVERFLOW-NOISY?",
+ Prim_IPPB_overflow_noisy_p, 0, 0,
+ "()\n\
+ Specifies whether notification of IPPB overflows is enabled.\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("INTERP-PROC-PROFILE-BUFFER/EXTEND-NOISY?/TOGGLE!",
+ Prim_IPPB_extend_noisy_p_toggle_bang, 0, 0,
+ "()\n\
+ Toggles the Boolean sense of whether to notify of IPPB extensions.\n\
+ \n\
+ It returns the newly installed sense of the flag.\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("INTERP-PROC-PROFILE-BUFFER/FLUSH-NOISY?/TOGGLE!",
+ Prim_IPPB_flush_noisy_p_toggle_bang, 0, 0,
+ "()\n\
+ Toggles the Boolean sense of whether to notify of IPPB flushes.\n\
+ \n\
+ It returns the newly installed sense of the flag.\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("INTERP-PROC-PROFILE-BUFFER/OVERFLOW-NOISY?/TOGGLE!",
+ Prim_IPPB_overflow_noisy_p_toggle_bang, 0, 0,
+ "()\n\
+ Toggles the Boolean sense of whether to notify of IPPB overflows.\n\
+ \n\
+ It returns the newly installed sense of the flag.\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("INTERP-PROC-PROFILE-BUFFER/EMPTY?",
+ Prim_IPPB_empty_p, 0, 0,
+ "()\n\
+ Returns a boolean indicating whether or not the IPPB is empty.\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("INTERP-PROC-PROFILE-BUFFER/NEXT-EMPTY-SLOT-INDEX",
+ Prim_IPPB_next_empty_slot_index, 0, 0,
+ "()\n\
+ Returns the index of the next `free' slot of the interp-proc profile buffer.\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("%INTERP-PROC-PROFILE-BUFFER/NEXT-EMPTY-SLOT-INDEX/RESET",
+ Prim_IPPB_next_empty_slot_index_reset, 0, 0,
+ "()\n\
+ Resets the index of the next `free' slot of the interp-proc profile buffer.\
+ \n\
+ Only officially designated wizards should even think of using this\n\
+ super secret primitive. FNORD!\
+ ");
+\f
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("%PC-SAMPLE/IPPB-FLUSH-IMMEDIATE?",
+ Prim_pc_sample_IPPB_flush_immediate_p, 0, 0,
+ "()\n\
+ Specifies whether the IPPB is flushed upon each entry.\n\
+ \n\
+ Only officially designated wizards should even think of using this\n\
+ super secret primitive. FNORD!\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("%PC-SAMPLE/IPPB-FLUSH-IMMEDIATE?/TOGGLE!",
+ Prim_pc_sample_IPPB_flush_immediate_p_toggle_bang, 0, 0,
+ "()\n\
+ Toggles the Boolean sense of whether the IPPBuffer is flushed upon each entry.\n\
+ \n\
+ It returns the newly installed sense of the flag.\n\
+ \n\
+ This is for mondo bizarro sampler debugging purposes only.\n\
+ \n\
+ Only officially designated moby wizards should even think of thinking of\n\
+ using this most ultra super duper secret primitive. FNORD!\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("%PC-SAMPLE/IPPB-DEBUGGING?",
+ Prim_pc_sample_IPPB_debugging_p, 0, 0,
+ "()\n\
+ Specifies whether the IPPB is in debugging mode.\n\
+ \n\
+ Only officially designated wizards should even think of using this\n\
+ super secret primitive. FNORD!\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("%PC-SAMPLE/IPPB-DEBUGGING?/TOGGLE!",
+ Prim_pc_sample_IPPB_debugging_p_toggle_bang, 0, 0,
+ "()\n\
+ Toggles the Boolean sense of whether the IPPBuffer is in debugging mode.\n\
+ \n\
+ It returns the newly installed sense of the flag.\n\
+ \n\
+ This is for mondo bizarro sampler debugging purposes only.\n\
+ \n\
+ Only officially designated moby wizards should even think of thinking of\n\
+ using this most ultra super duper secret primitive. FNORD!\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("%PC-SAMPLE/IPPB-MONITORING?",
+ Prim_pc_sample_IPPB_monitoring_p, 0, 0,
+ "()\n\
+ Specifies whether the IPPB is in monitoring mode.\n\
+ \n\
+ This, for instance, is how a count of buffer overflows is accumulated.\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("%PC-SAMPLE/IPPB-MONITORING?/TOGGLE!",
+ Prim_pc_sample_IPPB_monitoring_p_toggle_bang, 0, 0,
+ "()\n\
+ Toggles the Boolean sense of whether the IPPB is in monitoring mode.\n\
+ \n\
+ It returns the newly installed sense of the flag.\n\
+ \n\
+ This is for mondo bizarro sampler monitoring purposes only.\n\
+ For instance, toggling this monitor flag to true triggers accumulating\n\
+ a count of buffer overflows.\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("%PC-SAMPLE/IPPB-FLUSH-COUNT",
+ Prim_pc_sample_IPPB_flush_count, 0, 0,
+ "()\n\
+ Returns the number of IPPB flush requests that have been issued since the\n\
+ last PC-SAMPLE/IPPB-FLUSH-COUNT/RESET was issued (or since booting if no\n\
+ resets issued).\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("%PC-SAMPLE/IPPB-FLUSH-COUNT/RESET",
+ Prim_pc_sample_IPPB_flush_count_reset, 0, 0,
+ "()\n\
+ Resets the IPPB flush count (obviously... sheesh!).\
+ ");
+\f
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("%PC-SAMPLE/IPPB-EXTEND-COUNT",
+ Prim_pc_sample_IPPB_extend_count, 0, 0,
+ "()\n\
+ Returns the number of IPPB extend requests that have been issued since the\n\
+ last PC-SAMPLE/IPPB-EXTEND-COUNT/RESET was issued (or since booting if no\n\
+ resets issued).\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("%PC-SAMPLE/IPPB-EXTEND-COUNT/RESET",
+ Prim_pc_sample_IPPB_extend_count_reset, 0, 0,
+ "()\n\
+ Resets the IPPB extend count (obviously... sheesh!).\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("%PC-SAMPLE/IPPB-OVERFLOW-COUNT",
+ Prim_pc_sample_IPPB_overflow_count, 0, 0,
+ "()\n\
+ Returns the number of IPPB overflows that have been issued since the\n\
+ last PC-SAMPLE/IPPB-OVERFLOW-COUNT/RESET was issued (or since booting if no\n\
+ resets issued).\n\
+ \n\
+ Each overflow indicates a sample that was punted into the bit bucket.\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("%PC-SAMPLE/IPPB-OVERFLOW-COUNT/RESET",
+ Prim_pc_sample_IPPB_overflow_count_reset, 0, 0,
+ "()\n\
+ Resets the IPPB overflow count (obviously... sheesh!).\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("%PC-SAMPLE/IPPB-EXTRA-INFO",
+ Prim_pc_sample_IPPB_extra_info, 0, 0,
+ "()\n\
+ Returns the extra info entry associated with the IPP Buffer.\n\
+ \n\
+ Only officially designated wizards should even think of using this\n\
+ super secret primitive. FNORD!\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("%PC-SAMPLE/SET-IPPB-EXTRA-INFO!",
+ Prim_pc_sample_set_IPPB_extra_info_bang, 1, 1,
+ "(object)\n\
+ Stores OBJECT in the extra info entry of the IPPB.\n\
+ \n\
+ This is for mondo bizarro sampler frobnication purposes only.\n\
+ \n\
+ Only officially designated moby wizards should even think of thinking of\n\
+ using this most ultra super duper secret primitive. FNORD!\
+ ");
+ /*-------------------------------------------------------------------------*/
+\f
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("PURIFIED-CODE-BLOCK-PROFILE-BUFFERS/DISABLE",
+ Prim_PCBPB_disable, 0, 0,
+ "()\n\
+ Disables the purified code block profile buffers hence disabling purified\n\
+ code block profiling (unless and until new buffers are installed).\
+ ");
+ /*.........................................................................*/
+ declare_primitive ( "HEATHEN-CODE-BLOCK-PROFILE-BUFFERS/DISABLE",
+ Prim_HCBPB_disable, 0, 0,
+ "()\n\
+ Disables the heathen code block profile buffers hence disabling heathen\n\
+ code block profiling (unless and until new buffers are installed).\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("PURIFIED-CODE-BLOCK-PROFILE-BUFFERS/INSTALL",
+ Prim_PCBPB_install, 2, 2,
+ "(block-vector offset-vector)\n\
+ Installs BLOCK-VECTOR and OFFSET-VECTOR as the purified code block profile\n\
+ buffers.\
+ ");
+ /*.........................................................................*/
+ declare_primitive ( "HEATHEN-CODE-BLOCK-PROFILE-BUFFERS/INSTALL",
+ Prim_HCBPB_install, 2, 2,
+ "(block-vector offset-vector)\n\
+ Installs BLOCK-VECTOR and OFFSET-VECTOR as the heathen code block profile\n\
+ buffers.\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/SLACK",
+ Prim_PCBPB_slack, 0, 0,
+ "()\n\
+ Returns the `slack' by which the near-fullness of the profile buffer for\n\
+ purified code blocks is determined and by which increment the buffer is\n\
+ extended when full.\
+ ");
+ /*.........................................................................*/
+ declare_primitive ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/SLACK",
+ Prim_HCBPB_slack, 0, 0,
+ "()\n\
+ Returns the `slack' by which the near-fullness of the profile buffer for\n\
+ heathen (i.e., non-purified) code blocks is determined and by which\n\
+ increment the buffer is extended when full.\
+ ");
+\f
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/SET-SLACK",
+ Prim_PCBPB_set_slack, 1, 1,
+ "(positive-fixnum)\n\
+ Sets the `slack' by which the near-fullness of the PCBPB is determined and\n\
+ by which increment the buffer is extended when full.\n\
+ \n\
+ Note that the slack must be a positive fixnum.\
+ ");
+ /*.........................................................................*/
+ declare_primitive ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/SET-SLACK",
+ Prim_HCBPB_set_slack, 1, 1,
+ "(positive-fixnum)\n\
+ Sets the `slack' by which the near-fullness of the HCBPB is determined and\n\
+ by which increment the buffer is extended when full.\n\
+ \n\
+ Note that the slack must be a positive fixnum.\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/SLACK-INCREMENT",
+ Prim_PCBPB_slack_increment, 0, 0,
+ "()\n\
+ Returns the amount by which the PCBPB slack is incremented when a buffer\n\
+ overflow occurs. In this sense it cuts the slack more slack.\n\
+ \n\
+ Note that the slack increment will always be a fixnum, but it can be negative\n\
+ (in which case it functions as a slack decrement).\
+ ");
+ /*.........................................................................*/
+ declare_primitive ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/SLACK-INCREMENT",
+ Prim_HCBPB_slack_increment, 0, 0,
+ "()\n\
+ Returns the amount by which the HCBPB slack is incremented when a buffer\n\
+ overflow occurs. In this sense it cuts the slack more slack.\n\
+ \n\
+ Note that the slack increment will always be a fixnum, but it can be negative\n\
+ (in which case it functions as a slack decrement).\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/SET-SLACK-INCREMENT",
+ Prim_PCBPB_set_slack_increment, 1, 1,
+ "(fixnum)\n\
+ Sets the amount by which the PCBPB slack is incremented when a buffer\n\
+ overflow occurs.\n\
+ \n\
+ Note that the slack increment must be a fixnum, but it can be negative\n\
+ (in which case it functions as a slack decrement).\
+ ");
+ /*.........................................................................*/
+ declare_primitive ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/SET-SLACK-INCREMENT",
+ Prim_HCBPB_set_slack_increment, 1, 1,
+ "(fixnum)\n\
+ Sets the amount by which the HCBPB slack is incremented when a buffer\n\
+ overflow occurs.\n\
+ \n\
+ Note that the slack increment must be a fixnum, but it can be negative\n\
+ (in which case it functions as a slack decrement).\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/EXTEND-NOISY?",
+ Prim_PCBPB_extend_noisy_p, 0, 0,
+ "()\n\
+ Specifies whether notification of PCBPB buffer extensions is enabled.\
+ ");
+ /*.........................................................................*/
+ declare_primitive ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/EXTEND-NOISY?",
+ Prim_HCBPB_extend_noisy_p, 0, 0,
+ "()\n\
+ Specifies whether notification of HCBPB buffer extensions is enabled.\
+ ");
+\f
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/FLUSH-NOISY?",
+ Prim_PCBPB_flush_noisy_p, 0, 0,
+ "()\n\
+ Specifies whether notification of PCBPB buffer extensions is enabled.\
+ ");
+ /*.........................................................................*/
+ declare_primitive ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/FLUSH-NOISY?",
+ Prim_HCBPB_flush_noisy_p, 0, 0,
+ "()\n\
+ Specifies whether notification of HCBPB buffer extensions is enabled.\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/OVERFLOW-NOISY?",
+ Prim_PCBPB_overflow_noisy_p, 0, 0,
+ "()\n\
+ Specifies whether notification of PCBPB buffer extensions is enabled.\
+ ");
+ /*.........................................................................*/
+ declare_primitive ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/OVERFLOW-NOISY?",
+ Prim_HCBPB_overflow_noisy_p, 0, 0,
+ "()\n\
+ Specifies whether notification of HCBPB buffer extensions is enabled.\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/EXTEND-NOISY?/TOGGLE!",
+ Prim_PCBPB_extend_noisy_p_toggle_bang, 0, 0,
+ "()\n\
+ Toggles the Boolean sense of whether to notify of PCBPB buffer extensions.\n\
+ \n\
+ It returns the newly installed sense of the flag.\
+ ");
+ /*.........................................................................*/
+ declare_primitive ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/EXTEND-NOISY?/TOGGLE!",
+ Prim_HCBPB_extend_noisy_p_toggle_bang, 0, 0,
+ "()\n\
+ Toggles the Boolean sense of whether to notify of HCBPB buffer extensions.\n\
+ \n\
+ It returns the newly installed sense of the flag.\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/FLUSH-NOISY?/TOGGLE!",
+ Prim_PCBPB_flush_noisy_p_toggle_bang, 0, 0,
+ "()\n\
+ Toggles the Boolean sense of whether to notify of PCBPB buffer flushes.\n\
+ \n\
+ It returns the newly installed sense of the flag.\
+ ");
+ /*.........................................................................*/
+ declare_primitive ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/FLUSH-NOISY?/TOGGLE!",
+ Prim_HCBPB_flush_noisy_p_toggle_bang, 0, 0,
+ "()\n\
+ Toggles the Boolean sense of whether to notify of HCBPB buffer flushes.\n\
+ \n\
+ It returns the newly installed sense of the flag.\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/OVERFLOW-NOISY?/TOGGLE!",
+ Prim_PCBPB_overflow_noisy_p_toggle_bang, 0, 0,
+ "()\n\
+ Toggles the Boolean sense of whether to notify of PCBPB buffer overflowes.\n\
+ \n\
+ It returns the newly installed sense of the flag.\
+ ");
+ /*.........................................................................*/
+ declare_primitive ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/OVERFLOW-NOISY?/TOGGLE!",
+ Prim_HCBPB_overflow_noisy_p_toggle_bang, 0, 0,
+ "()\n\
+ Toggles the Boolean sense of whether to notify of HCBPB buffer overflowes.\n\
+ \n\
+ It returns the newly installed sense of the flag.\
+ ");
+\f
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/EMPTY?",
+ Prim_PCBPB_empty_p, 0, 0,
+ "()\n\
+ Returns a boolean indicating whether or not the profile buffer for\n\
+ purified code blocks is empty.\
+ ");
+ /*.........................................................................*/
+ declare_primitive ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/EMPTY?",
+ Prim_HCBPB_empty_p, 0, 0,
+ "()\n\
+ Returns a boolean indicating whether or not the profile buffer for\n\
+ heathen (i.e., unpurified) code blocks is empty.\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/NEXT-EMPTY-SLOT-INDEX",
+ Prim_PCBPB_next_empty_slot_index, 0, 0,
+ "()\n\
+ Returns the index of the next `free' slot of the profile buffer for\n\
+ purified code blocks.\
+ ");
+ /*.........................................................................*/
+ declare_primitive ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/NEXT-EMPTY-SLOT-INDEX",
+ Prim_HCBPB_next_empty_slot_index, 0, 0,
+ "()\n\
+ Returns the index of the next `free' slot of the profile buffer for\n\
+ heathen (i.e., unpurified) code blocks.\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("%PURIFIED-CODE-BLOCK-PROFILE-BUFFER/NEXT-EMPTY-SLOT-INDEX/RESET",
+ Prim_PCBPB_next_empty_slot_index_reset, 0, 0,
+ "()\n\
+ Resets the index of the next `free' slot of the profile buffer for\n\
+ purified code blocks.\
+ \n\
+ Only officially designated wizards should even think of using this\n\
+ super secret primitive. FNORD!\
+ ");
+ /*.........................................................................*/
+ declare_primitive ("%HEATHEN-CODE-BLOCK-PROFILE-BUFFER/NEXT-EMPTY-SLOT-INDEX/RESET",
+ Prim_HCBPB_next_empty_slot_index_reset, 0, 0,
+ "()\n\
+ Resets the index of the next `free' slot of the profile buffer for\n\
+ heathen (i.e., unpurified) code blocks.\
+ \n\
+ Only officially designated wizards should even think of using this\n\
+ super secret primitive. FNORD!\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("%PC-SAMPLE/PCBPB-FLUSH-IMMEDIATE?",
+ Prim_pc_sample_PCBPB_flush_immediate_p, 0, 0,
+ "()\n\
+ Specifies whether the Purified Code Block Profile Buffer is flushed upon\n\
+ each entry.\n\
+ \n\
+ Only officially designated wizards should even think of using this\n\
+ super secret primitive. FNORD!\
+ ");
+ /*.........................................................................*/
+ declare_primitive ("%PC-SAMPLE/HCBPB-FLUSH-IMMEDIATE?",
+ Prim_pc_sample_HCBPB_flush_immediate_p, 0, 0,
+ "()\n\
+ Specifies whether the Heathen Code Block Profile Buffer is flushed upon\n\
+ each entry.\n\
+ \n\
+ Only officially designated wizards should even think of using this\n\
+ super secret primitive. FNORD!\
+ ");
+\f
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("%PC-SAMPLE/PCBPB-FLUSH-IMMEDIATE?/TOGGLE!",
+ Prim_pc_sample_PCBPB_flush_immediate_p_toggle_bang, 0, 0,
+ "()\n\
+ Toggles the Boolean sense of whether the Purified Code Block Profile Buffer\n\
+ is flushed upon each entry.\n\
+ \n\
+ It returns the newly installed sense of the flag.\n\
+ \n\
+ This is for mondo bizarro sampler debugging purposes only.\n\
+ \n\
+ Only officially designated moby wizards should even think of thinking of\n\
+ using this most ultra super duper secret primitive. FNORD!\
+ ");
+ /*.........................................................................*/
+ declare_primitive ("%PC-SAMPLE/HCBPB-FLUSH-IMMEDIATE?/TOGGLE!",
+ Prim_pc_sample_HCBPB_flush_immediate_p_toggle_bang, 0, 0,
+ "()\n\
+ Toggles the Boolean sense of whether the Heathen Code Block Profile Buffer\n\
+ is flushed upon each entry.\n\
+ \n\
+ It returns the newly installed sense of the flag.\n\
+ \n\
+ This is for mondo bizarro sampler debugging purposes only.\n\
+ \n\
+ Only officially designated moby wizards should even think of thinking of\n\
+ using this most ultra super duper secret primitive. FNORD!\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("%PC-SAMPLE/PCBPB-DEBUGGING?",
+ Prim_pc_sample_PCBPB_debugging_p, 0, 0,
+ "()\n\
+ Specifies whether the Purified Code Block Profile Buffer is in debugging mode.\n\
+ \n\
+ Only officially designated wizards should even think of using this\n\
+ super secret primitive. FNORD!\
+ ");
+ /*.........................................................................*/
+ declare_primitive ("%PC-SAMPLE/HCBPB-DEBUGGING?",
+ Prim_pc_sample_HCBPB_debugging_p, 0, 0,
+ "()\n\
+ Specifies whether the Heathen Code Block Profile Buffer is in debugging mode.\n\
+ \n\
+ Only officially designated wizards should even think of using this\n\
+ super secret primitive. FNORD!\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("%PC-SAMPLE/PCBPB-DEBUGGING?/TOGGLE!",
+ Prim_pc_sample_PCBPB_debugging_p_toggle_bang, 0, 0,
+ "()\n\
+ Toggles the Boolean sense of whether the Purified Code Block Profile Buffer\n\
+ is in debugging mode.\n\
+ \n\
+ It returns the newly installed sense of the flag.\n\
+ \n\
+ This is for mondo bizarro sampler debugging purposes only.\n\
+ \n\
+ Only officially designated moby wizards should even think of thinking of\n\
+ using this most ultra super duper secret primitive. FNORD!\
+ ");
+ /*.........................................................................*/
+ declare_primitive ("%PC-SAMPLE/HCBPB-DEBUGGING?/TOGGLE!",
+ Prim_pc_sample_HCBPB_debugging_p_toggle_bang, 0, 0,
+ "()\n\
+ Toggles the Boolean sense of whether the Heathen Code Block Profile Buffer\n\
+ is in debugging mode.\n\
+ \n\
+ It returns the newly installed sense of the flag.\n\
+ \n\
+ This is for mondo bizarro sampler debugging purposes only.\n\
+ \n\
+ Only officially designated moby wizards should even think of thinking of\n\
+ using this most ultra super duper secret primitive. FNORD!\
+ ");
+\f
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("%PC-SAMPLE/PCBPB-MONITORING?",
+ Prim_pc_sample_PCBPB_monitoring_p, 0, 0,
+ "()\n\
+ Specifies whether the PCBPB is in monitoring mode.\n\
+ \n\
+ This, for instance, is how a count of buffer overflows is accumulated.\
+ ");
+ /*.........................................................................*/
+ declare_primitive ("%PC-SAMPLE/HCBPB-MONITORING?",
+ Prim_pc_sample_HCBPB_monitoring_p, 0, 0,
+ "()\n\
+ Specifies whether the HCBPB is in monitoring mode.\n\
+ \n\
+ This, for instance, is how a count of buffer overflows is accumulated.\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("%PC-SAMPLE/PCBPB-MONITORING?/TOGGLE!",
+ Prim_pc_sample_PCBPB_monitoring_p_toggle_bang, 0, 0,
+ "()\n\
+ Toggles the Boolean sense of whether the Purified Code Block Profile Buffer\n\
+ is in monitoring mode.\n\
+ \n\
+ It returns the newly installed sense of the flag.\n\
+ \n\
+ This is for mondo bizarro sampler monitoring purposes only.\n\
+ For instance, toggling this monitor flag to true triggers accumulating\n\
+ a count of buffer overflows.\
+ ");
+ /*.........................................................................*/
+ declare_primitive ("%PC-SAMPLE/HCBPB-MONITORING?/TOGGLE!",
+ Prim_pc_sample_HCBPB_monitoring_p_toggle_bang, 0, 0,
+ "()\n\
+ Toggles the Boolean sense of whether the Heathen Code Block Profile Buffer\n\
+ is in monitoring mode.\n\
+ \n\
+ It returns the newly installed sense of the flag.\n\
+ \n\
+ This is for mondo bizarro sampler monitoring purposes only.\n\
+ For instance, toggling this monitor flag to true triggers accumulating\n\
+ a count of buffer overflows.\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("%PC-SAMPLE/PCBPB-FLUSH-COUNT",
+ Prim_pc_sample_PCBPB_flush_count, 0, 0,
+ "()\n\
+ Returns the number of PCBPB flush requests that have been issued since the\n\
+ last PC-SAMPLE/PCBPB-FLUSH-COUNT/RESET was issued (or since booting if no\n\
+ resets issued).\
+ ");
+ /*.........................................................................*/
+ declare_primitive ("%PC-SAMPLE/HCBPB-FLUSH-COUNT",
+ Prim_pc_sample_HCBPB_flush_count, 0, 0,
+ "()\n\
+ Returns the number of HCBPB flush requests that have been issued since the\n\
+ last PC-SAMPLE/HCBPB-FLUSH-COUNT/RESET was issued (or since booting if no\n\
+ resets issued).\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("%PC-SAMPLE/PCBPB-FLUSH-COUNT/RESET",
+ Prim_pc_sample_PCBPB_flush_count_reset, 0, 0,
+ "()\n\
+ Resets the PCBPB flush count (obviously... sheesh!).\
+ ");
+ /*.........................................................................*/
+ declare_primitive ("%PC-SAMPLE/HCBPB-FLUSH-COUNT/RESET",
+ Prim_pc_sample_HCBPB_flush_count_reset, 0, 0,
+ "()\n\
+ Resets the HCBPB flush count (obviously... sheesh!).\
+ ");
+\f
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("%PC-SAMPLE/PCBPB-EXTEND-COUNT",
+ Prim_pc_sample_PCBPB_extend_count, 0, 0,
+ "()\n\
+ Returns the number of PCBPB extend requests that have been issued since the\n\
+ last PC-SAMPLE/PCBPB-EXTEND-COUNT/RESET was issued (or since booting if no\n\
+ resets issued).\
+ ");
+ /*.........................................................................*/
+ declare_primitive ("%PC-SAMPLE/HCBPB-EXTEND-COUNT",
+ Prim_pc_sample_HCBPB_extend_count, 0, 0,
+ "()\n\
+ Returns the number of HCBPB extend requests that have been issued since the\n\
+ last PC-SAMPLE/HCBPB-EXTEND-COUNT/RESET was issued (or since booting if no\n\
+ resets issued).\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("%PC-SAMPLE/PCBPB-EXTEND-COUNT/RESET",
+ Prim_pc_sample_PCBPB_extend_count_reset, 0, 0,
+ "()\n\
+ Resets the PCBPB extend count (obviously... sheesh!).\
+ ");
+ /*.........................................................................*/
+ declare_primitive ("%PC-SAMPLE/HCBPB-EXTEND-COUNT/RESET",
+ Prim_pc_sample_HCBPB_extend_count_reset, 0, 0,
+ "()\n\
+ Resets the HCBPB extend count (obviously... sheesh!).\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("%PC-SAMPLE/PCBPB-OVERFLOW-COUNT",
+ Prim_pc_sample_PCBPB_overflow_count, 0, 0,
+ "()\n\
+ Returns the number of PCBPB overflows that have been issued since the last\n\
+ PC-SAMPLE/PCBPB-OVERFLOW-COUNT/RESET was issued (or since booting if no\n\
+ resets issued).\n\
+ \n\
+ Each overflow indicates a sample that was punted into the bit bucket.\
+ ");
+ /*.........................................................................*/
+ declare_primitive ("%PC-SAMPLE/HCBPB-OVERFLOW-COUNT",
+ Prim_pc_sample_HCBPB_overflow_count, 0, 0,
+ "()\n\
+ Returns the number of HCBPB overflows that have been issued since the last\n\
+ PC-SAMPLE/HCBPB-OVERFLOW-COUNT/RESET was issued (or since booting if no\n\
+ resets issued).\n\
+ \n\
+ Each overflow indicates a sample that was punted into the bit bucket.\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("%PC-SAMPLE/PCBPB-OVERFLOW-COUNT/RESET",
+ Prim_pc_sample_PCBPB_overflow_count_reset, 0, 0,
+ "()\n\
+ Resets the PCBPB overflow count (obviously... sheesh!).\
+ ");
+ /*.........................................................................*/
+ declare_primitive ("%PC-SAMPLE/HCBPB-OVERFLOW-COUNT/RESET",
+ Prim_pc_sample_HCBPB_overflow_count_reset, 0, 0,
+ "()\n\
+ Resets the HCBPB overflow count (obviously... sheesh!).\
+ ");
+\f
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("%PC-SAMPLE/PCBPB-EXTRA-INFO",
+ Prim_pc_sample_PCBPB_extra_info, 0, 0,
+ "()\n\
+ Returns the extra info entry associated with the Purified Code Block\n\
+ Profile Buffer.\n\
+ \n\
+ Only officially designated wizards should even think of using this\n\
+ super secret primitive. FNORD!\
+ ");
+ /*.........................................................................*/
+ declare_primitive ("%PC-SAMPLE/HCBPB-EXTRA-INFO",
+ Prim_pc_sample_HCBPB_extra_info, 0, 0,
+ "()\n\
+ Returns the extra info entry associated with the Heathen Code Block\n\
+ Profile Buffer.\n\
+ \n\
+ Only officially designated wizards should even think of using this\n\
+ super secret primitive. FNORD!\
+ ");
+ /*-------------------------------------------------------------------------*/
+ declare_primitive ("%PC-SAMPLE/SET-PCBPB-EXTRA-INFO!",
+ Prim_pc_sample_set_PCBPB_extra_info, 1, 1,
+ "(object)\n\
+ Stores OBJECT in the extra info entry of the Purified Code Block\n\
+ Profile Buffer.\n\
+ \n\
+ This is for mondo bizarro sampler frobnication purposes only.\n\
+ \n\
+ Only officially designated moby wizards should even think of thinking of\n\
+ using this most ultra super duper secret primitive. FNORD!\
+ ");
+ /*.........................................................................*/
+ declare_primitive ("%PC-SAMPLE/SET-HCBPB-EXTRA-INFO!",
+ Prim_pc_sample_set_HCBPB_extra_info, 1, 1,
+ "(object)\n\
+ Stores OBJECT in the extra info entry of the Heathen Code Block\n\
+ Profile Buffer.\n\
+ \n\
+ This is for mondo bizarro sampler frobnication purposes only.\n\
+ \n\
+ Only officially designated moby wizards should even think of thinking of\n\
+ using this most ultra super duper secret primitive. FNORD!\
+ ");
+ /*-------------------------------------------------------------------------*/
+}
+
+
+
+
+
+
+/* fini */
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: pcsintrp.scm,v 1.1 1995/07/28 14:14:08 adams Exp $
+
+Copyright (c) 1988-1993 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; PC Sample Interrupt System
+;;; package: (pc-sample interrupt-handler)
+
+(declare (usual-integrations))
+\f
+(define (initialize-package!)
+ (install))
+
+(define-primitives
+ (clear-interrupts! 1)
+ set-fixed-objects-vector!
+ )
+
+;; Slots 0--8 are reserved by the system (for GC and overflow et al)
+
+(define-integrable IPPB-flush-slot 9) ; pc-sample
+(define-integrable IPPB-extend-slot 10) ; pc-sample
+(define-integrable PCBPB-flush-slot 11) ; pc-sample
+(define-integrable PCBPB-extend-slot 12) ; pc-sample
+(define-integrable HCBPB-flush-slot 13) ; pc-sample
+(define-integrable HCBPB-extend-slot 14) ; pc-sample
+
+;; Slot 15 is the dreaded illegal-interrupt-slot
+
+
+;;;; Miscellaneous PC Sample Interrupts: buffer flush and extend requests
+
+(define (IPPB-flush-request-handler interrupt-code interrupt-enables)
+ interrupt-code interrupt-enables
+ (interp-proc-profile-buffer/flush)
+ (clear-interrupts! interrupt-bit/IPPB-flush))
+
+(define (IPPB-extend-interrupt-handler interrupt-code interrupt-enables)
+ interrupt-code interrupt-enables
+ (interp-proc-profile-buffer/extend)
+ (clear-interrupts! interrupt-bit/IPPB-extend))
+
+(define (PCBPB-flush-request-handler interrupt-code interrupt-enables)
+ interrupt-code interrupt-enables
+ (purified-code-block-profile-buffer/flush)
+ (clear-interrupts! interrupt-bit/PCBPB-flush))
+
+(define (PCBPB-extend-interrupt-handler interrupt-code interrupt-enables)
+ interrupt-code interrupt-enables
+ (purified-code-block-profile-buffer/extend)
+ (clear-interrupts! interrupt-bit/PCBPB-extend))
+
+(define (HCBPB-flush-request-handler interrupt-code interrupt-enables)
+ interrupt-code interrupt-enables
+ (heathen-code-block-profile-buffer/flush)
+ (clear-interrupts! interrupt-bit/HCBPB-flush))
+
+(define (HCBPB-extend-interrupt-handler interrupt-code interrupt-enables)
+ interrupt-code interrupt-enables
+ (heathen-code-block-profile-buffer/extend)
+ (clear-interrupts! interrupt-bit/HCBPB-extend))
+\f
+;;;; Keyboard Interrupts
+
+(define (install)
+ (without-interrupts
+ (lambda ()
+ (let ((system-interrupt-vector
+ (vector-ref (get-fixed-objects-vector) index:interrupt-vector))
+ (interrupt-mask-vector
+ (vector-ref (get-fixed-objects-vector)
+ index:interrupt-mask-vector)))
+
+ (vector-set! system-interrupt-vector IPPB-flush-slot ; pc-sample
+ IPPB-flush-request-handler)
+ (vector-set! interrupt-mask-vector IPPB-flush-slot ; pc-sample
+ interrupt-mask/gc-ok)
+
+ (vector-set! system-interrupt-vector IPPB-extend-slot ; pc-sample
+ IPPB-extend-interrupt-handler)
+ (vector-set! interrupt-mask-vector IPPB-extend-slot ; pc-sample
+ interrupt-mask/gc-ok)
+
+ (vector-set! system-interrupt-vector PCBPB-flush-slot ; pc-sample
+ PCBPB-flush-request-handler)
+ (vector-set! interrupt-mask-vector PCBPB-flush-slot ; pc-sample
+ interrupt-mask/gc-ok)
+
+ (vector-set! system-interrupt-vector PCBPB-extend-slot ; pc-sample
+ PCBPB-extend-interrupt-handler)
+ (vector-set! interrupt-mask-vector PCBPB-extend-slot ; pc-sample
+ interrupt-mask/gc-ok)
+
+ (vector-set! system-interrupt-vector HCBPB-flush-slot ; pc-sample
+ HCBPB-flush-request-handler)
+ (vector-set! interrupt-mask-vector HCBPB-flush-slot ; pc-sample
+ interrupt-mask/gc-ok)
+
+ (vector-set! system-interrupt-vector HCBPB-extend-slot ; pc-sample
+ HCBPB-extend-interrupt-handler)
+ (vector-set! interrupt-mask-vector HCBPB-extend-slot ; pc-sample
+ interrupt-mask/gc-ok)
+
+ #|
+ ;; Nop
+ (set-fixed-objects-vector! (get-fixed-objects-vector))
+ |#
+ ))))
+
+;;; fini
--- /dev/null
+/* -*-C-*-
+
+$Id: pcsiproc.c,v 1.1 1995/07/28 14:14:08 adams Exp $
+
+Copyright (c) 1990-1995 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+/* PCSIPROC.C -- defines PC Sample subroutines for profiling interp-procs *\
+\* (a.k.a. interpreted procedures) within pcsample.c */
+
+/*****************************************************************************/
+#ifdef REALLY_INCLUDE_PROFILE_CODE /* scan_defines concession */
+
+#include <microcode/lookup.h> /* For AUX_LIST_TYPE */
+\f
+/*!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*\
+ * TODO:
+ *
+ * - Maybe flatten number of primitives?
+ *
+\*!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*/
+\f
+/*===========================================================================*\
+ * Interp-Proc Profile Buffer is for buffering sightings of interpreted procs *
+ * (a.k.a. compounds) until they can be spilled into the Interp-Proc Profile *
+ * Table. *
+ * *
+ * This hairy mess is to reduce the overhead of passing interpreted procs up *
+ * to Scheme (where they can be entered into a hash table)... only once the *
+ * buffer is nearly filled does an interrupt get generated to spill the buffer*
+ * contents into the profile hashtable. *
+\*===========================================================================*/
+
+/*****************************************************************************
+ * Interp-Proc Profile Buffer consists of a vector of slots and a handfull of
+ * state variables...
+ */
+
+static struct profile_buffer_state interp_proc_profile_buffer_state;
+
+static void
+DEFUN_VOID (init_IPPB_profile_buffer_state)
+{
+ init_profile_uni_buffer_state (&interp_proc_profile_buffer_state,
+ " IPPB", /* name */
+ PC_Sample_Interp_Proc_Buffer, /* ID */
+ 8*128, /* slack */
+ 128, /* slack_inc */
+ INT_IPPB_Flush, /* flush_INT */
+ INT_IPPB_Extend /* extnd_INT */
+ );
+}
+
+/* convenient shorthand for use in primitives below... */
+
+#define IPPB_name \
+ (interp_proc_profile_buffer_state . name)
+#define IPPB_ID \
+ (interp_proc_profile_buffer_state . ID)
+#define IPPB_enabled \
+ (interp_proc_profile_buffer_state . enabled_flag)
+#define IPPB_buffer \
+ (interp_proc_profile_buffer_state . buffer)
+#define IPPB_length \
+ (interp_proc_profile_buffer_state . length)
+#define IPPB_next_empty_slot_index \
+ (interp_proc_profile_buffer_state . next_empty_slot_index)
+#define IPPB_slack \
+ (interp_proc_profile_buffer_state . slack)
+#define IPPB_slack_increment \
+ (interp_proc_profile_buffer_state . slack_increment)
+#define IPPB_flush_INT \
+ (interp_proc_profile_buffer_state . flush_INT)
+#define IPPB_extend_INT \
+ (interp_proc_profile_buffer_state . extend_INT)
+#define IPPB_flush_noisy \
+ (interp_proc_profile_buffer_state . flush_noisy_flag)
+#define IPPB_extend_noisy \
+ (interp_proc_profile_buffer_state . extend_noisy_flag)
+#define IPPB_overflow_noisy \
+ (interp_proc_profile_buffer_state . overflow_noisy_flag)
+#define IPPB_flush_immediate \
+ (interp_proc_profile_buffer_state . flush_immed_flag)
+#define IPPB_debugging \
+ (interp_proc_profile_buffer_state . debug_flag)
+#define IPPB_monitoring \
+ (interp_proc_profile_buffer_state . monitor_flag)
+#define IPPB_flush_count \
+ (interp_proc_profile_buffer_state . flush_count)
+#define IPPB_extend_count \
+ (interp_proc_profile_buffer_state . extend_count)
+#define IPPB_overflow_count \
+ (interp_proc_profile_buffer_state . overflow_count)
+#define IPPB_extra_info \
+ (interp_proc_profile_buffer_state . extra_buffer_state_info)
+\f
+/*---------------------------------------------------------------------------*/
+#define IPPB_disable() do \
+{ \
+ Set_Fixed_Obj_Slot (PC_Sample_Interp_Proc_Buffer, SHARP_F ) ; \
+ IPPB_buffer = SHARP_F ; \
+ IPPB_enabled = false ; \
+ IPPB_next_empty_slot_index = 0 ; \
+ IPPB_length = 0 ; /* Paranoia */\
+} while (FALSE)
+/*...........................................................................*/
+DEFINE_PRIMITIVE ("INTERP-PROC-PROFILE-BUFFER/DISABLE",
+ Prim_IPPB_disable, 0, 0,
+ "()\n\
+ Disables the interpreted procedure profile buffer hence disabling profiling\n\
+ of interpreted procedures (unless and until a new buffer is installed).\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ IPPB_disable ();
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+/*---------------------------------------------------------------------------*/
+#define IPPB_install(buffer_arg) do \
+{ \
+ Set_Fixed_Obj_Slot (PC_Sample_Interp_Proc_Buffer, buffer_arg ) ; \
+ IPPB_buffer = buffer_arg ; \
+ IPPB_enabled = true ; \
+ IPPB_length = (VECTOR_LENGTH (buffer_arg)) ; \
+ /* NB: Do NOT reset next_empty_slot_index since may be extending */ \
+} while (FALSE)
+/*...........................................................................*/
+DEFINE_PRIMITIVE ("INTERP-PROC-PROFILE-BUFFER/INSTALL",
+ Prim_IPPB_install, 1, 1,
+ "(vector)\n\
+ Installs VECTOR as the interpreted procedure profile buffer.\
+ ")
+{
+ PRIMITIVE_HEADER(1);
+ CHECK_ARG(1, VECTOR_P);
+ IPPB_install (ARG_REF (1));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+/*---------------------------------------------------------------------------*/
+/*---------------------------------------------------------------------------*/
+static void
+DEFUN_VOID(resynch_IPPB_post_gc_hook)
+{
+ if IPPB_enabled
+ IPPB_install (Get_Fixed_Obj_Slot (PC_Sample_Interp_Proc_Buffer)) ;
+}
+/*---------------------------------------------------------------------------*/
+/*---------------------------------------------------------------------------*/
+\f
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("INTERP-PROC-PROFILE-BUFFER/SLACK", Prim_IPPB_slack, 0, 0,
+ "()\n\
+ Returns the `slack' by which the near-fullness of the interpreted procedure\n\
+ profile buffer is determined and by which increment the buffer is extended\n\
+ when full.\n\
+ \n\
+ Note that the slack will always be a positive fixnum.\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PRIMITIVE_RETURN (ulong_to_integer (IPPB_slack));
+}
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("INTERP-PROC-PROFILE-BUFFER/SET-SLACK",
+ Prim_IPPB_set_slack, 1, 1,
+ "(positive-fixnum)\n\
+ Sets the `slack' by which the near-fullness of the interpreted procedure\n\
+ profile buffer is determined and by which increment the buffer is extended\n\
+ when full.\n\
+ \n\
+ Note that the slack must be a positive fixnum.\
+ ")
+{
+ PRIMITIVE_HEADER(1);
+ CHECK_ARG (1, FIXNUM_POSITIVE_P);
+ IPPB_slack = (integer_to_ulong (ARG_REF (1)));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("INTERP-PROC-PROFILE-BUFFER/SLACK-INCREMENT",
+ Prim_IPPB_slack_increment, 0, 0,
+ "()\n\
+ Returns the amount by which the interpreted procedure profile buffer slack\n\
+ is incremented when a buffer overflow occurs. In this sense it cuts the\n\
+ slack some slack.\n\
+ \n\
+ Note that the slack increment will always be a fixnum, but it can be negative\n\
+ (in which case it functions as a slack decrement).\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PRIMITIVE_RETURN (long_to_integer (IPPB_slack_increment));
+}
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("INTERP-PROC-PROFILE-BUFFER/SET-SLACK-INCREMENT",
+ Prim_IPPB_set_slack_increment, 1, 1,
+ "(fixnum)\n\
+ Sets the amount by which the interpreted procedure profile buffer slack is\n\
+ incremented when a buffer overflow occurs.\n\
+ \n\
+ Note that the slack increment must be a fixnum, but it can be negative\n\
+ (in which case it functions as a slack decrement).\
+ ")
+{
+ PRIMITIVE_HEADER(1);
+ CHECK_ARG (1, INTEGER_P);
+ IPPB_slack_increment = (integer_to_long (ARG_REF (1)));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+\f
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("INTERP-PROC-PROFILE-BUFFER/EXTEND-NOISY?",
+ Prim_IPPB_extend_noisy_p, 0, 0,
+ "()\n\
+ Specifies whether notification of IPPB extensions is enabled.\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (IPPB_extend_noisy)) ;
+}
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("INTERP-PROC-PROFILE-BUFFER/FLUSH-NOISY?",
+ Prim_IPPB_flush_noisy_p, 0, 0,
+ "()\n\
+ Specifies whether notification of IPPB extensions is enabled.\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (IPPB_flush_noisy)) ;
+}
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("INTERP-PROC-PROFILE-BUFFER/OVERFLOW-NOISY?",
+ Prim_IPPB_overflow_noisy_p, 0, 0,
+ "()\n\
+ Specifies whether notification of IPPB overflows is enabled.\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (IPPB_overflow_noisy)) ;
+}
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("INTERP-PROC-PROFILE-BUFFER/EXTEND-NOISY?/TOGGLE!",
+ Prim_IPPB_extend_noisy_p_toggle_bang, 0, 0,
+ "()\n\
+ Toggles the Boolean sense of whether to notify of IPPB extensions.\n\
+ \n\
+ It returns the newly installed sense of the flag.\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ IPPB_extend_noisy = (! (IPPB_extend_noisy)) ;
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (IPPB_extend_noisy)) ;
+}
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("INTERP-PROC-PROFILE-BUFFER/FLUSH-NOISY?/TOGGLE!",
+ Prim_IPPB_flush_noisy_p_toggle_bang, 0, 0,
+ "()\n\
+ Toggles the Boolean sense of whether to notify of IPPB flushes.\n\
+ \n\
+ It returns the newly installed sense of the flag.\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ IPPB_flush_noisy = (! (IPPB_flush_noisy)) ;
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (IPPB_flush_noisy)) ;
+}
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("INTERP-PROC-PROFILE-BUFFER/OVERFLOW-NOISY?/TOGGLE!",
+ Prim_IPPB_overflow_noisy_p_toggle_bang, 0, 0,
+ "()\n\
+ Toggles the Boolean sense of whether to notify of IPPB overflows.\n\
+ \n\
+ It returns the newly installed sense of the flag.\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ IPPB_overflow_noisy = (! (IPPB_overflow_noisy)) ;
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (IPPB_overflow_noisy)) ;
+}
+\f
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("INTERP-PROC-PROFILE-BUFFER/EMPTY?", Prim_IPPB_empty_p, 0, 0,
+ "()\n\
+ Returns a boolean indicating whether or not the IPPB is empty.\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PRIMITIVE_RETURN(BOOLEAN_TO_OBJECT (IPPB_next_empty_slot_index == 0)) ;
+}
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("INTERP-PROC-PROFILE-BUFFER/NEXT-EMPTY-SLOT-INDEX",
+ Prim_IPPB_next_empty_slot_index, 0, 0,
+ "()\n\
+ Returns the index of the next `free' slot of the interp-proc profile buffer.\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PRIMITIVE_RETURN(ulong_to_integer (IPPB_next_empty_slot_index));
+}
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("%INTERP-PROC-PROFILE-BUFFER/NEXT-EMPTY-SLOT-INDEX/RESET",
+ Prim_IPPB_next_empty_slot_index_reset, 0, 0,
+ "()\n\
+ Resets the index of the next `free' slot of the interp-proc profile buffer.\
+ \n\
+ Only officially designated wizards should even think of using this\n\
+ super secret primitive. FNORD!\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ IPPB_next_empty_slot_index = ((unsigned long) 0);
+ PRIMITIVE_RETURN(UNSPECIFIC);
+}
+\f
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("%PC-SAMPLE/IPPB-FLUSH-IMMEDIATE?",
+ Prim_pc_sample_IPPB_flush_immediate_p, 0, 0,
+ "()\n\
+ Specifies whether the IPPB is flushed upon each entry.\n\
+ \n\
+ Only officially designated wizards should even think of using this\n\
+ super secret primitive. FNORD!\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (IPPB_flush_immediate)) ;
+}
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("%PC-SAMPLE/IPPB-FLUSH-IMMEDIATE?/TOGGLE!",
+ Prim_pc_sample_IPPB_flush_immediate_p_toggle_bang, 0, 0,
+ "()\n\
+ Toggles the Boolean sense of whether the IPPBuffer is flushed upon each entry.\n\
+ \n\
+ It returns the newly installed sense of the flag.\n\
+ \n\
+ This is for mondo bizarro sampler debugging purposes only.\n\
+ \n\
+ Only officially designated moby wizards should even think of thinking of\n\
+ using this most ultra super duper secret primitive. FNORD!\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ IPPB_flush_immediate = (! (IPPB_flush_immediate)) ;
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (IPPB_flush_immediate)) ;
+}
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("%PC-SAMPLE/IPPB-DEBUGGING?",
+ Prim_pc_sample_IPPB_debugging_p, 0, 0,
+ "()\n\
+ Specifies whether the IPPB is in debugging mode.\n\
+ \n\
+ Only officially designated wizards should even think of using this\n\
+ super secret primitive. FNORD!\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (IPPB_debugging)) ;
+}
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("%PC-SAMPLE/IPPB-DEBUGGING?/TOGGLE!",
+ Prim_pc_sample_IPPB_debugging_p_toggle_bang, 0, 0,
+ "()\n\
+ Toggles the Boolean sense of whether the IPPBuffer is in debugging mode.\n\
+ \n\
+ It returns the newly installed sense of the flag.\n\
+ \n\
+ This is for mondo bizarro sampler debugging purposes only.\n\
+ \n\
+ Only officially designated moby wizards should even think of thinking of\n\
+ using this most ultra super duper secret primitive. FNORD!\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ IPPB_debugging = (! (IPPB_debugging)) ;
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (IPPB_debugging)) ;
+}
+\f
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("%PC-SAMPLE/IPPB-MONITORING?",
+ Prim_pc_sample_IPPB_monitoring_p, 0, 0,
+ "()\n\
+ Specifies whether the IPPB is in monitoring mode.\n\
+ \n\
+ This, for instance, is how a count of buffer overflows is accumulated.\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (IPPB_monitoring)) ;
+}
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("%PC-SAMPLE/IPPB-MONITORING?/TOGGLE!",
+ Prim_pc_sample_IPPB_monitoring_p_toggle_bang, 0, 0,
+ "()\n\
+ Toggles the Boolean sense of whether the IPPB is in monitoring mode.\n\
+ \n\
+ It returns the newly installed sense of the flag.\n\
+ \n\
+ This is for mondo bizarro sampler monitoring purposes only.\n\
+ For instance, toggling this monitor flag to true triggers accumulating\n\
+ a count of buffer overflows.\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ IPPB_monitoring = (! (IPPB_monitoring)) ;
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (IPPB_monitoring)) ;
+}
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("%PC-SAMPLE/IPPB-FLUSH-COUNT",
+ Prim_pc_sample_IPPB_flush_count, 0, 0,
+ "()\n\
+ Returns the number of IPPB flush requests that have been issued since the\n\
+ last PC-SAMPLE/IPPB-FLUSH-COUNT/RESET was issued (or since booting if no\n\
+ resets issued).\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PRIMITIVE_RETURN(ulong_to_integer (IPPB_flush_count));
+}
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("%PC-SAMPLE/IPPB-FLUSH-COUNT/RESET",
+ Prim_pc_sample_IPPB_flush_count_reset, 0, 0,
+ "()\n\
+ Resets the IPPB flush count (obviously... sheesh!).\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ IPPB_flush_count = ((unsigned long) 0);
+ PRIMITIVE_RETURN(UNSPECIFIC);
+}
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("%PC-SAMPLE/IPPB-EXTEND-COUNT",
+ Prim_pc_sample_IPPB_extend_count, 0, 0,
+ "()\n\
+ Returns the number of IPPB extend requests that have been issued since the\n\
+ last PC-SAMPLE/IPPB-EXTEND-COUNT/RESET was issued (or since booting if no\n\
+ resets issued).\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PRIMITIVE_RETURN(ulong_to_integer (IPPB_extend_count));
+}
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("%PC-SAMPLE/IPPB-EXTEND-COUNT/RESET",
+ Prim_pc_sample_IPPB_extend_count_reset, 0, 0,
+ "()\n\
+ Resets the IPPB extend count (obviously... sheesh!).\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ IPPB_extend_count = ((unsigned long) 0);
+ PRIMITIVE_RETURN(UNSPECIFIC);
+}
+\f
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("%PC-SAMPLE/IPPB-OVERFLOW-COUNT",
+ Prim_pc_sample_IPPB_overflow_count, 0, 0,
+ "()\n\
+ Returns the number of IPPB overflows that have been issued since the\n\
+ last PC-SAMPLE/IPPB-OVERFLOW-COUNT/RESET was issued (or since booting if no\n\
+ resets issued).\n\
+ \n\
+ Each overflow indicates a sample that was punted into the bit bucket.\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PRIMITIVE_RETURN(ulong_to_integer (IPPB_overflow_count));
+}
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("%PC-SAMPLE/IPPB-OVERFLOW-COUNT/RESET",
+ Prim_pc_sample_IPPB_overflow_count_reset, 0, 0,
+ "()\n\
+ Resets the IPPB overflow count (obviously... sheesh!).\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ IPPB_overflow_count = ((unsigned long) 0);
+ PRIMITIVE_RETURN(UNSPECIFIC);
+}
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("%PC-SAMPLE/IPPB-EXTRA-INFO",
+ Prim_pc_sample_IPPB_extra_info, 0, 0,
+ "()\n\
+ Returns the extra info entry associated with the IPP Buffer.\n\
+ \n\
+ Only officially designated wizards should even think of using this\n\
+ super secret primitive. FNORD!\
+ ")
+{
+ PRIMITIVE_HEADER(0);
+ PRIMITIVE_RETURN (IPPB_extra_info) ;
+}
+/*---------------------------------------------------------------------------*/
+DEFINE_PRIMITIVE ("%PC-SAMPLE/SET-IPPB-EXTRA-INFO!",
+ Prim_pc_sample_set_IPPB_extra_info_bang, 1, 1,
+ "(object)\n\
+ Stores OBJECT in the extra info entry of the IPPB.\n\
+ \n\
+ This is for mondo bizarro sampler frobnication purposes only.\n\
+ \n\
+ Only officially designated moby wizards should even think of thinking of\n\
+ using this most ultra super duper secret primitive. FNORD!\
+ ")
+{
+ PRIMITIVE_HEADER(1);
+ IPPB_extra_info = ARG_REF(1);
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+\f
+/*****************************************************************************
+ * kludgerous ``hidden arg'' passing mechanism
+ */
+
+static SCHEME_OBJECT pc_sample_current_env_frame = UNSPECIFIC ;
+
+/*****************************************************************************/
+static void
+DEFUN (pc_sample_record_interp_proc, (trinfo), struct trap_recovery_info * trinfo)
+{
+ /* GJR suggested nabbing the current ENV to find the current PROC,
+ * warning that the current ENV may be invalid, e.g. in the middle
+ * of a LOAD. Its validity will have been assured by the caller here.
+ *
+ * Since no real virtual PC is maintained in the interpreter, this ENV
+ * frobbing is our only means of mapping a SIGCONTEXT into some unique ID
+ * of the interp-proc being interpreted. Specifically, we recover the lambda
+ * lurking within the body of the procedure whose arguments gave rise to the
+ * current ENV frame.
+ *
+ * Oh, TRINFO arg is for cutesy diagnostics of Unidentifiable Function Objs.
+ */
+
+ SCHEME_OBJECT interp_proc_lambda ;
+ SCHEME_OBJECT the_procedure = (MEMORY_REF (pc_sample_current_env_frame,
+ ENVIRONMENT_FUNCTION));
+
+ /* Stutter step to make sure it really *is* a procedure object */
+
+ if ((OBJECT_TYPE (the_procedure)) == AUX_LIST_TYPE)
+ the_procedure = (MEMORY_REF (the_procedure, ENV_EXTENSION_PROCEDURE));
+
+ interp_proc_lambda = (MEMORY_REF (the_procedure, PROCEDURE_LAMBDA_EXPR ));
+
+ /* Hurumph... since the lambda may never have been hashed (and trap
+ * handlers are forbidden to do the CONSing necessary to generate new hash
+ * numbers), and since there is no microcode/scheme interface for hashing
+ * microcode objects (i.e., C data) anyway, we just pass the buck up to the
+ * interrupt handler mechanism: interrupt handlers are called at delicately
+ * perspicatious moments so they are permitted to CONS. This buck is passed
+ * by buffering lambdas until we have enough of them that it is worth
+ * issuing a request to spill the buffer into the lambda hashtable.
+ * For more details, see pcsiproc.scm in the runtime directory.
+ */
+
+ pc_sample_record_buffer_entry( interp_proc_lambda,
+ &interp_proc_profile_buffer_state);
+
+#if ( defined(PCS_LOG) /* Sample console logging */ \
+ || defined(PCS_LOG_INTERP_PROC) \
+ )
+ log_interp_proc_sample (trinfo) ;
+#endif
+
+}
+
+
+
+/*****************************************************************************/
+#endif /* REALLY_INCLUDE_PROFILE_CODE */
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/pcsample/pcsiproc.scm,v 1.1 1995/07/28 14:14:08 adams Exp $
+
+Copyright (c) 1993 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; PC Sampling Interp-Procs (i.e., interpreted procedure profiling)
+;;; package: (pc-sample interp-procs)
+
+(declare (usual-integrations))
+\f
+;;; Interp-Procs (interpreted procedures) are profiled by recording profiling
+;;; info about their associated procedure-lambdas. The reason the procedure
+;;; lambda is used rather than the full procedure object (lambda + environment)
+;;; is we want various dynamic activations of the same lambda to be identified.
+;;; Were we to hash off the procedure object rather than just its lambda, these
+;;; dynamic invocation instances would be distinguished since their associated
+;;; envs would (normally) be distinguishable.
+;;;
+;;; An interesting issue arises when considering generated procedures,
+;;; especially those such as would be generated by the canonical MAKE-COUNTER
+;;; proc below:
+;;;
+;;; (define (make-counter)
+;;; (let ((count -1))
+;;; (lambda (msg)
+;;; (case msg
+;;; ((NEXT) (set! count (1+ count)) count)
+;;; ((RESET) (set! count -1 ) count)
+;;; ))))
+;;;
+;;; (define a (make-counter))
+;;; (define b (make-counter))
+;;;
+;;; At the time of creation of this facility (1993.03.31.04.02.01), under such
+;;; an arrangement, the procedures A and B would share procedure lambdas so,
+;;; for purposes of profiling them while interpreted, they would be indistin-
+;;; guishable. To wit, time spent in either A or B would be attributed as time
+;;; spent in the ``A-or-B'' procedure.
+;;;
+;;; The obvious alternative is to profile interpreted procedures by their full
+;;; procedure object (lambda + environment). Under this approach, A and B
+;;; would indeed be distinguishable. Unfortunately, so too would any two
+;;; activations of the same procedure. This is clearly untenable for purposes
+;;; of collecting useable profiling information. ???
+
+(define (initialize-package!)
+ (set! *interp-proc-profile-table* (interp-proc-profile-table/make))
+ ;; microlevel buffer install
+ (install-interp-proc-profile-buffer/length)
+ )
+
+(define-primitives
+ (interp-proc-profile-buffer/empty? 0)
+ (interp-proc-profile-buffer/next-empty-slot-index 0)
+ (interp-proc-profile-buffer/slack 0)
+ (interp-proc-profile-buffer/slack-increment 0)
+ (interp-proc-profile-buffer/set-slack 1)
+ (interp-proc-profile-buffer/set-slack-increment 1)
+ (interp-proc-profile-buffer/extend-noisy? 0)
+ (interp-proc-profile-buffer/flush-noisy? 0)
+ (interp-proc-profile-buffer/overflow-noisy? 0)
+ (interp-proc-profile-buffer/extend-noisy?/toggle! 0)
+ (interp-proc-profile-buffer/flush-noisy?/toggle! 0)
+ (interp-proc-profile-buffer/overflow-noisy?/toggle! 0)
+ #|
+ (interp-proc-profile-buffer/with-extend-notification! 0)
+ (interp-proc-profile-buffer/with-flush-notification! 0)
+ (interp-proc-profile-buffer/with-overflow-notification! 0)
+ |#
+ ;; microcode magic: don't look. Fnord!
+ (%pc-sample/IPPB-overflow-count 0)
+ (%pc-sample/IPPB-overflow-count/reset 0)
+ (%pc-sample/IPPB-monitoring? 0)
+ (%pc-sample/IPPB-monitoring?/toggle! 0)
+ )
+
+(define (profile-buffer/with-mumble-notification! noise? thunk
+ x/f-noisy? toggle-noise!)
+ (let ((already-noisy? (x/f-noisy?))
+ (want-no-noise? (not noise?))) ; coerce to Boolean
+ (if (eq? already-noisy? want-no-noise?) ; xor want and got
+ (dynamic-wind toggle-noise! thunk toggle-noise!)
+ (thunk))))
+
+(define (interp-proc-profile-buffer/with-extend-notification! noise? thunk)
+ (profile-buffer/with-mumble-notification! noise? thunk
+ interp-proc-profile-buffer/extend-noisy?
+ interp-proc-profile-buffer/extend-noisy?/toggle!))
+
+(define (interp-proc-profile-buffer/with-flush-notification! noise? thunk)
+ (profile-buffer/with-mumble-notification! noise? thunk
+ interp-proc-profile-buffer/flush-noisy?
+ interp-proc-profile-buffer/flush-noisy?/toggle!))
+
+(define (interp-proc-profile-buffer/with-overflow-notification! noise? thunk)
+ (profile-buffer/with-mumble-notification! noise? thunk
+ interp-proc-profile-buffer/overflow-noisy?
+ interp-proc-profile-buffer/overflow-noisy?/toggle!))
+\f
+;;; Interp-Proc Profile Buffer is to buffer up sightings of interpreted procs
+;;; that are not yet hashed into the Interp-Proc Profile (Hash) Table
+
+(define *interp-proc-profile-buffer* #F) ; software cache of fixed obj Ntry
+
+(define (interp-proc-profiling-disabled?)
+ (not *interp-proc-profile-buffer*))
+
+(define *interp-proc-profile-buffer/length/initial*)
+
+(define (install-interp-proc-profile-buffer/length/initial)
+ (set! *interp-proc-profile-buffer/length/initial*
+ (* 4 (interp-proc-profile-buffer/slack))))
+
+(define *interp-proc-profile-buffer/length*)
+
+(define (install-interp-proc-profile-buffer/length)
+ ( install-interp-proc-profile-buffer/length/initial)
+ (set! *interp-proc-profile-buffer/length*
+ *interp-proc-profile-buffer/length/initial*))
+
+(define (interp-proc-profile-buffer/length)
+ *interp-proc-profile-buffer/length*)
+(define (interp-proc-profile-buffer/length/set! new-value)
+ (set! *interp-proc-profile-buffer/length* new-value))
+
+(define (interp-proc-profile-buffer/status)
+ "()\n\
+ Returns a CONS pair of the length and `slack' of the\n\
+ interpreted procedure profile buffer.\
+ "
+ (cons (interp-proc-profile-buffer/length)
+ (interp-proc-profile-buffer/slack)))
+
+(define *interp-proc-profile-buffer/status/old* '(0 . 0))
+(define (interp-proc-profile-buffer/status/previous)
+ "()\n\
+ Returns the status of the profile buffer before the last modification to\n\
+ its length and/or slack.\
+ "
+ *interp-proc-profile-buffer/status/old*)
+
+;;; TODO: flush/reset/spill/extend should all employ double buffering of the
+;;; interp-proc profile buffer.
+
+(define *interp-proc-profile-buffer/extend-count?* #F)
+(define-integrable (interp-proc-profile-buffer/extend-count?)
+ *interp-proc-profile-buffer/extend-count?*)
+(define-integrable (interp-proc-profile-buffer/extend-count?/toggle!)
+ (set! *interp-proc-profile-buffer/extend-count?*
+ (not *interp-proc-profile-buffer/extend-count?*)))
+(define (interp-proc-profile-buffer/with-extend-count! count?
+ thunk)
+ (fluid-let ((*interp-proc-profile-buffer/extend-count?* count?))
+ (thunk)))
+(define *interp-proc-profile-buffer/extend-count* 0)
+(define-integrable (interp-proc-profile-buffer/extend-count)
+ *interp-proc-profile-buffer/extend-count*)
+(define-integrable (interp-proc-profile-buffer/extend-count/reset)
+ (set! *interp-proc-profile-buffer/extend-count* 0))
+(define-integrable (interp-proc-profile-buffer/extend-count/1+)
+ (set! *interp-proc-profile-buffer/extend-count*
+ (1+ *interp-proc-profile-buffer/extend-count*)))
+
+(define (interp-proc-profile-buffer/extend)
+ (let ((stop/restart-sampler? (and (not *pc-sample/sample-sampler?*)
+ (pc-sample/started?))))
+ ;; stop if need be
+ (cond (stop/restart-sampler? (fluid-let ((*pc-sample/noisy?* #F))
+ (pc-sample/stop))))
+ ;; count if willed to
+ (cond ((interp-proc-profile-buffer/extend-count?)
+ (interp-proc-profile-buffer/extend-count/1+)))
+ ;; No need to disable during extend since we build an extended copy of the
+ ;; buffer then install it in one swell foop...
+ ;; Of course, any interp-proc samples made during the extend will be punted.
+ ;; For this reason, we go ahead and disable interp-proc buffering anyway
+ ;; since it would be a waste of time.
+ (fixed-interp-proc-profile-buffer/disable)
+ (cond ((interp-proc-profile-buffer/extend-noisy?)
+ (with-output-to-port console-output-port ; in case we're in Edwin
+ (lambda ()
+ (display "\n;> > > > > IPPB Extend Request being serviced.")))
+ (output-port/flush-output console-output-port)))
+ (let* ((slack (interp-proc-profile-buffer/slack) )
+ (old-buffer-length (interp-proc-profile-buffer/length))
+ (new-buffer-length (+ old-buffer-length slack) )
+ (new-buffer (vector-grow *interp-proc-profile-buffer*
+ new-buffer-length)))
+ ;; maintain invariant: unused slots of interp-proc-profile-buffer = #F
+ (do ((index old-buffer-length (1+ index)))
+ ((= index new-buffer-length))
+ (vector-set! new-buffer index #F))
+ ;; Intall new-buffer...
+ (set! *interp-proc-profile-buffer* new-buffer)
+ ;; synch length cache
+ (interp-proc-profile-buffer/length/set! new-buffer-length))
+ ;; Re-enable: synch kludge... one swell foop
+ (fixed-interp-proc-profile-buffer/install *interp-proc-profile-buffer*)
+ ;; restart if need be
+ (cond (stop/restart-sampler? (fluid-let ((*pc-sample/noisy?* #F))
+ (pc-sample/start)))))
+ unspecific)
+
+(define *interp-proc-profile-buffer/flush-count?* #F)
+(define-integrable (interp-proc-profile-buffer/flush-count?)
+ *interp-proc-profile-buffer/flush-count?*)
+(define-integrable (interp-proc-profile-buffer/flush-count?/toggle!)
+ (set! *interp-proc-profile-buffer/flush-count?*
+ (not *interp-proc-profile-buffer/flush-count?*)))
+(define (interp-proc-profile-buffer/with-flush-count! count?
+ thunk)
+ (fluid-let ((*interp-proc-profile-buffer/flush-count?* count?))
+ (thunk)))
+(define *interp-proc-profile-buffer/flush-count* 0)
+(define-integrable (interp-proc-profile-buffer/flush-count)
+ *interp-proc-profile-buffer/flush-count*)
+(define-integrable (interp-proc-profile-buffer/flush-count/reset)
+ (set! *interp-proc-profile-buffer/flush-count* 0))
+(define-integrable (interp-proc-profile-buffer/flush-count/1+)
+ (set! *interp-proc-profile-buffer/flush-count*
+ (1+ *interp-proc-profile-buffer/flush-count*)))
+
+(define-integrable (interp-proc-profile-buffer/flush)
+ (cond ((and *interp-proc-profile-buffer* ; not disabled
+ (interp-proc-profile-buffer/flush?))
+ (interp-proc-profile-buffer/spill-into-interp-proc-profile-table)))
+ unspecific)
+
+(define (interp-proc-profile-buffer/reset)
+ ;; It is important to disable the buffer during reset so we don't have any
+ ;; random ignored samples dangling in the buffer.
+ (let ((next-mt-slot-index
+ ;; Bletch: need to disable buffer but must sniff next-mt-slot-index
+ ;; first, then must ensure nothing new is buffered.
+ (without-interrupts
+ (lambda ()
+ (let ((nmtsi (interp-proc-profile-buffer/next-empty-slot-index)))
+ ;; NB: No interrupts between LET rhs and following assignment
+ (fixed-interp-proc-profile-buffer/disable)
+ nmtsi)))))
+ ;; It is useful to keep a global var as a handle on this object.
+ (if *interp-proc-profile-buffer* ; initialized already so avoid CONS-ing
+ (subvector-fill! *interp-proc-profile-buffer* 0 next-mt-slot-index #F)
+ (set! *interp-proc-profile-buffer*
+ (pc-sample/interp-proc-buffer/make))))
+ ;; Re-enable: synch kludge... one swell foop
+ (fixed-interp-proc-profile-buffer/install *interp-proc-profile-buffer*)
+ (cond ((pc-sample/uninitialized?)
+ (pc-sample/set-state! 'RESET)))
+ 'RESET)
+
+(define (interp-proc-profile-buffer/flush?)
+ (not (interp-proc-profile-buffer/empty?)))
+
+(define (interp-proc-profile-buffer/spill-into-interp-proc-profile-table)
+ (let ((stop/restart-sampler? (and (not *pc-sample/sample-sampler?*)
+ (pc-sample/started?))))
+ ;; stop if need be
+ (cond (stop/restart-sampler? (fluid-let ((*pc-sample/noisy?* #F))
+ (pc-sample/stop))))
+ ;; count if willed to
+ (cond ((interp-proc-profile-buffer/flush-count?)
+ (interp-proc-profile-buffer/flush-count/1+)))
+ ;; It is important to disable the buffer during spillage so we don't have
+ ;; any random ignored samples dangling in the buffer.
+ (let ((next-mt-slot-index
+ ;; Bletch: need to disable buffer but must sniff next-mt-slot-index
+ ;; first, then must ensure nothing new is buffered.
+ (without-interrupts
+ (lambda ()
+ (let ((nmtsi (interp-proc-profile-buffer/next-empty-slot-index)))
+ ;; NB: No interrupts between LET rhs and following assignment
+ (fixed-interp-proc-profile-buffer/disable)
+ nmtsi)))))
+ (cond ((interp-proc-profile-buffer/flush-noisy?)
+ (with-output-to-port console-output-port ; in case we're in Edwin
+ (lambda ()
+ (display "\n;> > > > > IPPB Flush Request being serviced.")))
+ (output-port/flush-output console-output-port)))
+ (do ((index 0 (1+ index)))
+ ((= index next-mt-slot-index))
+ ;; debuggery
+ (cond ((not (vector-ref *interp-proc-profile-buffer* index))
+ (warn "Damn. Found a #F entry at index = " index)))
+ ;; copy from buffer into hash table
+ (interp-proc-profile-table/hash-entry
+ (vector-ref *interp-proc-profile-buffer* index))
+ ;; A rivederci, Baby
+ (vector-set! *interp-proc-profile-buffer* index #F)
+ ))
+ ;; Re-enable: synch kludge... one swell foop
+ (fixed-interp-proc-profile-buffer/install *interp-proc-profile-buffer*)
+ ;; restart if need be
+ (cond (stop/restart-sampler? (fluid-let ((*pc-sample/noisy?* #F))
+ (pc-sample/start)))))
+ unspecific)
+
+
+
+(define-integrable (interp-proc-profile-buffer/overflow-count?)
+ (%pc-sample/IPPB-monitoring?))
+(define-integrable (interp-proc-profile-buffer/overflow-count?/toggle!)
+ (%pc-sample/IPPB-monitoring?/toggle!))
+
+(define (interp-proc-profile-buffer/with-overflow-count! count? thunk)
+ (let ((counting? (interp-proc-profile-buffer/overflow-count?))
+ (want-no-count? (not count?))) ; coerce to Boolean
+ (if (eq? counting? want-no-count?) ; xor want and got
+ (dynamic-wind interp-proc-profile-buffer/overflow-count?/toggle!
+ thunk
+ interp-proc-profile-buffer/overflow-count?/toggle!)
+ (thunk))))
+
+(define-integrable (interp-proc-profile-buffer/overflow-count )
+ (%pc-sample/IPPB-overflow-count ))
+(define-integrable (interp-proc-profile-buffer/overflow-count/reset)
+ (%pc-sample/IPPB-overflow-count/reset))
+\f
+;;; Interp-Proc Profile (Hash) Table is where interpreted procs are profiled...
+;;; but the profile trap handler cannot CONS so if the current profiled
+;;; proc is not already hashed, we must buffer it in the Interp-Proc Profile
+;;; Buffer until the GC Daemon gets around to hashing it.
+
+(define *interp-proc-profile-table*)
+(define (interp-proc-profile-table/make) (make-profile-hash-table 4096))
+
+(define (interp-proc-profile-table)
+ (interp-proc-profile-buffer/flush)
+ (hash-table/entries-vector *interp-proc-profile-table*))
+
+(define *interp-proc-profile-table/old* #F)
+(define (interp-proc-profile-table/old)
+ *interp-proc-profile-table/old*)
+
+(define (interp-proc-profile-table/reset #!optional disable?)
+ (set! *interp-proc-profile-table/old*
+ (interp-proc-profile-table))
+ (hash-table/clear! *interp-proc-profile-table*)
+ (set! *interp-proc-profile-buffer/status/old*
+ (interp-proc-profile-buffer/status))
+ (cond ((and (not (default-object? disable?)) disable?)
+ (set! *interp-proc-profile-buffer* #F) ; disable buffer disables table
+ (fixed-interp-proc-profile-buffer/disable)
+ ;; TODO: really should detect if last to be disabled so set overall
+ ;; sampling state to disabled
+ (if (pc-sample/initialized?)
+ 'RESET-AND-DISABLED
+ 'STILL-UNINITIALIZED))
+ ((not *interp-proc-profile-buffer*) ; disabled but wanna enable?
+ (interp-proc-profile-buffer/reset))
+ (else
+ 'RESET)))
+
+(define (interp-proc-profile-table/enable)
+ (interp-proc-profile-table/reset))
+
+(define (interp-proc-profile-table/disable)
+ (interp-proc-profile-table/reset 'DISABLE))
+
+(define (interp-proc-profile-table/hash-entry proc-lambda)
+ (cond ((hash-table/get *interp-proc-profile-table* proc-lambda false)
+ =>
+ (lambda (datum) ; found
+ (interp-proc-profile-datum/update! datum)))
+ (else ; not found
+ (hash-table/put! *interp-proc-profile-table*
+ proc-lambda
+ (interp-proc-profile-datum/make)))))
+\f
+;;; Interp-Proc Profile Datum
+
+(define-structure (interp-proc-profile-datum
+ (conc-name interp-proc-profile-datum/)
+ (constructor interp-proc-profile-datum/make
+ (#!optional count histogram rank utility)))
+ (count (interp-proc-profile-datum/count/make))
+ (histogram (interp-proc-profile-datum/histogram/make))
+ (rank (interp-proc-profile-datum/rank/make))
+ (utility (interp-proc-profile-datum/utility/make))
+ ;... more to come (?)
+ )
+
+(define (interp-proc-profile-datum/count/make) 1.0) ; FLONUM
+(define (interp-proc-profile-datum/histogram/make) '#())
+(define (interp-proc-profile-datum/rank/make) 0)
+(define (interp-proc-profile-datum/utility/make) 0.0) ; FLONUM
+;... more to come (?)
+
+(define (interp-proc-profile-datum/update! datum)
+ (set-interp-proc-profile-datum/count!
+ datum
+ (flo:+ 1.0 (interp-proc-profile-datum/count datum))) ; FLONUM
+ ;; histogram not yet implemented
+ ;; rank not yet implemented
+ ;; utility not yet implemented
+
+ ;; NB: returns datum
+ datum)
+
+;;; fini
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/pcsample/pribinut.scm,v 1.1 1995/07/28 14:14:08 adams Exp $
+
+Copyright (c) 1993 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Primitive, Builtin and Utility support
+;;; package: (pribinut)
+
+(declare (usual-integrations))
+\f
+(define (initialize-package!)
+ (install-pribinut))
+
+(define-primitives
+ (get-primitive-counts 0)
+ (get-primitive-name 1))
+
+
+;; Primitives-- NB: *not* memoizeable since can dynamically load new ucode!
+
+(define (get-primitive-count)
+ "()\n\
+ Returns the sum of the number of defined and undefined primitive procedures.\
+ "
+ (let ((defined-dot-undefined (get-primitive-counts)))
+ (+ (car defined-dot-undefined)
+ (cdr defined-dot-undefined))))
+
+
+;; GJR Hack: given that mumble-get returns #F is nonesuch, we can walk up
+;; through the indices until we find the first failure. Moreover,
+;; Since there is no mechanism for dynacmically loading new builtins
+;; or utilities, this result can be memoized.
+
+(define (count-mumbles mumble-getter)
+ (do ((i 0 (1+ i)))
+ ((not (mumble-getter i)) ; first index to fail to be gotten is it
+ i)))
+
+
+;; Builtins
+
+(define (get-builtin-name index)
+ ((ucode-primitive builtin-index->name 1) index))
+
+(define *builtin-count-promise*) ; tba
+(define (get-builtin-count)
+ "()\n\
+ Returns the number of ``builtin'' hooks defined in the running Scheme system.\
+ "
+ (force *builtin-count-promise*))
+
+(define (install-builtin-count-promise)
+ (set! *builtin-count-promise*
+ (delay (count-mumbles get-builtin-name)))
+ unspecific)
+
+
+;; Utilities
+
+(define (get-utility-name index)
+ ((ucode-primitive utility-index->name 1) index))
+
+(define *utility-count-promise*) ; tba
+(define (get-utility-count)
+ "()\n\
+ Returns the number of ``utility'' hooks defined in the running Scheme system.\
+ "
+ (force *utility-count-promise*))
+
+(define (install-utility-count-promise)
+ (set! *utility-count-promise*
+ (delay (count-mumbles get-utility-name)))
+ unspecific)
+
+
+;; Install
+
+(define (install-pribinut)
+ (install-builtin-count-promise)
+ (install-utility-count-promise)
+ ;; re-cache counts in code new frobs have been added to the microcode
+ (add-event-receiver! event:after-restore install-pribinut))
+
+
+;;; fini
projects / mit-scheme.git / commitdiff