/usr/share/scheme48-1.9/env/profile-instr.scm is in scheme48 1.9-5.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 | ; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Marcel Turino, Manuel Dietrich
; This optimizer does the instrumentation for the exact call profiler,
; by calling the profiler before executing the real function code.
; It therefore needs a reference to the profile-count procedure,
; which is exported by the profiler structure.
(set-optimizer! 'profiler-instrumentation
(lambda (forms package)
(get-pcount-name!)
(map (lambda (form)
(instrument-form (force-node form)))
forms)))
;;; returns a bound name-node for "name" out of "env"
(define (expand-name name env)
(let ((binding (generic-lookup env name)))
(if (node? binding)
binding
(let ((node (make-node operator/name name)))
(node-set! node 'binding (or binding 'unbound))
node))))
;;; caches the reference to the profile-count function
(define *pcount-name* #f)
(define (get-pcount-name!)
(let* ((p (environment-ref (config-package) 'profiler))
(name (expand-name 'profile-count p)))
(set! *pcount-name* name)))
(define (instrument-form node)
(let ((out (current-noise-port))
(form (node-form node)))
(if (define-node? node)
(begin
(make-similar-node node
`(define ,(cadr form)
,(instrument-node (caddr form)))))
node)))
(define (instrument-node node)
(cond
((node? node)
((operator-table-ref instrumentors (node-operator-id node)) node))
((list? node)
(instrument-list node))
(else
node)))
(define (instrument-list nodes)
(if (list? nodes)
(map (lambda (node)
(instrument-node node))
nodes)
nodes))
(define (no-instrumentation node)
(let ((form (node-form node)))
(make-similar-node node (instrument-list form))))
(define instrumentors
(make-operator-table no-instrumentation))
(define (define-instrumentor name proc)
(operator-define! instrumentors name #f proc))
(define-instrumentor 'literal no-instrumentation)
(define-instrumentor 'quote no-instrumentation)
(define-instrumentor 'primitive-procedure no-instrumentation)
(define-instrumentor 'call no-instrumentation)
(define-instrumentor 'name no-instrumentation)
(define-instrumentor 'set! no-instrumentation)
(define-instrumentor 'loophole no-instrumentation)
(define-instrumentor 'letrec no-instrumentation)
(define-instrumentor 'pure-letrec no-instrumentation)
(define-instrumentor 'lambda
(lambda (node)
(let* ((form (node-form node))
(param (cadr form))
(body (cddr form)))
(make-similar-node node
`(lambda ,param
,(make-node operator/begin
`(begin
,(make-node operator/call
(list *pcount-name*))
,@(instrument-list body))))))))
|