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