home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / pcsample / pcsample.scm < prev    next >
Text File  |  1999-01-02  |  51KB  |  1,241 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: pcsample.scm,v 1.3 1999/01/02 06:11:34 cph Exp $
  4.  
  5. Copyright (c) 1995, 1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. #|
  23. TODO:
  24.         Flonum in counts should be coerced into exacts straight away.
  25.         Make profile tables hold their elements weakly again (?)
  26.     Reset should preserve enable/disable state.
  27.         Separate timing from sampling.
  28. |#
  29.  
  30. ;;;; PC Sampling
  31. ;;; package: (pc-sample)
  32.  
  33. (declare (usual-integrations))
  34.  
  35. (define (initialize-package!)
  36.   (set! *pc-sample/state* 'UNINITIALIZED)
  37.   (set! *pc-sample/sample-interval* pc-sample/default-sample-interval)
  38.   (install))
  39.  
  40. (define-primitives
  41.   (pc-sample/timer-clear 0)
  42.   (pc-sample/timer-set   2)
  43.   (%pc-sample/halted? 0)    ; super secret state hook
  44.   (pc-sample/spill-GC-samples-into-primitive-table 0)
  45.   (        interp-proc-profile-buffer/install 1)
  46.   (        interp-proc-profile-buffer/disable 0)
  47.   (purified-code-block-profile-buffers/install 2)
  48.   ( heathen-code-block-profile-buffers/install 2)
  49.   (purified-code-block-profile-buffers/disable 0)
  50.   ( heathen-code-block-profile-buffers/disable 0)
  51.   ;; Following for runtime/microcode installation only
  52.   (%pc-sample/install-microcode 0)
  53.   (%pc-sample/disable-microcode 0)
  54.   )
  55.  
  56. (define index:pc-sample/builtin-table)
  57. (define index:pc-sample/utility-table)
  58. (define index:pc-sample/primitive-table)
  59. (define index:pc-sample/code-block-table)
  60. (define index:pc-sample/purified-code-block-block-buffer)
  61. (define index:pc-sample/purified-code-block-offset-buffer)
  62. (define index:pc-sample/heathen-code-block-block-buffer)
  63. (define index:pc-sample/heathen-code-block-offset-buffer)
  64. (define index:pc-sample/interp-proc-buffer)
  65. (define index:pc-sample/prob-comp-table)
  66. (define index:pc-sample/UFO-table)
  67.  
  68. (define (install-indices)        ; see utabmd.scm
  69.   (set! index:pc-sample/builtin-table
  70.     (fixed-objects-vector-slot 'PC-Sample/Builtin-Table))
  71.   (set! index:pc-sample/utility-table
  72.     (fixed-objects-vector-slot 'PC-Sample/Utility-Table))
  73.   (set! index:pc-sample/primitive-table
  74.     (fixed-objects-vector-slot 'PC-Sample/Primitive-Table))
  75.   (set! index:pc-sample/code-block-table
  76.     (fixed-objects-vector-slot 'PC-Sample/Code-Block-Table))
  77.   (set! index:pc-sample/purified-code-block-block-buffer
  78.     (fixed-objects-vector-slot 'PC-Sample/Purified-Code-Block-Block-Buffer))
  79.   (set! index:pc-sample/purified-code-block-offset-buffer
  80.     (fixed-objects-vector-slot 'PC-Sample/Purified-Code-Block-Offset-Buffer))
  81.   (set! index:pc-sample/heathen-code-block-block-buffer
  82.     (fixed-objects-vector-slot 'PC-Sample/Heathen-Code-Block-Block-Buffer))
  83.   (set! index:pc-sample/heathen-code-block-offset-buffer
  84.     (fixed-objects-vector-slot 'PC-Sample/Heathen-Code-Block-Offset-Buffer))
  85.   (set! index:pc-sample/interp-proc-buffer
  86.     (fixed-objects-vector-slot 'PC-Sample/Interp-Proc-Buffer))
  87.   (set! index:pc-sample/prob-comp-table
  88.     (fixed-objects-vector-slot 'PC-Sample/Prob-Comp-Table))
  89.   (set! index:pc-sample/UFO-table
  90.     (fixed-objects-vector-slot 'PC-Sample/UFO-Table))
  91.   )
  92.  
  93. ;; Sample while running pc-sample interrupt handling code?
  94.  
  95. (define *pc-sample/sample-sampler?* #F)    ; Ziggy wants to, but nobody else...
  96.  
  97. ;; Sample Interval
  98.  
  99. (define *pc-sample/sample-interval*)
  100. (define  pc-sample/default-sample-interval 20) ; milliseconds (i.e. 50Hz-ish)
  101.  
  102. (define (pc-sample/sample-interval)
  103.   "()\n\
  104.   Returns the interval (in milliseconds) between the completion of one\n\
  105.   PC sampling and the initiation of the next PC sampling.\n\
  106.   This value may be changed by invoking:\n\
  107.          (PC-SAMPLE/SET-SAMPLE-INTERVAL <interval>)\n\
  108.   where <interval> is an exact positive integer expressing milliseconds.\n\
  109.   The initial value for this implicit system state variable is determined\n\
  110.   by the value returned by the expression: (PC-SAMPLE/DEFAULT-SAMPLE-INTERVAL)\
  111.   "
  112.         *pc-sample/sample-interval*)    ; Fear not: package inits to default
  113.  
  114. (define (pc-sample/set-sample-interval #!optional interval)
  115.   "(#!OPTIONAL interval)\n\
  116.   Sets the interval between the completion of one PC sampling and the\n\
  117.   initiation of the next PC sampling to be roughly INTERVAL milliseconds.\n\
  118.   If no INTERVAL argument is supplied, it defaults to the value returned by\n\
  119.   the expression (PC-SAMPLE/DEFAULT-SAMPLE-INTERVAL).\
  120.   "
  121.   (set! *pc-sample/sample-interval*
  122.     (cond ((default-object? interval)
  123.            pc-sample/default-sample-interval)
  124.           ((zero? interval)
  125.            (cond (*pc-sample/noisy?*
  126.               (display
  127.                (string-append "\n;; PC Sampling has been disabled "
  128.                       "via a  0 msec  sampling interval."))))
  129.            0)
  130.           ((negative? interval)    ; Smart ass.
  131.            (display (string-append
  132.              "\n"
  133.              ";;-----------\n"
  134.              ";; WARNING --\n"
  135.              ";;-----------\n"
  136.              ";;\n"
  137.              ";; Your hardware configuration cannot "
  138.                 "support negative PC sampling intervals.\n"
  139.              ";; Consult your local hardware distributor for an "
  140.                 "FTL co-processor upgrade kit.\n"
  141.              ";;\n"
  142.              ";; In the meantime, a sample interval of  1 msec  "
  143.                 "will be used instead.\n"
  144.              ";;\n"
  145.              ";; Have a nice day, " (current-user-name) ".\n"))
  146.            1)
  147.           ((not (integer? interval))
  148.            (error "PC Sampling interval must be a non-negative integer."
  149.               interval))
  150.           (else
  151.            interval)))
  152.   unspecific)
  153.  
  154. (define *current-user-name-promise*)
  155. (define (current-user-name) (force *current-user-name-promise*))
  156.  
  157. (define (install-current-user-name-promise)
  158.   (cond (*pc-sample/install-verbosity?*
  159.      (newline)
  160.      (display "Installing current user name promise...")
  161.      (newline)))
  162.   (set! *current-user-name-promise* (delay (unix/current-user-name)))
  163.   unspecific)
  164.  
  165. ;; Sample State Regulation
  166.  
  167. (define *pc-sample/state*)
  168. (define (pc-sample/state)
  169.         *pc-sample/state*)
  170. (define (pc-sample/set-state! new-state)
  171.   (set! *pc-sample/state*     new-state))
  172.  
  173. (define (pc-sample/uninitialized?)
  174.   (eq?  (pc-sample/state) 'UNINITIALIZED))
  175.  
  176. (define (pc-sample/init #!optional start?)
  177.   "(#!OPTIONAL start?)\n\
  178.   Resets all PC sampling tables and sets the sampling interval to the\n\
  179.   system default sampling interval.\n\
  180.   This is the preferred way to initialize PC sampling in the system.\n\
  181.   If the optional START? argument is supplied, PC sampling commences ASAP.\n\
  182.   Otherwise, (PC-SAMPLE/START) may be invoked to commence sampling, whereupon\n\
  183.   the evolving state of the PC sampling tables and counters may be monitored\n\
  184.   by invoking: (PC-SAMPLE/STATUS).\
  185.   "
  186.   (pc-sample/reset)
  187.   (pc-sample/set-state! 'INITIALIZED)
  188.   (if (or (default-object? start?) (not start?))
  189.       (pc-sample/set-sample-interval)
  190.       (pc-sample/start))
  191.   unspecific)
  192.  
  193. (define (pc-sample/initialized?)
  194.   (not  (pc-sample/uninitialized?)))
  195.  
  196.  
  197. (define *pc-sample/noisy?* #F)
  198.  
  199. (define (pc-sample/start #!optional interval)
  200.   "(#!OPTIONAL interval)\n\
  201.   Enables periodic sampling of the virtual Program Counter by starting the\n\
  202.   PC sampling interrupt timer. Note that this does *not* initialize the PC\n\
  203.   sampling tables into which the sampling profile information is gathered.\n\
  204.   Unless/until these tables are initialized, no gathering of sampling info\n\
  205.   will be recorded, although the PC sampling interrupts will be issued and\n\
  206.   processed: the data will just not be recorded. To initiate sampling, refer\n\
  207.   to (PC-SAMPLE/INIT) instead. By contrast, PC-SAMPLE/START serves two pur-\n\
  208.   poses: 1) it is useful for unsuspending PC sampling after one has issued\n\
  209.   a (PC-SAMPLE/STOP), and 2) it is useful for debuggering the interrupt/trap\n\
  210.   mechanism for processing periodic PC sampling.\n\
  211.   \n\
  212.   The optional INTERVAL argument specifies how many milliseconds after a\n\
  213.   PC sample completes should the next PC sample be attempted.\n\
  214.   The evolving state of the PC sampling tables and counters may be monitored\n\
  215.   by invoking: (PC-SAMPLE/STATUS).\
  216.  "
  217.   (cond ((not (default-object? interval))
  218.      (pc-sample/set-sample-interval interval)))
  219.   (let ((real-interval (pc-sample/sample-interval)))
  220.     (cond ((zero? real-interval)
  221.        (pc-sample/timer-clear)
  222.        (pc-sample/disable)
  223.        (cond (*pc-sample/noisy?*
  224.           (display
  225.            "\n;; PC Sampling DISABLED: by virtue of 0 msec interval")))
  226.        )
  227.       ((pc-sample/uninitialized?)
  228.        (pc-sample/init 'START))
  229.       (else
  230.        (cond (*pc-sample/noisy?*
  231.           (display (string-append "\n;; PC Sampling starting: "
  232.                       (number->string real-interval)
  233.                       " millisecond period."))))
  234.        (pc-sample/set-state! 'RUNNING)
  235.        (pc-sample/timer-set *ASAP* real-interval)))
  236.     )
  237.   unspecific)
  238.  
  239. (define *ASAP* 1)  ; cannot be 0... that would disable the timer.
  240.  
  241. (define-integrable (pc-sample/running?)
  242.              (not  (%pc-sample/halted?)))
  243.  
  244. (define-integrable (pc-sample/started?)
  245.                    (pc-sample/running?))
  246.  
  247.  
  248. (define (pc-sample/stop)
  249.   "()\n\
  250.   Halts PC sampling by disabling the sampling interrupt timer.\n\
  251.   No profiling state is reset so invoking (PC-SAMPLE/START <interval>)\n\
  252.   afterward will re-start profiling by accumulating into the existing state.\n\
  253.   By contrast, see PC-SAMPLE/ENABLE and PC-SAMPLE/DISABLE.\n\
  254.   The state of the PC sampling tables and counters existent at the time when\n\
  255.   the sampling was stopped may be monitored by invoking: (PC-SAMPLE/STATUS).\
  256.   "
  257.   (pc-sample/timer-clear)
  258.   (pc-sample/set-state! 'STOPPED)
  259.   (cond (*pc-sample/noisy?*
  260.      (display "\n;; PC Sampling stopped.")))
  261.   unspecific)
  262.  
  263. (define-integrable (pc-sample/stopped?)
  264.                    (%pc-sample/halted?))
  265.  
  266. ;; Status/Accessors
  267.  
  268. ;; Returns a structure of PC sampling profile information.
  269. ;; This is useful for monitoring the evolving histogram of PC sampling data.
  270.  
  271. (define-structure (pc-sample/status-record
  272.            (conc-name    pc-sample/status/)
  273.            (constructor pc-sample/status
  274.                 (#!optional builtin-table
  275.                         utility-table
  276.                         primitive-table
  277.                         code-block-table
  278.                         code-block-buffer/status
  279.                         interp-proc-table
  280.                         interp-proc-buffer/status
  281.                         prob-comp-table
  282.                         UFO-table)))
  283.   (builtin-table        (pc-sample/builtin-table))
  284.   (utility-table        (pc-sample/utility-table))
  285.   (primitive-table        (pc-sample/primitive-table))
  286.   (code-block-table        (pc-sample/code-block-table))
  287.   (code-block-buffer/status    (pc-sample/code-block-buffer/status))
  288.   (interp-proc-table        (pc-sample/interp-proc-table))
  289.   (interp-proc-buffer/status    (pc-sample/interp-proc-buffer/status))
  290.   (prob-comp-table        (pc-sample/prob-comp-table))
  291.   (UFO-table            (pc-sample/UFO-table))
  292.   )
  293.  
  294. (define pc-sample/builtin-table)
  295. (define pc-sample/utility-table)
  296. (define pc-sample/primitive-table)
  297. (define pc-sample/purified-code-block-block-buffer)
  298. (define pc-sample/purified-code-block-offset-buffer)
  299. (define pc-sample/heathen-code-block-block-buffer)
  300. (define pc-sample/heathen-code-block-offset-buffer)
  301. (define pc-sample/interp-proc-buffer)
  302. (define pc-sample/prob-comp-table)
  303. (define pc-sample/UFO-table)
  304.  
  305. (define (pc-sample/code-block-table)          (code-block-profile-table))
  306. (define (pc-sample/code-block-buffer/status)  (code-block-profile-buffer/status))
  307. (define (pc-sample/interp-proc-table)        (interp-proc-profile-table))
  308. (define (pc-sample/interp-proc-buffer/status)(interp-proc-profile-buffer/status))
  309.  
  310. ;; Exportable naming scheme
  311. (define (pc-sample/builtin/status)
  312.         (pc-sample/builtin-table))
  313. (define (pc-sample/utility/status)
  314.         (pc-sample/utility-table))
  315. (define (pc-sample/primitive/status)
  316.         (pc-sample/primitive-table))
  317. (define (pc-sample/code-block/status)
  318.         (pc-sample/code-block-table))
  319. (define (pc-sample/interp-proc/status)
  320.         (pc-sample/interp-proc-table))
  321. (define (pc-sample/prob-comp/status)
  322.         (pc-sample/prob-comp-table))
  323. (define (pc-sample/UFO/status)
  324.         (pc-sample/UFO-table))
  325.  
  326. (define (generate:pc-sample/table-accessor index)
  327.   (lambda ()
  328.     (cond ((eq? index index:pc-sample/primitive-table)
  329.        (pc-sample/spill-GC-samples-into-primitive-table)))
  330.     (vector-ref (get-fixed-objects-vector) index)))
  331.  
  332. (define (install-accessors)
  333.   (set! pc-sample/builtin-table
  334.     (generate:pc-sample/table-accessor index:pc-sample/builtin-table))
  335.   (set! pc-sample/utility-table
  336.     (generate:pc-sample/table-accessor index:pc-sample/utility-table))
  337.   (set! pc-sample/primitive-table
  338.     (generate:pc-sample/table-accessor index:pc-sample/primitive-table))
  339.   (set! pc-sample/purified-code-block-block-buffer
  340.     (generate:pc-sample/table-accessor index:pc-sample/purified-code-block-block-buffer))
  341.   (set! pc-sample/purified-code-block-offset-buffer
  342.     (generate:pc-sample/table-accessor index:pc-sample/purified-code-block-offset-buffer))
  343.   (set! pc-sample/heathen-code-block-block-buffer
  344.     (generate:pc-sample/table-accessor index:pc-sample/heathen-code-block-block-buffer))
  345.   (set! pc-sample/heathen-code-block-offset-buffer
  346.     (generate:pc-sample/table-accessor index:pc-sample/heathen-code-block-offset-buffer))
  347.   (set! pc-sample/interp-proc-buffer
  348.     (generate:pc-sample/table-accessor index:pc-sample/interp-proc-buffer))
  349.   (set! pc-sample/prob-comp-table
  350.     (generate:pc-sample/table-accessor index:pc-sample/prob-comp-table))
  351.   (set! pc-sample/UFO-table
  352.     (generate:pc-sample/table-accessor index:pc-sample/UFO-table))
  353.   )
  354.  
  355. (define-structure (pc-sample/fixed-objects-record
  356.            (conc-name    pc-sample/fixed-objects/)
  357.            (constructor pc-sample/fixed-objects
  358.                 (#!optional builtin-table
  359.                         utility-table
  360.                         primitive-table
  361.                         purified-cobl-block-buffer
  362.                         purified-cobl-offset-buffer
  363.                         heathen-cobl-block-buffer
  364.                         heathen-cobl-offset-buffer
  365.                         interp-proc-buffer
  366.                         prob-comp-table
  367.                         UFO-table)))
  368.   (builtin-table           (pc-sample/builtin-table))
  369.   (utility-table           (pc-sample/utility-table))
  370.   (primitive-table           (pc-sample/primitive-table))
  371.   (purified-cobl-block-buffer  (pc-sample/purified-code-block-block-buffer))
  372.   (purified-cobl-offset-buffer (pc-sample/purified-code-block-offset-buffer))
  373.   (heathen-cobl-block-buffer   (pc-sample/heathen-code-block-block-buffer))
  374.   (heathen-cobl-offset-buffer  (pc-sample/heathen-code-block-offset-buffer))
  375.   (interp-proc-buffer           (pc-sample/interp-proc-buffer))
  376.   (prob-comp-table           (pc-sample/prob-comp-table))
  377.   (UFO-table               (pc-sample/UFO-table))
  378.   )
  379.  
  380. ;; Makers
  381.  
  382. (define pc-sample/builtin-table/make)
  383. (define pc-sample/utility-table/make)
  384. (define pc-sample/primitive-table/make)
  385. (define pc-sample/code-block-buffer/make/purified-blocks)
  386. (define pc-sample/code-block-buffer/make/purified-offsets)
  387. (define pc-sample/code-block-buffer/make/heathen-blocks)
  388. (define pc-sample/code-block-buffer/make/heathen-offsets)
  389. (define pc-sample/interp-proc-buffer/make)
  390. (define pc-sample/prob-comp-table/make)
  391. (define pc-sample/UFO-table/make)
  392.  
  393. (define (generate:pc-sample/table-maker length-thunk init-value-thunk)
  394.   (lambda ()
  395.     (make-initialized-vector (length-thunk)
  396.                  (lambda (i) i (init-value-thunk)))))
  397.  
  398. (define (generate:pc-sample/buffer-maker length-thunk)
  399.   (lambda ()
  400.     (make-vector (length-thunk)
  401.          ;; interp-proc-buffer is a buffer of interp-procs, 
  402.          ;;   not a table of counters.
  403.          #F)))
  404.  
  405. (define (generate:pc-sample/counter-maker init-value-thunk)
  406.   (lambda ()
  407.     (vector (init-value-thunk)        ; happy count
  408.         (init-value-thunk)        ;   sad count
  409.         )))
  410.  
  411. (define (install-makers)
  412.   (set! pc-sample/builtin-table/make
  413.     (generate:pc-sample/table-maker get-builtin-count
  414.                     pc-sample/init-datum))
  415.   (set! pc-sample/utility-table/make
  416.     (generate:pc-sample/table-maker get-utility-count
  417.                     pc-sample/init-datum))
  418.   (set! pc-sample/primitive-table/make
  419.     (generate:pc-sample/table-maker get-primitive-count
  420.                     pc-sample/init-datum))
  421.   (set! pc-sample/code-block-buffer/make/purified-blocks
  422.     (generate:pc-sample/buffer-maker code-block-profile-buffer/purified/length))
  423.   (set! pc-sample/code-block-buffer/make/purified-offsets
  424.     (generate:pc-sample/buffer-maker code-block-profile-buffer/purified/length))
  425.   (set! pc-sample/code-block-buffer/make/heathen-blocks
  426.     (generate:pc-sample/buffer-maker code-block-profile-buffer/heathen/length))
  427.   (set! pc-sample/code-block-buffer/make/heathen-offsets
  428.     (generate:pc-sample/buffer-maker code-block-profile-buffer/heathen/length))
  429.   (set! pc-sample/interp-proc-buffer/make
  430.     (generate:pc-sample/buffer-maker interp-proc-profile-buffer/length))
  431.   (set! pc-sample/prob-comp-table/make    
  432.     (generate:pc-sample/counter-maker pc-sample/init-datum))
  433.   (set! pc-sample/UFO-table/make    
  434.     (generate:pc-sample/counter-maker pc-sample/init-datum))
  435.   )
  436.  
  437. (define    (code-block-profile-buffer/purified/length) ; annoying alias
  438.   (purified-code-block-profile-buffer/length))
  439. (define    (code-block-profile-buffer/heathen/length)  ; disturbing alias
  440.   ( heathen-code-block-profile-buffer/length))
  441.  
  442. (define (pc-sample/init-datum)
  443.   "()\n\
  444.    The initial PC sampling profile datum for each profiling table entry.\n\
  445.    This is a convenient data abstraction for later extending profiling\n\
  446.    data to be more than mere counts. More elaborate histograms are envisioned,\
  447.    including gathering of timing and type statistics.\
  448.   "
  449. ;------------------------------------------------------------------------------
  450. ; HORROR!  When I used a constant 0.0, I found it shared throughout the
  451. ;          profile data structures... I think maybe my C manipulation is
  452. ;          updating in place rather than storing back into the vector(s).
  453. ;          Dr.Adams assisted me in defining this adorable little work around
  454. ;          as a means of confusing the compiler into CONS-ing up a bunch o'
  455. ;          floating point 0.0's.
  456. ;------------------------------------------------------------------------------
  457.   (massive-kludge *kludgey-constant*))    ; for now, just a count
  458.  
  459. (define *kludgey-constant* (flo:+ 37. 42.))
  460.  
  461. (define (massive-kludge x)
  462.   (flo:- x *kludgey-constant*))
  463. ;--------------------------------END-OF-HORROR---------------------------------
  464.  
  465. ;; Profile hashtables (for interp-procs [pcsiproc] & code blocks [pcscobl])
  466.  
  467. (define make-profile-hash-table    )
  468. (define      profile-hash-table-car)
  469. (define      profile-hash-table-cdr)
  470.  
  471. (define (install-profile-hash-table)
  472.   (load-option 'hash-table)        ; For code block profile tables
  473.  
  474. ;;;(set! make-profile-hash-table     make-eq-hash-table);   weakly held
  475. ;;;(set!      profile-hash-table-car weak-car)
  476. ;;;(set!      profile-hash-table-cdr weak-cdr)
  477.  
  478.   (set! make-profile-hash-table                ; strongly held
  479.     (strong-hash-table/constructor (lambda (obj modulus)
  480.                      (modulo (object-hash obj) modulus))
  481.                        eq?
  482.                        #T))
  483.   (set! profile-hash-table-car car)
  484.   (set! profile-hash-table-cdr cdr)
  485.   )
  486.  
  487. ;; Old value caches
  488.  
  489. ;; Returns the profiling status in effect just before the last reset of any\n\
  490. ;; PC sampling profile table.\
  491.  
  492. (define-structure (pc-sample/status/previous-record
  493.            (conc-name    pc-sample/status/previous/)
  494.            (constructor pc-sample/status/previous
  495.                 (#!optional builtin-table
  496.                         utility-table
  497.                         primitive-table
  498.                         code-block-table
  499.                         code-block-buffer/status
  500.                         interp-proc-table
  501.                         interp-proc-buffer/status
  502.                         prob-comp-table
  503.                         UFO-table)))
  504.   (builtin-table        (pc-sample/builtin-table/old))
  505.   (utility-table        (pc-sample/utility-table/old))
  506.   (primitive-table        (pc-sample/primitive-table/old))
  507.   (code-block-table        (pc-sample/code-block-table/old))
  508.   (code-block-buffer/status    (pc-sample/code-block-buffer/status/previous))
  509.   (interp-proc-table        (pc-sample/interp-proc-table/old))
  510.   (interp-proc-buffer/status    (pc-sample/interp-proc-buffer/status/previous))
  511.   (prob-comp-table        (pc-sample/prob-comp-table/old))
  512.   (UFO-table            (pc-sample/UFO-table/old))
  513.   )
  514.  
  515. (define *pc-sample/builtin-table/old* #F)
  516. (define (pc-sample/builtin-table/old)
  517.         *pc-sample/builtin-table/old*)
  518.  
  519. (define *pc-sample/utility-table/old* #F)
  520. (define (pc-sample/utility-table/old)
  521.         *pc-sample/utility-table/old*)
  522.  
  523. (define *pc-sample/primitive-table/old* #F)
  524. (define (pc-sample/primitive-table/old)
  525.         *pc-sample/primitive-table/old*)
  526.  
  527. (define (pc-sample/code-block-table/old)
  528.           (code-block-profile-table/old))
  529.  
  530. (define (pc-sample/code-block-buffer/status/previous)
  531.           (code-block-profile-buffer/status/previous))
  532.  
  533. (define (pc-sample/interp-proc-table/old)
  534.           (interp-proc-profile-table/old))
  535.  
  536. (define (pc-sample/interp-proc-buffer/status/previous)
  537.           (interp-proc-profile-buffer/status/previous))
  538.  
  539. (define *pc-sample/prob-comp-table/old* #F)
  540. (define (pc-sample/prob-comp-table/old)
  541.         *pc-sample/prob-comp-table/old*)
  542.  
  543. (define *pc-sample/UFO-table/old* #F)
  544. (define (pc-sample/UFO-table/old)
  545.         *pc-sample/UFO-table/old*)
  546.  
  547. ;; quirk... synchronize C buffer state w/ Scheme buffer state
  548.  
  549. (define-integrable (fixed-interp-proc-profile-buffer/disable)
  550.                          (interp-proc-profile-buffer/disable))
  551. (define-integrable (fixed-interp-proc-profile-buffer/install buffer)
  552.                          (interp-proc-profile-buffer/install buffer))
  553.  
  554. ;; quirks... for export to pcscobl.scm  [temporary kludges]
  555.  
  556. (define-integrable (fixed-purified-code-block-profile-buffers/disable)
  557.                          (purified-code-block-profile-buffers/disable))
  558. (define-integrable ( fixed-heathen-code-block-profile-buffers/disable)
  559.                          ( heathen-code-block-profile-buffers/disable))
  560.  
  561. (define-integrable (fixed-purified-code-block-profile-buffers/install buff1
  562.                                       buff2)
  563.                          (purified-code-block-profile-buffers/install buff1
  564.                                       buff2))
  565. (define-integrable ( fixed-heathen-code-block-profile-buffers/install buff1
  566.                                       buff2)
  567.                          ( heathen-code-block-profile-buffers/install buff1
  568.                                       buff2))
  569.  
  570. ;; Resetters       TODO: Worry about disabling while copying? Not for now.
  571. ;;                       Maybe employ W/O-INTERRUPTS later. Maybe not.
  572.  
  573. (define (pc-sample/reset #!optional disable?)
  574.   "(#!OPTIONAL disable?)\n\
  575.   Resets all the PC Sampling profile tables and counters, initializing them\n\
  576.   if they have never yet been initialized.\n\
  577.   If the optional DISABLE? argument is supplied, PC Sampling is then\n\
  578.   disabled by virtue of disabling the PC sampling timer interrupt.\n\
  579.   PC sampling can be re-enabled by typing: (PC-SAMPLE/ENABLE)\n\
  580.   \n\
  581.   For more fine grained enabling/disabling of various kinds of sampling data\n\
  582.   consider:\n\
  583.        \n\
  584.      PC-SAMPLE/BUILTIN/ENABLE,           PC-SAMPLE/BUILTIN/DISABLE,\n\
  585.      PC-SAMPLE/UTILITY/ENABLE,           PC-SAMPLE/UTILITY/DISABLE,\n\
  586.      PC-SAMPLE/PRIMITIVE/ENABLE,       PC-SAMPLE/PRIMITIVE/DISABLE,\n\
  587.      PC-SAMPLE/CODE-BLOCK/ENABLE,       PC-SAMPLE/CODE-BLOCK/DISABLE,\n\
  588.      PC-SAMPLE/PURIFIED-CODE-BLOCK/ENABLE, PC-SAMPLE/PURIFIED-CODE-BLOCK/DISABLE,\n\
  589.      PC-SAMPLE/HEATHEN-CODE-BLOCK/ENABLE,  PC-SAMPLE/HEATHEN-CODE-BLOCK/DISABLE,\n\
  590.      PC-SAMPLE/INTERP-PROC/ENABLE,       PC-SAMPLE/INTERP-PROC/DISABLE,\n\
  591.      PC-SAMPLE/PROB-COMP/ENABLE,       PC-SAMPLE/PROB-COMP/DISABLE,\n\
  592.      PC-SAMPLE/UFO/ENABLE,           PC-SAMPLE/UFO/DISABLE\
  593.   "
  594.   (cond ((or (default-object? disable?) (not disable?))
  595.      (pc-sample/builtin/reset)
  596.      (pc-sample/utility/reset)
  597.      (pc-sample/primitive/reset)
  598.      (pc-sample/code-block/reset)
  599.      (pc-sample/interp-proc/reset)
  600.      (pc-sample/prob-comp/reset)
  601.      (pc-sample/UFO/reset)
  602.      ;; resetting in itself does not alter the state of the pc-sampling...
  603.      'RESET)
  604.     (else
  605.      (pc-sample/builtin/reset    disable?)
  606.      (pc-sample/utility/reset    disable?)
  607.      (pc-sample/primitive/reset    disable?)
  608.      (pc-sample/code-block/reset    disable?)
  609.      (pc-sample/interp-proc/reset    disable?)
  610.      (pc-sample/prob-comp/reset    disable?)
  611.      (pc-sample/UFO/reset        disable?)
  612.      (cond ((pc-sample/initialized?)
  613.         (pc-sample/set-state! 'DISABLED)
  614.         'RESET-AND-DISABLED)
  615.            (else
  616.         'STILL-UNINITIALIZED)))))
  617.  
  618. (define  pc-sample/builtin/reset)
  619. (define  pc-sample/utility/reset)
  620. (define  pc-sample/primitive/reset)
  621. (define (pc-sample/code-block/reset #!optional disable?) ; alias
  622.   (if (or (default-object? disable?) (not disable?))
  623.       (code-block-profile-tables/reset)
  624.       (code-block-profile-tables/reset disable?)))
  625. (define (pc-sample/purified-code-block/reset #!optional disable?) ; alias
  626.   (if (or (default-object? disable?) (not disable?))
  627.       (purified-code-block-profile-tables/reset)
  628.       (purified-code-block-profile-tables/reset disable?)))
  629. (define (pc-sample/heathen-code-block/reset #!optional disable?) ; alias
  630.   (if (or (default-object? disable?) (not disable?))
  631.       (heathen-code-block-profile-tables/reset)
  632.       (heathen-code-block-profile-tables/reset disable?)))
  633. (define (pc-sample/interp-proc/reset #!optional disable?) ; alias
  634.   (if (or (default-object? disable?) (not disable?))
  635.       (interp-proc-profile-table/reset)
  636.       (interp-proc-profile-table/reset disable?)))
  637. (define  pc-sample/prob-comp/reset)
  638. (define  pc-sample/UFO/reset)
  639.  
  640. ;; TODO: Would be very nice to maintain a bit-vector of the states of the
  641. ;;       sundry profiling tables: enabled/disabled
  642.  
  643. (define (generate:pc-sample/table-resetter index save-oldy default-table-maker)
  644.   (lambda (#!optional disable?)
  645.     (save-oldy)
  646.     (let ((enabling? (or (default-object? disable?) (not disable?))))
  647.       (vector-set! (get-fixed-objects-vector)
  648.            index
  649.            (if enabling?
  650.                (default-table-maker)
  651.                #F))
  652.       (cond (enabling?
  653.          (cond ((pc-sample/uninitialized?)
  654.             (pc-sample/set-state! 'RESET)))
  655.           'RESET-AND-ENABLED)
  656.         ((pc-sample/uninitialized?)
  657.          'STILL-UNINITIALIZED)
  658.         (else
  659.          ;; TODO: should recognize when the last is disabled and mark
  660.          ;;       overall sampling state as disabled then.
  661.          'RESET-AND-DISABLED)))))
  662.  
  663. ;; TODO: To avoid gratuitous cons-ing, really should always maintain two
  664. ;;       of each table (current and old) then flip the two on reset, re-
  665. ;;       initializing the new current (former old). [double buffer]
  666.  
  667. (define (install-resetters)
  668.   (set! pc-sample/builtin/reset
  669.     (generate:pc-sample/table-resetter
  670.         index:pc-sample/builtin-table
  671.         (lambda () (set! *pc-sample/builtin-table/old*
  672.                  (pc-sample/builtin-table)))
  673.         pc-sample/builtin-table/make))
  674.   (set! pc-sample/utility/reset
  675.     (generate:pc-sample/table-resetter
  676.         index:pc-sample/utility-table
  677.         (lambda () (set! *pc-sample/utility-table/old*
  678.                  (pc-sample/utility-table)))
  679.         pc-sample/utility-table/make))
  680.   (set! pc-sample/primitive/reset
  681.     (generate:pc-sample/table-resetter
  682.         index:pc-sample/primitive-table
  683.         (lambda () (set! *pc-sample/primitive-table/old*
  684.                  (pc-sample/primitive-table)))
  685.         pc-sample/primitive-table/make))
  686.   (set! pc-sample/prob-comp/reset
  687.     (generate:pc-sample/table-resetter
  688.         index:pc-sample/prob-comp-table
  689.         (lambda () (set! *pc-sample/prob-comp-table/old*
  690.                  (pc-sample/prob-comp-table)))
  691.         pc-sample/prob-comp-table/make))
  692.   (set! pc-sample/UFO/reset
  693.     (generate:pc-sample/table-resetter
  694.         index:pc-sample/UFO-table
  695.         (lambda () (set! *pc-sample/UFO-table/old*
  696.                  (pc-sample/UFO-table)))
  697.         pc-sample/UFO-table/make))
  698.   )
  699.  
  700. ;; Enablers/Disablers
  701.  
  702. (define (pc-sample/enable)
  703.   "()\n\
  704.   Resets all PC sampling tables and counters and re-starts the PC\n\
  705.   sampling periodic interrupt timer.\n\
  706.   The old state/status of the PC sampling tables and counters can be\n\
  707.   monitored by invoking: (PC-SAMPLE/STATUS/PREVIOUS).\n\
  708.   The evolving state of the PC sampling tables and counters may be monitored\n\
  709.   by invoking: (PC-SAMPLE/STATUS).\n\
  710.   \n\
  711.   For more fine grained enabling/disabling of various kinds of sampling data\n\
  712.   consider:\n\
  713.        \n\
  714.      PC-SAMPLE/BUILTIN/ENABLE,           PC-SAMPLE/BUILTIN/DISABLE,\n\
  715.      PC-SAMPLE/UTILITY/ENABLE,           PC-SAMPLE/UTILITY/DISABLE,\n\
  716.      PC-SAMPLE/PRIMITIVE/ENABLE,       PC-SAMPLE/PRIMITIVE/DISABLE,\n\
  717.      PC-SAMPLE/CODE-BLOCK/ENABLE,       PC-SAMPLE/CODE-BLOCK/DISABLE,\n\
  718.      PC-SAMPLE/PURIFIED-CODE-BLOCK/ENABLE, PC-SAMPLE/PURIFIED-CODE-BLOCK/DISABLE,\n\
  719.      PC-SAMPLE/HEATHEN-CODE-BLOCK/ENABLE,  PC-SAMPLE/HEATHEN-CODE-BLOCK/DISABLE,\n\
  720.      PC-SAMPLE/INTERP-PROC/ENABLE,       PC-SAMPLE/INTERP-PROC/DISABLE,\n\
  721.      PC-SAMPLE/PROB-COMP/ENABLE,       PC-SAMPLE/PROB-COMP/DISABLE,\n\
  722.      PC-SAMPLE/UFO/ENABLE,           PC-SAMPLE/UFO/DISABLE\
  723.   "
  724.         (pc-sample/reset))
  725.  
  726. (define (pc-sample/disable)
  727.   "()\n\
  728.   Resets all the PC sampling tables and counters then disables the PC\n\
  729.   sampling periodic interrupt timer.\n\
  730.   The old state/status of the PC sampling tables and counters can be\n\
  731.   monitored by invoking: (PC-SAMPLE/STATUS/PREVIOUS).\n\
  732.   \n\
  733.   For more fine grained enabling/disabling of various kinds of sampling data\n\
  734.   consider:\n\
  735.        \n\
  736.      PC-SAMPLE/BUILTIN/ENABLE,           PC-SAMPLE/BUILTIN/DISABLE,\n\
  737.      PC-SAMPLE/UTILITY/ENABLE,           PC-SAMPLE/UTILITY/DISABLE,\n\
  738.      PC-SAMPLE/PRIMITIVE/ENABLE,       PC-SAMPLE/PRIMITIVE/DISABLE,\n\
  739.      PC-SAMPLE/CODE-BLOCK/ENABLE,       PC-SAMPLE/CODE-BLOCK/DISABLE,\n\
  740.      PC-SAMPLE/PURIFIED-CODE-BLOCK/ENABLE, PC-SAMPLE/PURIFIED-CODE-BLOCK/DISABLE,\n\
  741.      PC-SAMPLE/HEATHEN-CODE-BLOCK/ENABLE,  PC-SAMPLE/HEATHEN-CODE-BLOCK/DISABLE,\n\
  742.      PC-SAMPLE/INTERP-PROC/ENABLE,       PC-SAMPLE/INTERP-PROC/DISABLE,\n\
  743.      PC-SAMPLE/PROB-COMP/ENABLE,       PC-SAMPLE/PROB-COMP/DISABLE,\n\
  744.      PC-SAMPLE/UFO/ENABLE,           PC-SAMPLE/UFO/DISABLE\
  745.   "
  746.         (pc-sample/reset 'DISABLE))
  747.  
  748.  
  749. (define (pc-sample/builtin/enable)     (pc-sample/builtin/reset))
  750. (define (pc-sample/builtin/disable)    (pc-sample/builtin/reset 'DISABLE))
  751.  
  752. (define (pc-sample/utility/enable)     (pc-sample/utility/reset))
  753. (define (pc-sample/utility/disable)    (pc-sample/utility/reset 'DISABLE))
  754.  
  755. (define (pc-sample/primitive/enable)   (pc-sample/primitive/reset))
  756. (define (pc-sample/primitive/disable)  (pc-sample/primitive/reset 'DISABLE))
  757.  
  758. (define (pc-sample/code-block/enable)  (code-block-profile-tables/enable)) ;cob
  759. (define (pc-sample/code-block/disable) (code-block-profile-tables/disable));cob
  760.  
  761. (define (pc-sample/purified-code-block/enable) (purified-code-block-profile-tables/enable)) ;cob
  762. (define (pc-sample/purified-code-block/disable)(purified-code-block-profile-tables/disable));cob
  763.  
  764. (define (pc-sample/heathen-code-block/enable)   (heathen-code-block-profile-tables/enable)) ;cob
  765. (define (pc-sample/heathen-code-block/disable)  (heathen-code-block-profile-tables/disable));cob
  766.  
  767. (define (pc-sample/interp-proc/enable)  (interp-proc-profile-table/enable)) ;clo
  768. (define (pc-sample/interp-proc/disable) (interp-proc-profile-table/disable)) ;clo
  769.  
  770. (define (pc-sample/prob-comp/enable)  (pc-sample/prob-comp/reset))
  771. (define (pc-sample/prob-comp/disable) (pc-sample/prob-comp/reset 'DISABLE))
  772.  
  773. (define (pc-sample/UFO/enable)        (pc-sample/UFO/reset))
  774. (define (pc-sample/UFO/disable)       (pc-sample/UFO/reset 'DISABLE))
  775.  
  776. #|
  777.  |
  778.  |       --------------------------------------------------
  779.  |       --------------------------------------------------
  780.  |
  781.  |         THIS PAGE INTENTIONALLY LEFT VERY NEARLY BLANK
  782.  |
  783.  |       --------------------------------------------------
  784.  |       --------------------------------------------------
  785.  |
  786.  |  Seriously, though, user interface hacks moved to a separate file 'cause
  787.  |  I could not decide on a stable set of basic display mechanisms... I leave
  788.  |  it to the SWAT Team to deal with all that rot. For now, see PCDISP.SCM.
  789.  |
  790.  |#
  791.  
  792. ;;; Call-with-pc-sampling
  793.  
  794. (define *pc-sample/top-level?*      #T)
  795. (define *pc-sample/wan-sampling?*   #F)    ; With-Absolutely-No-PC-Sampling
  796. (define *pc-sample/timing?*         #F)
  797. (define *pc-sample/timing-deficit?* #F)
  798.  
  799. (define *pc-sample/last-sampling-duration-deficit*       0 )
  800. (define *pc-sample/last-sampling-duration-deficit/no-gc* 0.)
  801. (define *pc-sample/last-sampling-duration-deficit/real*  0 )
  802.         
  803.  
  804. (define (call-with-pc-sampling thunk #!optional untimed? displayer)
  805.   (let ((restart? (and (pc-sample/running?)
  806.                (begin (pc-sample/stop) ; stop sampling until in d-wind
  807.                   #T))))
  808.     (dynamic-wind
  809.      (lambda () 'restart-sampling-even-when-thunk-craps-out)
  810.      (lambda ()
  811.        (let* ((tople?  *pc-sample/top-level?*)
  812.           (defle?  *pc-sample/timing-deficit?*)
  813.           (timing? *pc-sample/timing?*)
  814.           (timing-up?  (and timing? (not defle?)))
  815.           (wanna-time? (or (default-object? untimed?) (not untimed?)))
  816.           (time-it? (and      wanna-time? (not timing?)))
  817.           (deficit? (and (not wanna-time?)     timing? ))
  818.           (neficit? (and time-it? defle?)) ; nix enclosing deficit charge
  819.           )
  820.      (cond (tople?            ; tolerate nesting of cwpcs
  821.         (pc-sample/reset)))    ; start afresh inside thunk
  822.      (cond ((and tople? time-it?)    ; erase deficit...
  823.         ;;... by first killing all the liberals
  824.         '(for-each (lambda (x) (kill x)) *liberals*)
  825.         (set! *pc-sample/last-sampling-duration-deficit*       0 )
  826.         (set! *pc-sample/last-sampling-duration-deficit/no-gc* 0.)
  827.         (set! *pc-sample/last-sampling-duration-deficit/real*  0 )))
  828.      (with-values 
  829.          (lambda ()
  830.            ;; Uhm... would wrap fluid-let around d-wind body but then it
  831.            ;;        would be included in the sample/timing: not desirable.
  832.            (fluid-let ((*pc-sample/top-level?* #F)
  833.                (*pc-sample/timing?*         (or time-it? timing?))
  834.                (*pc-sample/timing-deficit?* (or deficit?  defle?)))
  835.          (dynamic-wind (lambda () (or *pc-sample/wan-sampling?*
  836.                           (pc-sample/start)))
  837.                    (if (eq? wanna-time? timing-up?)   
  838.                    (lambda () (values (thunk)
  839.                               'runtime-fnord!
  840.                               'process-time-fnord!
  841.                               'real-time-fnord!))
  842.                    (lambda ()
  843.                      (let* ((start-rt  (     runtime      ))
  844.                         (start-ptc (process-time-clock))
  845.                         (start-rtc (   real-time-clock))
  846.                         (result    (thunk))
  847.                         (  end-rt  (     runtime      ))
  848.                         (  end-ptc (process-time-clock))
  849.                         (  end-rtc (   real-time-clock)))
  850.                        (pc-sample/stop)    ; dun sample following
  851.                        (let ((p-s/no-gc (- end-rt  start-rt ))
  852.                          (p-ticks   (- end-ptc start-ptc))
  853.                          (r-ticks   (- end-rtc start-rtc)))
  854.                      (values result
  855.                          p-s/no-gc
  856.                          p-ticks
  857.                          r-ticks)))))
  858.                    (lambda () (pc-sample/stop)))))
  859.        (lambda (result process-secs/no-gc process-ticks real-ticks)
  860.          ;; Probably not the best control paradigm in the world.
  861.          ;; If you know of a more elegant solution, I'd sure like
  862.          ;;  to hear it.   -ziggy@ai.mit.edu
  863.          (cond
  864.           ((or deficit? neficit?)
  865.            (let ((t:mixin (if deficit? int:+ int:-))
  866.              (s:mixin (if deficit? flo:+ flo:-)))
  867.          (set!          *pc-sample/last-sampling-duration-deficit*
  868.                (t:mixin *pc-sample/last-sampling-duration-deficit*
  869.                 process-ticks))
  870.          (set!          *pc-sample/last-sampling-duration-deficit/no-gc*
  871.                (s:mixin *pc-sample/last-sampling-duration-deficit/no-gc*
  872.                 process-secs/no-gc))
  873.          (set!          *pc-sample/last-sampling-duration-deficit/real*
  874.                (t:mixin *pc-sample/last-sampling-duration-deficit/real*
  875.                 real-ticks)))))
  876.          (cond ((and tople? time-it?)
  877.             (time-display thunk
  878.                   process-ticks
  879.                   process-secs/no-gc
  880.                   real-ticks)))
  881.          (cond (tople?
  882.             (cond ((default-object? displayer)
  883.                (*pc-sample/default-status-displayer*))
  884.               (displayer
  885.                (displayer)))))
  886.          result))))
  887.      (lambda ()
  888.        (cond (restart?
  889.           (pc-sample/start)))))))
  890.  
  891. ;;; Time Display
  892.  
  893. (define *pc-sample/time-display?*                  #T)
  894. (define *pc-sample/time-display/running-time-too?* #T)
  895. (define *pc-sample/time-display/non-gc-time-too?*  #T)
  896.  
  897. (define *pc-sample/time-display/real-time-too?*    #F)
  898.  
  899. (define (time-display thunk p-ticks p-secs/no-gc r-ticks)
  900.   ;; not integrable so customizable
  901.   (cond
  902.    (*pc-sample/time-display?*
  903.     (let ((stealth-t       *pc-sample/last-sampling-duration-deficit*      )
  904.       (stealth-s/no-gc *pc-sample/last-sampling-duration-deficit/no-gc*)
  905.       (stealth-t/real  *pc-sample/last-sampling-duration-deficit/real* ))
  906.       (let ((  delta-t       (int:- p-ticks      stealth-t      ))
  907.         (  delta-s/no-gc (flo:- p-secs/no-gc stealth-s/no-gc))
  908.         (  delta-t/real  (int:- r-ticks      stealth-t/real )))
  909.     (let ((delta-s
  910.            (flo:round-to-magnification
  911.         (internal-time/ticks->seconds delta-t     )
  912.         *flo:round-to-magnification/scale*))
  913.           (delta-s/real
  914.            (flo:round-to-magnification
  915.         (internal-time/ticks->seconds delta-t/real)
  916.         *flo:round-to-magnification/scale*)))
  917.       (let ((delta-s/gc-only (flo:- delta-s delta-s/no-gc)))
  918.         (for-each
  919.          display
  920.          `("\n;;;"
  921.            "\n;;; Timed funcall of " ,thunk
  922.            "\n;;;   took (in secs) " ,delta-s
  923.            ,@(if *pc-sample/time-display/running-time-too?*
  924.              `("\n;;;         running: " ,delta-s/no-gc)
  925.              '())
  926.            ,@(if *pc-sample/time-display/non-gc-time-too?*
  927.              `("\n;;;         GC time: " ,delta-s/gc-only)
  928.              '())
  929.            ,@(if *pc-sample/time-display/real-time-too?*
  930.              `("\n;;; wall clock time: " ,delta-s/real)
  931.              '())
  932.            "\n;;;\n"
  933.            ,@(if (fix:zero? stealth-t)
  934.              '()
  935.              (let ((stealth-s
  936.                 (flo:round-to-magnification
  937.                  (internal-time/ticks->seconds stealth-t     )
  938.                  *flo:round-to-magnification/scale*))
  939.                (stealth-s/real
  940.                 (flo:round-to-magnification
  941.                  (internal-time/ticks->seconds stealth-t/real)
  942.                  *flo:round-to-magnification/scale*)))
  943.                (let ((stealth-s/gc-only
  944.                   (flo:- stealth-s stealth-s/no-gc)))
  945.              `("\n;;;      discounting " ,stealth-s
  946.                ,@(if *pc-sample/time-display/running-time-too?*
  947.                  `("\n;;;         running: " ,stealth-s/no-gc)
  948.                  '())
  949.                ,@(if *pc-sample/time-display/non-gc-time-too?*
  950.                  `("\n;;;         GC time: " ,stealth-s/gc-only)
  951.                  '())
  952.                ,@(if *pc-sample/time-display/real-time-too?*
  953.                  `("\n;;; wall clock time: " ,stealth-s/real)
  954.                  '())
  955.                "\n;;;      seconds spent in clandestine activities."
  956.                "\n;;;\n")))))
  957.          ))))))))
  958.  
  959. (define-integrable (flo:round-to-magnification num magnification)
  960.   (flo:/ (flo:round (flo:* num magnification)) magnification))
  961.  
  962. (define *flo:round-to-magnification/scale* 1000000.)
  963.  
  964.  
  965. (define (call-with-builtin-pc-sampling thunk)
  966.   (call-with-pc-sampling thunk pc-sample/builtin/status/display))
  967.  
  968. (define (call-with-utility-pc-sampling thunk)
  969.   (call-with-pc-sampling thunk pc-sample/utility/status/display))
  970.  
  971. (define (call-with-primitive-pc-sampling thunk)
  972.   (call-with-pc-sampling thunk pc-sample/primitive/status/display))
  973.  
  974. (define (call-with-code-block-pc-sampling thunk)
  975.   (call-with-pc-sampling thunk pc-sample/code-block/status/display))
  976.  
  977. (define (call-with-interp-proc-pc-sampling thunk)
  978.   (call-with-pc-sampling thunk pc-sample/interp-proc/status/display))
  979.  
  980. (define (call-with-prob-comp-pc-sampling thunk)
  981.   (call-with-pc-sampling thunk pc-sample/prob-comp/status/display))
  982.  
  983. (define (call-with-UFO-pc-sampling thunk)
  984.   (call-with-pc-sampling thunk pc-sample/UFO/status/display))
  985.  
  986. ;;; With-pc-sampling
  987.  
  988. (define (with-pc-sampling                  proc . args)
  989.    (call-with-pc-sampling        (lambda () (apply proc     args))))
  990. (define (with-builtin-pc-sampling              proc . args)
  991.    (call-with-builtin-pc-sampling    (lambda () (apply proc     args))))
  992. (define (with-utility-pc-sampling              proc . args)
  993.    (call-with-utility-pc-sampling    (lambda () (apply proc     args))))
  994. (define (with-primitive-pc-sampling              proc . args)
  995.    (call-with-primitive-pc-sampling    (lambda () (apply proc     args))))
  996. (define (with-code-block-pc-sampling              proc . args)
  997.    (call-with-code-block-pc-sampling    (lambda () (apply proc     args))))
  998. (define (with-interp-proc-pc-sampling              proc . args)
  999.    (call-with-interp-proc-pc-sampling    (lambda () (apply proc     args))))
  1000. (define (with-prob-comp-pc-sampling              proc . args)
  1001.    (call-with-prob-comp-pc-sampling    (lambda () (apply proc     args))))
  1002. (define (with-UFO-pc-sampling                  proc . args)
  1003.    (call-with-UFO-pc-sampling        (lambda () (apply proc     args))))
  1004.  
  1005. ;;; Call-without-pc-sampling
  1006.  
  1007. (define (call-without-pc-sampling thunk #!optional untimed?)
  1008.   ;; If UNTIMED? then subtract time in thunk from total time.
  1009.   (let ((restart? (and (pc-sample/running?)
  1010.                (begin (pc-sample/stop) ; stop ASAP
  1011.                   #T))))
  1012.     (dynamic-wind
  1013.      (lambda () 'restart-sampling-even-when-thunk-craps-out)
  1014.      (lambda ()
  1015.        (let* ((tople?  *pc-sample/top-level?*)
  1016.           (defle?  *pc-sample/timing-deficit?*)
  1017.           (timing? *pc-sample/timing?*)
  1018.           (timing-up?  (and timing? (not defle?)))
  1019.           (wanna-time? (or (default-object? untimed?) (not untimed?)))
  1020.           (time-it? (and      wanna-time? (not timing?)))
  1021.           (deficit? (and (not wanna-time?)     timing? ))
  1022.           (neficit? (and time-it? defle?)) ; nix enclosing deficit charge
  1023.           )
  1024.      (cond ((and tople? time-it?)    ; erase deficit...
  1025.         ;;... by first killing all the liberals
  1026.         '(for-each (lambda (x) (kill x)) *liberals*)
  1027.         (set! *pc-sample/last-sampling-duration-deficit*       0 )
  1028.         (set! *pc-sample/last-sampling-duration-deficit/no-gc* 0.)
  1029.         (set! *pc-sample/last-sampling-duration-deficit/real*  0 )))
  1030.      ;; Really just want fluid-let around THUNK calls, but what the hay.
  1031.      (fluid-let ((*pc-sample/top-level?*      #F)
  1032.              (*pc-sample/timing?*         (or time-it? timing?))
  1033.              (*pc-sample/timing-deficit?* (or deficit?  defle?)))
  1034.        (if (eq? wanna-time? timing-up?)
  1035.            (thunk)
  1036.            (let* ((start-rt  (     runtime      ))
  1037.               (start-ptc (process-time-clock))
  1038.               (start-rtc (   real-time-clock))
  1039.               (result    (thunk))
  1040.               (  end-rt  (     runtime      ))
  1041.               (  end-ptc (process-time-clock))
  1042.               (  end-rtc (   real-time-clock)))
  1043.          (let ((process-secs/no-gc (- end-rt  start-rt ))
  1044.                (process-ticks      (- end-ptc start-ptc))
  1045.                (real-ticks         (- end-rtc start-rtc)))
  1046.            (cond
  1047.             ((or deficit? neficit?)
  1048.              (let ((t:mixin (if deficit? int:+ int:-))
  1049.                (s:mixin (if deficit? flo:+ flo:-)))
  1050.                (set!     *pc-sample/last-sampling-duration-deficit*
  1051.             (t:mixin *pc-sample/last-sampling-duration-deficit*
  1052.                  process-ticks))
  1053.                (set!     *pc-sample/last-sampling-duration-deficit/no-gc*
  1054.             (s:mixin *pc-sample/last-sampling-duration-deficit/no-gc*
  1055.                  process-secs/no-gc))
  1056.                (set!     *pc-sample/last-sampling-duration-deficit/real*
  1057.                 (t:mixin *pc-sample/last-sampling-duration-deficit/real*
  1058.                  real-ticks)))))
  1059.            (cond ((and tople? time-it?)
  1060.               (time-display thunk
  1061.                     process-ticks
  1062.                     process-secs/no-gc
  1063.                     real-ticks))))
  1064.          result)))))
  1065.      (lambda ()
  1066.        (cond (restart?
  1067.           (pc-sample/start)))))))
  1068.  
  1069. (define (call-without-builtin-pc-sampling thunk)
  1070.   (call-without-pc-sampling thunk pc-sample/builtin/status/display))
  1071.  
  1072. (define (call-without-utility-pc-sampling thunk)
  1073.   (call-without-pc-sampling thunk pc-sample/utility/status/display))
  1074.  
  1075. (define (call-without-primitive-pc-sampling thunk)
  1076.   (call-without-pc-sampling thunk pc-sample/primitive/status/display))
  1077.  
  1078. (define (call-without-code-block-pc-sampling thunk)
  1079.   (call-without-pc-sampling thunk pc-sample/code-block/status/display))
  1080.  
  1081. (define (call-without-interp-proc-pc-sampling thunk)
  1082.   (call-without-pc-sampling thunk pc-sample/interp-proc/status/display))
  1083.  
  1084. (define (call-without-prob-comp-pc-sampling thunk)
  1085.   (call-without-pc-sampling thunk pc-sample/prob-comp/status/display))
  1086.  
  1087. (define (call-without-UFO-pc-sampling thunk)
  1088.   (call-without-pc-sampling thunk pc-sample/UFO/status/display))
  1089.  
  1090. ;;; Without-pc-sampling
  1091.  
  1092. (define (without-pc-sampling                   proc . args)
  1093.    (call-without-pc-sampling         (lambda () (apply proc      args))))
  1094. (define (without-builtin-pc-sampling               proc . args)
  1095.    (call-without-builtin-pc-sampling     (lambda () (apply proc      args))))
  1096. (define (without-utility-pc-sampling               proc . args)
  1097.    (call-without-utility-pc-sampling     (lambda () (apply proc      args))))
  1098. (define (without-primitive-pc-sampling               proc . args)
  1099.    (call-without-primitive-pc-sampling     (lambda () (apply proc      args))))
  1100. (define (without-code-block-pc-sampling               proc . args)
  1101.    (call-without-code-block-pc-sampling     (lambda () (apply proc      args))))
  1102. (define (without-interp-proc-pc-sampling           proc . args)
  1103.    (call-without-interp-proc-pc-sampling (lambda () (apply proc      args))))
  1104. (define (without-prob-comp-pc-sampling               proc . args)
  1105.    (call-without-prob-comp-pc-sampling     (lambda () (apply proc      args))))
  1106. (define (without-UFO-pc-sampling               proc . args)
  1107.    (call-without-UFO-pc-sampling     (lambda () (apply proc      args))))
  1108.  
  1109. ;;; Call-with-absolutely-no-pc-sampling
  1110.  
  1111. (define (call-with-absolutely-no-pc-sampling thunk #!optional untimed?)
  1112.   (let ((restart? (and (pc-sample/running?)
  1113.                (begin (pc-sample/stop) ; stop ASAP
  1114.                   #T))))
  1115.     (dynamic-wind
  1116.      (lambda () 'restart-sampling-even-when-thunk-craps-out)
  1117.      (lambda () (let ((untimed-arg (and (not (default-object? untimed?))
  1118.                     untimed?)))
  1119.           (fluid-let ((*pc-sample/wan-sampling?* #T))
  1120.             (call-without-pc-sampling thunk untimed-arg))))
  1121.      (lambda () (cond (restart?
  1122.                (pc-sample/start)))))))
  1123.  
  1124. (define (call-with-absolutely-no-builtin-pc-sampling thunk)
  1125.   (call-with-absolutely-no-pc-sampling thunk 
  1126.                        pc-sample/builtin/status/display))
  1127.  
  1128. (define (call-with-absolutely-no-utility-pc-sampling thunk)
  1129.   (call-with-absolutely-no-pc-sampling thunk
  1130.                        pc-sample/utility/status/display))
  1131.  
  1132. (define (call-with-absolutely-no-primitive-pc-sampling thunk)
  1133.   (call-with-absolutely-no-pc-sampling thunk
  1134.                        pc-sample/primitive/status/display))
  1135.  
  1136. (define (call-with-absolutely-no-code-block-pc-sampling thunk)
  1137.   (call-with-absolutely-no-pc-sampling thunk
  1138.                        pc-sample/code-block/status/display))
  1139.  
  1140. (define (call-with-absolutely-no-interp-proc-pc-sampling thunk)
  1141.   (call-with-absolutely-no-pc-sampling thunk
  1142.                        pc-sample/interp-proc/status/display))
  1143.  
  1144. (define (call-with-absolutely-no-prob-comp-pc-sampling thunk)
  1145.   (call-with-absolutely-no-pc-sampling thunk
  1146.                        pc-sample/prob-comp/status/display))
  1147.  
  1148. (define (call-with-absolutely-no-UFO-pc-sampling thunk)
  1149.   (call-with-absolutely-no-pc-sampling thunk
  1150.                        pc-sample/UFO/status/display))
  1151.  
  1152. ;;; With-absolutely-no-pc-sampling
  1153.  
  1154. (define (with-absolutely-no-pc-sampling                      proc . args)
  1155.    (call-with-absolutely-no-pc-sampling            (lambda () (apply proc   args))))
  1156. (define (with-absolutely-no-builtin-pc-sampling                  proc . args)
  1157.    (call-with-absolutely-no-builtin-pc-sampling        (lambda () (apply proc   args))))
  1158. (define (with-absolutely-no-utility-pc-sampling                  proc . args)
  1159.    (call-with-absolutely-no-utility-pc-sampling        (lambda () (apply proc   args))))
  1160. (define (with-absolutely-no-primitive-pc-sampling              proc . args)
  1161.    (call-with-absolutely-no-primitive-pc-sampling   (lambda () (apply proc   args))))
  1162. (define (with-absolutely-no-code-block-pc-sampling              proc . args)
  1163.    (call-with-absolutely-no-code-block-pc-sampling  (lambda () (apply proc   args))))
  1164. (define (with-absolutely-no-interp-proc-pc-sampling              proc . args)
  1165.    (call-with-absolutely-no-interp-proc-pc-sampling (lambda () (apply proc   args))))
  1166. (define (with-absolutely-no-prob-comp-pc-sampling              proc . args)
  1167.    (call-with-absolutely-no-prob-comp-pc-sampling   (lambda () (apply proc   args))))
  1168. (define (with-absolutely-no-UFO-pc-sampling                  proc . args)
  1169.    (call-with-absolutely-no-UFO-pc-sampling        (lambda () (apply proc   args))))
  1170.  
  1171. ;;; Install
  1172.  
  1173. (define *pc-sample/install-verbosity?* #F)
  1174.  
  1175. (define (install-dynamic-microcode)
  1176.   (let ((pcs-directory (system-library-directory-pathname "pcsample")))
  1177.     (cond (*pc-sample/install-verbosity?*
  1178.        (newline)
  1179.        (display "Installing dynamic microcode...")
  1180.        (newline)))
  1181.     (cond ((not (implemented-primitive-procedure? ; avoid ucode re-loads
  1182.          (make-primitive-procedure '%pc-sample/install-microcode 0)))
  1183.        (let ((filename
  1184.           (->namestring (merge-pathnames "pcsdld.sl" pcs-directory))))
  1185.          (newline)
  1186.          (write-string ";Loading ")
  1187.          (write-string filename)
  1188.          (let* ((handle ((make-primitive-procedure 'load-object-file)
  1189.                  filename))
  1190.             (cth ((make-primitive-procedure 'object-lookup-symbol)
  1191.               handle "initialize_pcsample_primitives" 0)))
  1192.            (write-string " -- done")
  1193.            ((make-primitive-procedure 'invoke-c-thunk) cth)))))))
  1194.  
  1195. (define (pc-sample/install-microcode-frobs)
  1196.   (cond (*pc-sample/install-verbosity?*
  1197.      (newline)
  1198.      (display "Installing microcode frobs...")
  1199.      (newline)))
  1200.   (let ((win? (%pc-sample/install-microcode)))
  1201.     (cond ((not win?)
  1202.        (error "\nCould not install PC Sample GC synch hooks.\
  1203.                    \nGame over."))))
  1204.   unspecific)
  1205.  
  1206. (define (pc-sample/disable-microcode-frobs)
  1207.   (cond (*pc-sample/install-verbosity?*
  1208.      (newline)
  1209.      (display "Disabling microcode frobs...")
  1210.      (newline)))
  1211.   (let ((win? (%pc-sample/disable-microcode)))
  1212.     (cond ((not win?)
  1213.        (error "\nCould not disable PC Sample GC synch hooks.\
  1214.                    \nGame over."))))
  1215.   unspecific)
  1216.  
  1217. (define (install)
  1218.   ;; Dynamically load microcode
  1219.   (install-dynamic-microcode)
  1220.   (add-event-receiver! event:after-restore install-dynamic-microcode)
  1221.   ;; Install runtime stuff...
  1222.   (install-indices)
  1223.   (install-accessors)
  1224.   (install-makers)
  1225.   (install-resetters)
  1226.   (install-profile-hash-table)
  1227.   ;; Install microcode structures
  1228.   (pc-sample/install-microcode-frobs)
  1229.   (add-event-receiver! event:after-restore pc-sample/install-microcode-frobs)
  1230.   (add-event-receiver! event:before-exit   pc-sample/disable-microcode-frobs)
  1231.   ;; HACK: reinitialize the variable when this code is disk-restored so
  1232.   ;;       we can post way-cool bands to the Internet News servers.
  1233.   (install-current-user-name-promise)
  1234.   (add-event-receiver! event:after-restore install-current-user-name-promise)
  1235.   ;; Stop sampling at inauspicious occassions...
  1236.   (add-event-receiver! event:after-restore pc-sample/stop)
  1237.   (add-event-receiver! event:before-exit   pc-sample/stop)
  1238.   )
  1239.  
  1240. ;;; fini
  1241.