From: Stephen Adams Date: Fri, 28 Jul 1995 14:14:08 +0000 (+0000) Subject: Initial revision X-Git-Tag: 20090517-FFI~6100 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=5a6cf119229f050ce3dc1bfd66601e8ca14c8ffd;p=mit-scheme.git Initial revision --- diff --git a/v7/src/pcsample/Makefile b/v7/src/pcsample/Makefile new file mode 100644 index 000000000..c67a612ca --- /dev/null +++ b/v7/src/pcsample/Makefile @@ -0,0 +1,24 @@ +# +# 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) diff --git a/v7/src/pcsample/load.scm b/v7/src/pcsample/load.scm new file mode 100644 index 000000000..8a8f85812 --- /dev/null +++ b/v7/src/pcsample/load.scm @@ -0,0 +1,94 @@ +#| -*-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)) + +(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 + diff --git a/v7/src/pcsample/pcs.cbf b/v7/src/pcsample/pcs.cbf new file mode 100644 index 000000000..54a3510bd --- /dev/null +++ b/v7/src/pcsample/pcs.cbf @@ -0,0 +1,42 @@ +#| -*-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 diff --git a/v7/src/pcsample/pcs.pkg b/v7/src/pcsample/pcs.pkg new file mode 100644 index 000000000..6d02393f1 --- /dev/null +++ b/v7/src/pcsample/pcs.pkg @@ -0,0 +1,434 @@ +#| -*-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!))) + +(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!))) diff --git a/v7/src/pcsample/pcs.sf b/v7/src/pcsample/pcs.sf new file mode 100644 index 000000000..9207fda85 --- /dev/null +++ b/v7/src/pcsample/pcs.sf @@ -0,0 +1,42 @@ +#| -*-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") diff --git a/v7/src/pcsample/pcsample.c b/v7/src/pcsample/pcsample.c new file mode 100644 index 000000000..9b18b1454 --- /dev/null +++ b/v7/src/pcsample/pcsample.c @@ -0,0 +1,1428 @@ +/* -*-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 */ + +/*!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*\ + * 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 + * +\*!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*/ + + +#include /* UNIX bullocks */ +#include /* For profile_timer_set/clear */ +#include /* For TRUE/FALSE & true/false */ +#include +#include /* UNIX trap handlers */ +#include /* For DEFUN_STD_HANDLER */ +#include /* For DEFINE_PRIMITIVE */ +#include /* 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 + +} + + +/*****************************************************************************/ +#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 + +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); + }) + +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)) ; +} + +/***************************************************************************** + * 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); +} + + +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 () ; +} + +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) ; +} + +/*****************************************************************************/ +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)) ; +} + +/*****************************************************************************/ +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 () ; +} + +/***************************************************************************** + * 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 () ; +} + +/*****************************************************************************/ +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 */ + } +} + +/*****************************************************************************/ +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 */ +}; + +/*****************************************************************************/ +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 */ + ); +} +/*---------------------------------------------------------------------------*/ + +/*****************************************************************************/ +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 ... */ + + /* ... 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 */ + +/*****************************************************************************/ +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 ... */ + + /* ... 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 */ + +/*****************************************************************************/ +#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; + } + } +} + +/*****************************************************************************/ +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))); +} + +/*****************************************************************************/ +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 */ diff --git a/v7/src/pcsample/pcsample.scm b/v7/src/pcsample/pcsample.scm new file mode 100644 index 000000000..53c20e9f0 --- /dev/null +++ b/v7/src/pcsample/pcsample.scm @@ -0,0 +1,1253 @@ +#| -*-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)) + +(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)) + ) + +;; 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 )\n\ + where 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 )\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)) + +#| + | + | -------------------------------------------------- + | -------------------------------------------------- + | + | 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. + | + |# + +;;; 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))))))) + +;;; 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.) + + +(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)))) + +;;; 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)))) + +;;; 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)))) + +;;; 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 diff --git a/v7/src/pcsample/pcsboot.scm b/v7/src/pcsample/pcsboot.scm new file mode 100644 index 000000000..90725ed51 --- /dev/null +++ b/v7/src/pcsample/pcsboot.scm @@ -0,0 +1,49 @@ +#| -*-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 + diff --git a/v7/src/pcsample/pcscobl.c b/v7/src/pcsample/pcscobl.c new file mode 100644 index 000000000..f9af1b4ca --- /dev/null +++ b/v7/src/pcsample/pcscobl.c @@ -0,0 +1,1140 @@ +/* -*-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 */ + +/*!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*\ + * TODO: + * + * - Maybe flatten number of primitives? + * +\*!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*/ + +/*****************************************************************************\ + * 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 ... */ + + /* ... 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) + +/*---------------------------------------------------------------------------*/ +#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 (); +} + +/*---------------------------------------------------------------------------*/ +#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); +} + +/*---------------------------------------------------------------------------*/ +/*---------------------------------------------------------------------------*/ +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); +} + +/*---------------------------------------------------------------------------*/ +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); +} + +/*---------------------------------------------------------------------------*/ +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)) ; +} + +/*---------------------------------------------------------------------------*/ +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)) ; +} + +/*---------------------------------------------------------------------------*/ +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); +} + +/*---------------------------------------------------------------------------*/ +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)) ; +} + +/*---------------------------------------------------------------------------*/ +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)) ; +} + +/*---------------------------------------------------------------------------*/ +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)) ; +} + +/*---------------------------------------------------------------------------*/ +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); +} + +/*---------------------------------------------------------------------------*/ +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); +} + +/*---------------------------------------------------------------------------*/ +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); +} + +/*---------------------------------------------------------------------------*/ +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); +} +/*---------------------------------------------------------------------------*/ + +/*****************************************************************************/ +#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 */ diff --git a/v7/src/pcsample/pcscobl.scm b/v7/src/pcsample/pcscobl.scm new file mode 100644 index 000000000..c2a6bb704 --- /dev/null +++ b/v7/src/pcsample/pcscobl.scm @@ -0,0 +1,1058 @@ +#| -*-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)) + +(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!)) + +;;; 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*) + +;;; 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)) + +;;; 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)) + +;;; 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))))) + +;;; 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 diff --git a/v7/src/pcsample/pcsdisp.com b/v7/src/pcsample/pcsdisp.com new file mode 100644 index 000000000..1b1b25e21 Binary files /dev/null and b/v7/src/pcsample/pcsdisp.com differ diff --git a/v7/src/pcsample/pcsdisp.scm b/v7/src/pcsample/pcsdisp.scm new file mode 100644 index 000000000..4d01d23ed --- /dev/null +++ b/v7/src/pcsample/pcsdisp.scm @@ -0,0 +1,715 @@ +#| -*-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)) + +(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)) + ) + +;; 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 '<--- ')))) + (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))))) + +;;; 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 diff --git a/v7/src/pcsample/pcsdld.c b/v7/src/pcsample/pcsdld.c new file mode 100644 index 000000000..425ad554f --- /dev/null +++ b/v7/src/pcsample/pcsdld.c @@ -0,0 +1,905 @@ +/* -*-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 */ + +/*!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*\ + * TODO: + * Get a real job. Find a wife, CONS up some progeny. Write a will. Croak. + * +\*!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*/ + +/***************************************************************************** + * 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 /* 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.\ + "); + + /*-------------------------------------------------------------------------*/ + 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).\ + "); + + /*-------------------------------------------------------------------------*/ + 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!\ + "); + + /*-------------------------------------------------------------------------*/ + 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!).\ + "); + + /*-------------------------------------------------------------------------*/ + 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!\ + "); + /*-------------------------------------------------------------------------*/ + + /*-------------------------------------------------------------------------*/ + 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.\ + "); + + /*-------------------------------------------------------------------------*/ + 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.\ + "); + + /*-------------------------------------------------------------------------*/ + 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.\ + "); + + /*-------------------------------------------------------------------------*/ + 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!\ + "); + + /*-------------------------------------------------------------------------*/ + 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!\ + "); + + /*-------------------------------------------------------------------------*/ + 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!).\ + "); + + /*-------------------------------------------------------------------------*/ + 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!).\ + "); + + /*-------------------------------------------------------------------------*/ + 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 */ diff --git a/v7/src/pcsample/pcsintrp.scm b/v7/src/pcsample/pcsintrp.scm new file mode 100644 index 000000000..334bbc7ac --- /dev/null +++ b/v7/src/pcsample/pcsintrp.scm @@ -0,0 +1,139 @@ +#| -*-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)) + +(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)) + +;;;; 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 diff --git a/v7/src/pcsample/pcsiproc.c b/v7/src/pcsample/pcsiproc.c new file mode 100644 index 000000000..6e6e7f9cb --- /dev/null +++ b/v7/src/pcsample/pcsiproc.c @@ -0,0 +1,595 @@ +/* -*-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 /* For AUX_LIST_TYPE */ + +/*!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*\ + * TODO: + * + * - Maybe flatten number of primitives? + * +\*!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*/ + +/*===========================================================================*\ + * 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) + +/*---------------------------------------------------------------------------*/ +#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)) ; +} +/*---------------------------------------------------------------------------*/ +/*---------------------------------------------------------------------------*/ + +/*---------------------------------------------------------------------------*/ +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); +} + +/*---------------------------------------------------------------------------*/ +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)) ; +} + +/*---------------------------------------------------------------------------*/ +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); +} + +/*---------------------------------------------------------------------------*/ +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)) ; +} + +/*---------------------------------------------------------------------------*/ +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); +} + +/*---------------------------------------------------------------------------*/ +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); +} + +/***************************************************************************** + * 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 */ diff --git a/v7/src/pcsample/pcsiproc.scm b/v7/src/pcsample/pcsiproc.scm new file mode 100644 index 000000000..e18453853 --- /dev/null +++ b/v7/src/pcsample/pcsiproc.scm @@ -0,0 +1,429 @@ +#| -*-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)) + +;;; 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!)) + +;;; 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)) + +;;; 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))))) + +;;; 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 diff --git a/v7/src/pcsample/pribinut.scm b/v7/src/pcsample/pribinut.scm new file mode 100644 index 000000000..21ee2f819 --- /dev/null +++ b/v7/src/pcsample/pribinut.scm @@ -0,0 +1,115 @@ +#| -*-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)) + +(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