1 /* -*-C-*-
2
3 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
4 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
5 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts
6 Institute of Technology
7
8 This file is part of MIT/GNU Scheme.
9
10 MIT/GNU Scheme is free software; you can redistribute it and/or modify
11 it under the terms of the GNU General Public License as published by
12 the Free Software Foundation; either version 2 of the License, or (at
13 your option) any later version.
14
15 MIT/GNU Scheme is distributed in the hope that it will be useful, but
16 WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 General Public License for more details.
19
20 You should have received a copy of the GNU General Public License
21 along with MIT/GNU Scheme; if not, write to the Free Software
22 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
23 USA.
24
25 */
26
27 /* PCSIPROC.C -- defines PC Sample subroutines for profiling interp-procs *\
28 \* (a.k.a. interpreted procedures) within pcsample.c */
29
30 /*****************************************************************************/
31 #ifdef REALLY_INCLUDE_PROFILE_CODE /* scan_defines concession */
32
33 #include <microcode/lookup.h> /* For AUX_LIST_TYPE */
34
35 /*!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*\
36 * TODO:
37 *
38 * - Maybe flatten number of primitives?
39 *
40 \*!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*/
41
42 /*===========================================================================*\
43 * Interp-Proc Profile Buffer is for buffering sightings of interpreted procs *
44 * (a.k.a. compounds) until they can be spilled into the Interp-Proc Profile *
45 * Table. *
46 * *
47 * This hairy mess is to reduce the overhead of passing interpreted procs up *
48 * to Scheme (where they can be entered into a hash table)... only once the *
49 * buffer is nearly filled does an interrupt get generated to spill the buffer*
50 * contents into the profile hashtable. *
51 \*===========================================================================*/
52
53 /*****************************************************************************
54 * Interp-Proc Profile Buffer consists of a vector of slots and a handfull of
55 * state variables...
56 */
57
58 static struct profile_buffer_state interp_proc_profile_buffer_state;
59
60 static void
DEFUN_VOID(init_IPPB_profile_buffer_state)61 DEFUN_VOID (init_IPPB_profile_buffer_state)
62 {
63 init_profile_uni_buffer_state (&interp_proc_profile_buffer_state,
64 " IPPB", /* name */
65 PC_Sample_Interp_Proc_Buffer, /* ID */
66 8*128, /* slack */
67 128, /* slack_inc */
68 INT_IPPB_Flush, /* flush_INT */
69 INT_IPPB_Extend /* extnd_INT */
70 );
71 }
72
73 /* convenient shorthand for use in primitives below... */
74
75 #define IPPB_name \
76 (interp_proc_profile_buffer_state . name)
77 #define IPPB_ID \
78 (interp_proc_profile_buffer_state . ID)
79 #define IPPB_enabled \
80 (interp_proc_profile_buffer_state . enabled_flag)
81 #define IPPB_buffer \
82 (interp_proc_profile_buffer_state . buffer)
83 #define IPPB_length \
84 (interp_proc_profile_buffer_state . length)
85 #define IPPB_next_empty_slot_index \
86 (interp_proc_profile_buffer_state . next_empty_slot_index)
87 #define IPPB_slack \
88 (interp_proc_profile_buffer_state . slack)
89 #define IPPB_slack_increment \
90 (interp_proc_profile_buffer_state . slack_increment)
91 #define IPPB_flush_INT \
92 (interp_proc_profile_buffer_state . flush_INT)
93 #define IPPB_extend_INT \
94 (interp_proc_profile_buffer_state . extend_INT)
95 #define IPPB_flush_noisy \
96 (interp_proc_profile_buffer_state . flush_noisy_flag)
97 #define IPPB_extend_noisy \
98 (interp_proc_profile_buffer_state . extend_noisy_flag)
99 #define IPPB_overflow_noisy \
100 (interp_proc_profile_buffer_state . overflow_noisy_flag)
101 #define IPPB_flush_immediate \
102 (interp_proc_profile_buffer_state . flush_immed_flag)
103 #define IPPB_debugging \
104 (interp_proc_profile_buffer_state . debug_flag)
105 #define IPPB_monitoring \
106 (interp_proc_profile_buffer_state . monitor_flag)
107 #define IPPB_flush_count \
108 (interp_proc_profile_buffer_state . flush_count)
109 #define IPPB_extend_count \
110 (interp_proc_profile_buffer_state . extend_count)
111 #define IPPB_overflow_count \
112 (interp_proc_profile_buffer_state . overflow_count)
113 #define IPPB_extra_info \
114 (interp_proc_profile_buffer_state . extra_buffer_state_info)
115
116 /*---------------------------------------------------------------------------*/
117 #define IPPB_disable() do \
118 { \
119 Set_Fixed_Obj_Slot (PC_Sample_Interp_Proc_Buffer, SHARP_F ) ; \
120 IPPB_buffer = SHARP_F ; \
121 IPPB_enabled = false ; \
122 IPPB_next_empty_slot_index = 0 ; \
123 IPPB_length = 0 ; /* Paranoia */\
124 } while (FALSE)
125 /*...........................................................................*/
126 DEFINE_PRIMITIVE ("INTERP-PROC-PROFILE-BUFFER/DISABLE",
127 Prim_IPPB_disable, 0, 0,
128 "()\n\
129 Disables the interpreted procedure profile buffer hence disabling profiling\n\
130 of interpreted procedures (unless and until a new buffer is installed).\
131 ")
132 {
133 PRIMITIVE_HEADER(0);
134 IPPB_disable ();
135 PRIMITIVE_RETURN (UNSPECIFIC);
136 }
137 /*---------------------------------------------------------------------------*/
138 #define IPPB_install(buffer_arg) do \
139 { \
140 Set_Fixed_Obj_Slot (PC_Sample_Interp_Proc_Buffer, buffer_arg ) ; \
141 IPPB_buffer = buffer_arg ; \
142 IPPB_enabled = true ; \
143 IPPB_length = (VECTOR_LENGTH (buffer_arg)) ; \
144 /* NB: Do NOT reset next_empty_slot_index since may be extending */ \
145 } while (FALSE)
146 /*...........................................................................*/
147 DEFINE_PRIMITIVE ("INTERP-PROC-PROFILE-BUFFER/INSTALL",
148 Prim_IPPB_install, 1, 1,
149 "(vector)\n\
150 Installs VECTOR as the interpreted procedure profile buffer.\
151 ")
152 {
153 PRIMITIVE_HEADER(1);
154 CHECK_ARG(1, VECTOR_P);
155 IPPB_install (ARG_REF (1));
156 PRIMITIVE_RETURN (UNSPECIFIC);
157 }
158 /*---------------------------------------------------------------------------*/
159 /*---------------------------------------------------------------------------*/
160 static void
DEFUN_VOID(resynch_IPPB_post_gc_hook)161 DEFUN_VOID(resynch_IPPB_post_gc_hook)
162 {
163 if IPPB_enabled
164 IPPB_install (Get_Fixed_Obj_Slot (PC_Sample_Interp_Proc_Buffer)) ;
165 }
166 /*---------------------------------------------------------------------------*/
167 /*---------------------------------------------------------------------------*/
168
169 /*---------------------------------------------------------------------------*/
170 DEFINE_PRIMITIVE ("INTERP-PROC-PROFILE-BUFFER/SLACK", Prim_IPPB_slack, 0, 0,
171 "()\n\
172 Returns the `slack' by which the near-fullness of the interpreted procedure\n\
173 profile buffer is determined and by which increment the buffer is extended\n\
174 when full.\n\
175 \n\
176 Note that the slack will always be a positive fixnum.\
177 ")
178 {
179 PRIMITIVE_HEADER(0);
180 PRIMITIVE_RETURN (ulong_to_integer (IPPB_slack));
181 }
182 /*---------------------------------------------------------------------------*/
183 DEFINE_PRIMITIVE ("INTERP-PROC-PROFILE-BUFFER/SET-SLACK",
184 Prim_IPPB_set_slack, 1, 1,
185 "(positive-fixnum)\n\
186 Sets the `slack' by which the near-fullness of the interpreted procedure\n\
187 profile buffer is determined and by which increment the buffer is extended\n\
188 when full.\n\
189 \n\
190 Note that the slack must be a positive fixnum.\
191 ")
192 {
193 PRIMITIVE_HEADER(1);
194 CHECK_ARG (1, FIXNUM_POSITIVE_P);
195 IPPB_slack = (integer_to_ulong (ARG_REF (1)));
196 PRIMITIVE_RETURN (UNSPECIFIC);
197 }
198 /*---------------------------------------------------------------------------*/
199 DEFINE_PRIMITIVE ("INTERP-PROC-PROFILE-BUFFER/SLACK-INCREMENT",
200 Prim_IPPB_slack_increment, 0, 0,
201 "()\n\
202 Returns the amount by which the interpreted procedure profile buffer slack\n\
203 is incremented when a buffer overflow occurs. In this sense it cuts the\n\
204 slack some slack.\n\
205 \n\
206 Note that the slack increment will always be a fixnum, but it can be negative\n\
207 (in which case it functions as a slack decrement).\
208 ")
209 {
210 PRIMITIVE_HEADER(0);
211 PRIMITIVE_RETURN (long_to_integer (IPPB_slack_increment));
212 }
213 /*---------------------------------------------------------------------------*/
214 DEFINE_PRIMITIVE ("INTERP-PROC-PROFILE-BUFFER/SET-SLACK-INCREMENT",
215 Prim_IPPB_set_slack_increment, 1, 1,
216 "(fixnum)\n\
217 Sets the amount by which the interpreted procedure profile buffer slack is\n\
218 incremented when a buffer overflow occurs.\n\
219 \n\
220 Note that the slack increment must be a fixnum, but it can be negative\n\
221 (in which case it functions as a slack decrement).\
222 ")
223 {
224 PRIMITIVE_HEADER(1);
225 CHECK_ARG (1, INTEGER_P);
226 IPPB_slack_increment = (integer_to_long (ARG_REF (1)));
227 PRIMITIVE_RETURN (UNSPECIFIC);
228 }
229
230 /*---------------------------------------------------------------------------*/
231 DEFINE_PRIMITIVE ("INTERP-PROC-PROFILE-BUFFER/EXTEND-NOISY?",
232 Prim_IPPB_extend_noisy_p, 0, 0,
233 "()\n\
234 Specifies whether notification of IPPB extensions is enabled.\
235 ")
236 {
237 PRIMITIVE_HEADER(0);
238 PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (IPPB_extend_noisy)) ;
239 }
240 /*---------------------------------------------------------------------------*/
241 DEFINE_PRIMITIVE ("INTERP-PROC-PROFILE-BUFFER/FLUSH-NOISY?",
242 Prim_IPPB_flush_noisy_p, 0, 0,
243 "()\n\
244 Specifies whether notification of IPPB extensions is enabled.\
245 ")
246 {
247 PRIMITIVE_HEADER(0);
248 PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (IPPB_flush_noisy)) ;
249 }
250 /*---------------------------------------------------------------------------*/
251 DEFINE_PRIMITIVE ("INTERP-PROC-PROFILE-BUFFER/OVERFLOW-NOISY?",
252 Prim_IPPB_overflow_noisy_p, 0, 0,
253 "()\n\
254 Specifies whether notification of IPPB overflows is enabled.\
255 ")
256 {
257 PRIMITIVE_HEADER(0);
258 PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (IPPB_overflow_noisy)) ;
259 }
260 /*---------------------------------------------------------------------------*/
261 DEFINE_PRIMITIVE ("INTERP-PROC-PROFILE-BUFFER/EXTEND-NOISY?/TOGGLE!",
262 Prim_IPPB_extend_noisy_p_toggle_bang, 0, 0,
263 "()\n\
264 Toggles the Boolean sense of whether to notify of IPPB extensions.\n\
265 \n\
266 It returns the newly installed sense of the flag.\
267 ")
268 {
269 PRIMITIVE_HEADER(0);
270 IPPB_extend_noisy = (! (IPPB_extend_noisy)) ;
271 PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (IPPB_extend_noisy)) ;
272 }
273 /*---------------------------------------------------------------------------*/
274 DEFINE_PRIMITIVE ("INTERP-PROC-PROFILE-BUFFER/FLUSH-NOISY?/TOGGLE!",
275 Prim_IPPB_flush_noisy_p_toggle_bang, 0, 0,
276 "()\n\
277 Toggles the Boolean sense of whether to notify of IPPB flushes.\n\
278 \n\
279 It returns the newly installed sense of the flag.\
280 ")
281 {
282 PRIMITIVE_HEADER(0);
283 IPPB_flush_noisy = (! (IPPB_flush_noisy)) ;
284 PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (IPPB_flush_noisy)) ;
285 }
286 /*---------------------------------------------------------------------------*/
287 DEFINE_PRIMITIVE ("INTERP-PROC-PROFILE-BUFFER/OVERFLOW-NOISY?/TOGGLE!",
288 Prim_IPPB_overflow_noisy_p_toggle_bang, 0, 0,
289 "()\n\
290 Toggles the Boolean sense of whether to notify of IPPB overflows.\n\
291 \n\
292 It returns the newly installed sense of the flag.\
293 ")
294 {
295 PRIMITIVE_HEADER(0);
296 IPPB_overflow_noisy = (! (IPPB_overflow_noisy)) ;
297 PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (IPPB_overflow_noisy)) ;
298 }
299
300 /*---------------------------------------------------------------------------*/
301 DEFINE_PRIMITIVE ("INTERP-PROC-PROFILE-BUFFER/EMPTY?", Prim_IPPB_empty_p, 0, 0,
302 "()\n\
303 Returns a boolean indicating whether or not the IPPB is empty.\
304 ")
305 {
306 PRIMITIVE_HEADER(0);
307 PRIMITIVE_RETURN(BOOLEAN_TO_OBJECT (IPPB_next_empty_slot_index == 0)) ;
308 }
309 /*---------------------------------------------------------------------------*/
310 DEFINE_PRIMITIVE ("INTERP-PROC-PROFILE-BUFFER/NEXT-EMPTY-SLOT-INDEX",
311 Prim_IPPB_next_empty_slot_index, 0, 0,
312 "()\n\
313 Returns the index of the next `free' slot of the interp-proc profile buffer.\
314 ")
315 {
316 PRIMITIVE_HEADER(0);
317 PRIMITIVE_RETURN(ulong_to_integer (IPPB_next_empty_slot_index));
318 }
319 /*---------------------------------------------------------------------------*/
320 DEFINE_PRIMITIVE ("%INTERP-PROC-PROFILE-BUFFER/NEXT-EMPTY-SLOT-INDEX/RESET",
321 Prim_IPPB_next_empty_slot_index_reset, 0, 0,
322 "()\n\
323 Resets the index of the next `free' slot of the interp-proc profile buffer.\
324 \n\
325 Only officially designated wizards should even think of using this\n\
326 super secret primitive. FNORD!\
327 ")
328 {
329 PRIMITIVE_HEADER(0);
330 IPPB_next_empty_slot_index = ((unsigned long) 0);
331 PRIMITIVE_RETURN(UNSPECIFIC);
332 }
333
334 /*---------------------------------------------------------------------------*/
335 DEFINE_PRIMITIVE ("%PC-SAMPLE/IPPB-FLUSH-IMMEDIATE?",
336 Prim_pc_sample_IPPB_flush_immediate_p, 0, 0,
337 "()\n\
338 Specifies whether the IPPB is flushed upon each entry.\n\
339 \n\
340 Only officially designated wizards should even think of using this\n\
341 super secret primitive. FNORD!\
342 ")
343 {
344 PRIMITIVE_HEADER(0);
345 PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (IPPB_flush_immediate)) ;
346 }
347 /*---------------------------------------------------------------------------*/
348 DEFINE_PRIMITIVE ("%PC-SAMPLE/IPPB-FLUSH-IMMEDIATE?/TOGGLE!",
349 Prim_pc_sample_IPPB_flush_immediate_p_toggle_bang, 0, 0,
350 "()\n\
351 Toggles the Boolean sense of whether the IPPBuffer is flushed upon each entry.\n\
352 \n\
353 It returns the newly installed sense of the flag.\n\
354 \n\
355 This is for mondo bizarro sampler debugging purposes only.\n\
356 \n\
357 Only officially designated moby wizards should even think of thinking of\n\
358 using this most ultra super duper secret primitive. FNORD!\
359 ")
360 {
361 PRIMITIVE_HEADER(0);
362 IPPB_flush_immediate = (! (IPPB_flush_immediate)) ;
363 PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (IPPB_flush_immediate)) ;
364 }
365 /*---------------------------------------------------------------------------*/
366 DEFINE_PRIMITIVE ("%PC-SAMPLE/IPPB-DEBUGGING?",
367 Prim_pc_sample_IPPB_debugging_p, 0, 0,
368 "()\n\
369 Specifies whether the IPPB is in debugging mode.\n\
370 \n\
371 Only officially designated wizards should even think of using this\n\
372 super secret primitive. FNORD!\
373 ")
374 {
375 PRIMITIVE_HEADER(0);
376 PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (IPPB_debugging)) ;
377 }
378 /*---------------------------------------------------------------------------*/
379 DEFINE_PRIMITIVE ("%PC-SAMPLE/IPPB-DEBUGGING?/TOGGLE!",
380 Prim_pc_sample_IPPB_debugging_p_toggle_bang, 0, 0,
381 "()\n\
382 Toggles the Boolean sense of whether the IPPBuffer is in debugging mode.\n\
383 \n\
384 It returns the newly installed sense of the flag.\n\
385 \n\
386 This is for mondo bizarro sampler debugging purposes only.\n\
387 \n\
388 Only officially designated moby wizards should even think of thinking of\n\
389 using this most ultra super duper secret primitive. FNORD!\
390 ")
391 {
392 PRIMITIVE_HEADER(0);
393 IPPB_debugging = (! (IPPB_debugging)) ;
394 PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (IPPB_debugging)) ;
395 }
396
397 /*---------------------------------------------------------------------------*/
398 DEFINE_PRIMITIVE ("%PC-SAMPLE/IPPB-MONITORING?",
399 Prim_pc_sample_IPPB_monitoring_p, 0, 0,
400 "()\n\
401 Specifies whether the IPPB is in monitoring mode.\n\
402 \n\
403 This, for instance, is how a count of buffer overflows is accumulated.\
404 ")
405 {
406 PRIMITIVE_HEADER(0);
407 PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (IPPB_monitoring)) ;
408 }
409 /*---------------------------------------------------------------------------*/
410 DEFINE_PRIMITIVE ("%PC-SAMPLE/IPPB-MONITORING?/TOGGLE!",
411 Prim_pc_sample_IPPB_monitoring_p_toggle_bang, 0, 0,
412 "()\n\
413 Toggles the Boolean sense of whether the IPPB is in monitoring mode.\n\
414 \n\
415 It returns the newly installed sense of the flag.\n\
416 \n\
417 This is for mondo bizarro sampler monitoring purposes only.\n\
418 For instance, toggling this monitor flag to true triggers accumulating\n\
419 a count of buffer overflows.\
420 ")
421 {
422 PRIMITIVE_HEADER(0);
423 IPPB_monitoring = (! (IPPB_monitoring)) ;
424 PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (IPPB_monitoring)) ;
425 }
426 /*---------------------------------------------------------------------------*/
427 DEFINE_PRIMITIVE ("%PC-SAMPLE/IPPB-FLUSH-COUNT",
428 Prim_pc_sample_IPPB_flush_count, 0, 0,
429 "()\n\
430 Returns the number of IPPB flush requests that have been issued since the\n\
431 last PC-SAMPLE/IPPB-FLUSH-COUNT/RESET was issued (or since booting if no\n\
432 resets issued).\
433 ")
434 {
435 PRIMITIVE_HEADER(0);
436 PRIMITIVE_RETURN(ulong_to_integer (IPPB_flush_count));
437 }
438 /*---------------------------------------------------------------------------*/
439 DEFINE_PRIMITIVE ("%PC-SAMPLE/IPPB-FLUSH-COUNT/RESET",
440 Prim_pc_sample_IPPB_flush_count_reset, 0, 0,
441 "()\n\
442 Resets the IPPB flush count (obviously... sheesh!).\
443 ")
444 {
445 PRIMITIVE_HEADER(0);
446 IPPB_flush_count = ((unsigned long) 0);
447 PRIMITIVE_RETURN(UNSPECIFIC);
448 }
449 /*---------------------------------------------------------------------------*/
450 DEFINE_PRIMITIVE ("%PC-SAMPLE/IPPB-EXTEND-COUNT",
451 Prim_pc_sample_IPPB_extend_count, 0, 0,
452 "()\n\
453 Returns the number of IPPB extend requests that have been issued since the\n\
454 last PC-SAMPLE/IPPB-EXTEND-COUNT/RESET was issued (or since booting if no\n\
455 resets issued).\
456 ")
457 {
458 PRIMITIVE_HEADER(0);
459 PRIMITIVE_RETURN(ulong_to_integer (IPPB_extend_count));
460 }
461 /*---------------------------------------------------------------------------*/
462 DEFINE_PRIMITIVE ("%PC-SAMPLE/IPPB-EXTEND-COUNT/RESET",
463 Prim_pc_sample_IPPB_extend_count_reset, 0, 0,
464 "()\n\
465 Resets the IPPB extend count (obviously... sheesh!).\
466 ")
467 {
468 PRIMITIVE_HEADER(0);
469 IPPB_extend_count = ((unsigned long) 0);
470 PRIMITIVE_RETURN(UNSPECIFIC);
471 }
472
473 /*---------------------------------------------------------------------------*/
474 DEFINE_PRIMITIVE ("%PC-SAMPLE/IPPB-OVERFLOW-COUNT",
475 Prim_pc_sample_IPPB_overflow_count, 0, 0,
476 "()\n\
477 Returns the number of IPPB overflows that have been issued since the\n\
478 last PC-SAMPLE/IPPB-OVERFLOW-COUNT/RESET was issued (or since booting if no\n\
479 resets issued).\n\
480 \n\
481 Each overflow indicates a sample that was punted into the bit bucket.\
482 ")
483 {
484 PRIMITIVE_HEADER(0);
485 PRIMITIVE_RETURN(ulong_to_integer (IPPB_overflow_count));
486 }
487 /*---------------------------------------------------------------------------*/
488 DEFINE_PRIMITIVE ("%PC-SAMPLE/IPPB-OVERFLOW-COUNT/RESET",
489 Prim_pc_sample_IPPB_overflow_count_reset, 0, 0,
490 "()\n\
491 Resets the IPPB overflow count (obviously... sheesh!).\
492 ")
493 {
494 PRIMITIVE_HEADER(0);
495 IPPB_overflow_count = ((unsigned long) 0);
496 PRIMITIVE_RETURN(UNSPECIFIC);
497 }
498 /*---------------------------------------------------------------------------*/
499 DEFINE_PRIMITIVE ("%PC-SAMPLE/IPPB-EXTRA-INFO",
500 Prim_pc_sample_IPPB_extra_info, 0, 0,
501 "()\n\
502 Returns the extra info entry associated with the IPP Buffer.\n\
503 \n\
504 Only officially designated wizards should even think of using this\n\
505 super secret primitive. FNORD!\
506 ")
507 {
508 PRIMITIVE_HEADER(0);
509 PRIMITIVE_RETURN (IPPB_extra_info) ;
510 }
511 /*---------------------------------------------------------------------------*/
512 DEFINE_PRIMITIVE ("%PC-SAMPLE/SET-IPPB-EXTRA-INFO!",
513 Prim_pc_sample_set_IPPB_extra_info_bang, 1, 1,
514 "(object)\n\
515 Stores OBJECT in the extra info entry of the IPPB.\n\
516 \n\
517 This is for mondo bizarro sampler frobnication purposes only.\n\
518 \n\
519 Only officially designated moby wizards should even think of thinking of\n\
520 using this most ultra super duper secret primitive. FNORD!\
521 ")
522 {
523 PRIMITIVE_HEADER(1);
524 IPPB_extra_info = ARG_REF(1);
525 PRIMITIVE_RETURN (UNSPECIFIC);
526 }
527
528 /*****************************************************************************
529 * kludgerous ``hidden arg'' passing mechanism
530 */
531
532 static SCHEME_OBJECT pc_sample_current_env_frame = UNSPECIFIC ;
533
534 /*****************************************************************************/
535 static void
536 DEFUN (pc_sample_record_interp_proc, (trinfo), struct trap_recovery_info * trinfo)
537 {
538 /* GJR suggested nabbing the current ENV to find the current PROC,
539 * warning that the current ENV may be invalid, e.g. in the middle
540 * of a LOAD. Its validity will have been assured by the caller here.
541 *
542 * Since no real virtual PC is maintained in the interpreter, this ENV
543 * frobbing is our only means of mapping a SIGCONTEXT into some unique ID
544 * of the interp-proc being interpreted. Specifically, we recover the lambda
545 * lurking within the body of the procedure whose arguments gave rise to the
546 * current ENV frame.
547 *
548 * Oh, TRINFO arg is for cutesy diagnostics of Unidentifiable Function Objs.
549 */
550
551 SCHEME_OBJECT interp_proc_lambda ;
552 SCHEME_OBJECT the_procedure = (MEMORY_REF (pc_sample_current_env_frame,
553 ENVIRONMENT_FUNCTION));
554
555 /* Stutter step to make sure it really *is* a procedure object */
556
557 if ((OBJECT_TYPE (the_procedure)) == AUX_LIST_TYPE)
558 the_procedure = (MEMORY_REF (the_procedure, ENV_EXTENSION_PROCEDURE));
559
560 interp_proc_lambda = (MEMORY_REF (the_procedure, PROCEDURE_LAMBDA_EXPR ));
561
562 /* Hurumph... since the lambda may never have been hashed (and trap
563 * handlers are forbidden to do the CONSing necessary to generate new hash
564 * numbers), and since there is no microcode/scheme interface for hashing
565 * microcode objects (i.e., C data) anyway, we just pass the buck up to the
566 * interrupt handler mechanism: interrupt handlers are called at delicately
567 * perspicatious moments so they are permitted to CONS. This buck is passed
568 * by buffering lambdas until we have enough of them that it is worth
569 * issuing a request to spill the buffer into the lambda hashtable.
570 * For more details, see pcsiproc.scm in the runtime directory.
571 */
572
573 pc_sample_record_buffer_entry( interp_proc_lambda,
574 &interp_proc_profile_buffer_state);
575
576 #if ( defined(PCS_LOG) /* Sample console logging */ \
577 || defined(PCS_LOG_INTERP_PROC) \
578 )
579 log_interp_proc_sample (trinfo) ;
580 #endif
581
582 }
583
584
585
586 /*****************************************************************************/
587 #endif /* REALLY_INCLUDE_PROFILE_CODE */
588