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.c < prev    next >
C/C++ Source or Header  |  1999-01-02  |  53KB  |  1,499 lines
  1. /* -*-C-*-
  2.  
  3. $Id: pcsample.c,v 1.6 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. /* PCSAMPLE.C -- defines the PC Sample subroutines for UNIX implementations */
  23.  
  24. /*****************************************************************************/
  25. #ifdef REALLY_INCLUDE_PROFILE_CODE /* scan_defines concession */
  26.  
  27. /*!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*\
  28.  * TODO:
  29.  *
  30.  *  - The mumble_index func ptrs can be avoided via macro passing?!
  31.  *  - Maybe macro-ize/in-line code:
  32.  *    PC_SAMPLE
  33.  *    PC_SAMPLE_RECORD
  34.  *    PC_SAMPLE_UPDATE_BI_BUFFER (after merging out paranoia & verbosity)
  35.  *    PC_SAMPLE_RECORD_TABLE_ENTRY and some others?
  36.  *      PC_SAMPLE_SPILL_GC_SAMPLES_INTO_PRIMITIVE_TABLE
  37.  *
  38. \*!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*/
  39.  
  40.  
  41. #include <microcode/ux.h>        /* UNIX bullocks               */
  42. #include <microcode/osenv.h>        /* For profile_timer_set/clear */
  43. #include <microcode/config.h>        /* For TRUE/FALSE & true/false */
  44. #include <microcode/scheme.h>
  45. #include <microcode/uxtrap.h>        /* UNIX trap handlers         */
  46. #include <microcode/uxsig.h>        /* For DEFUN_STD_HANDLER */
  47. #include <microcode/prims.h>        /* For DEFINE_PRIMITIVE */
  48. #include <microcode/cmpintmd.h>     /* Compiled code interface macros */
  49.  
  50. #ifdef HAVE_ITIMER           /* No interrupt timer ==> no PC sampling */
  51.  
  52. /*****************************************************************************
  53.  * Very crude, brute force enable/disable key switch ... KERCHUNK! Debuggery */
  54.  
  55. static volatile Boolean pc_sample_halted = true ;
  56. static volatile clock_t profile_interval =    0 ; /* one-shot interval */
  57.  
  58. /*---------------------------------------------------------------------------*/
  59. static void
  60. DEFUN (OS_pc_sample_timer_set, (first, interval),
  61.        clock_t first AND
  62.        clock_t interval)
  63. {
  64.   /* The profile trap handler will issue another one-shot triggering
  65.    * of the prof timer once it has handled the pending profile request.
  66.    * This assures that the profile interval cannot be so small as
  67.    * to cause PROF triggers to deluge the system.
  68.    */
  69.  
  70.   Tsignal_handler_result sighnd_profile() ; /* See uxtrap.c section */
  71.  
  72.   {
  73.     OS_profile_timer_clear ();    /* ``Cease fire!'' while reset */
  74.     pc_sample_halted = false;     /* clear internal state flag */
  75.     profile_interval = interval;  /* trap handler re-arms @ interval */
  76.     activate_handler (SIGPROF, ((Tsignal_handler) sighnd_profile));
  77.                                   /* in case deactivated */
  78.     OS_profile_timer_set (first, ((clock_t) 0)); /* Open fire! (one shot) */
  79.   }
  80.  
  81. #if (   defined(PCS_LOG_TIMER_DELTA) /* Profile gestalt debuggery */          \
  82.      || defined(PCS_LOG_TIMER_SET)                          \
  83.      )
  84.   outf_console ("0x%x  ", profile_interval) ;
  85.   outf_flush_console () ;
  86. #endif
  87. }
  88.  
  89. static void
  90. DEFUN_VOID (OS_pc_sample_timer_clear)
  91. {
  92.   long old_mask = sigblock (sigmask (SIGPROF));    /* atomic wrt sigprof */
  93.   { 
  94.     OS_profile_timer_clear ()       ; /* ``Cease fire!'' */
  95.     deactivate_handler (SIGPROF)    ; /* disable handler */
  96.     pc_sample_halted = true         ; /* set internal state flag */
  97.     profile_interval = ((clock_t) 0); /* disable re-triggers too */
  98.   } 
  99.   (void) sigblock (old_mask) ;                     /* end atomic wrt sigprof */
  100.  
  101. #if (   defined(PCS_LOG_TIMER_DELTA) /* Profile gestalt debuggery */          \
  102.      || defined(PCS_LOG_TIMER_CLEAR)                          \
  103.      )
  104.   outf_console ("-\n") ;
  105.   outf_flush_console () ;
  106. #endif  
  107.  
  108. }
  109.  
  110.  
  111. /*****************************************************************************/
  112. #if !defined(HAVE_SIGCONTEXT) || !defined(HAS_COMPILER_SUPPORT) || defined(USE_STACKLETS)
  113. /*---------------------------------------------------------------------------*/
  114.  
  115. static void
  116. DEFUN (profile_trap_handler, (scp), struct FULL_SIGCONTEXT * scp)
  117. {
  118.   /* Cannot recover PC w/o sigcontext (?) so nothing to sample */
  119.  
  120. #ifndef PCS_TACIT_NO_TRAP
  121.   outf_error ("\nProfile trap handler called but is non-existent.\n") ;
  122.   outf_flush_error () ;
  123. #endif
  124.  
  125.   return;
  126. }
  127.  
  128. #else  /* HAVE_SIGCONTEXT and HAS_COMPILER_SUPPORT and not USE_STACKLETS     */
  129.  
  130. /* Timezones
  131.  * These timezones are different to the ones in the microcode.  The basic support here allows them to be
  132.  */
  133.  
  134. #define INITIAL_ZONE_LIMIT 10
  135. static int current_zone = 0;
  136. static int max_zone = INITIAL_ZONE_LIMIT;
  137.  
  138. static double initial_zone_buffer[INITIAL_ZONE_LIMIT] = {0.0};
  139. static double *zones = initial_zone_buffer;
  140.  
  141. /* Invariant: 0 <= current_zone < max_zone */
  142. /* Invariant: zones -> allocation of max_zone doubles */
  143.  
  144.  
  145. #define essential_profile_trap_handler(scp)  do                      \
  146. {                                          \
  147.   extern void EXFUN (pc_sample, (struct FULL_SIGCONTEXT *));              \
  148.   extern void EXFUN (zone_sample, ());                      \
  149.                                           \
  150.   pc_sample (scp) ;        /* For now, profiler just PC samples */          \
  151.   zones[current_zone] += 1.0;   /* and zone sampling */                       \
  152.   OS_pc_sample_timer_set(profile_interval,   /* launch another 1-shot */      \
  153.              profile_interval) ; /* at the same interval  */      \
  154. } while (FALSE)
  155.  
  156.  
  157. #ifndef PCS_TRAP_LOG        /* Sample debuggery */
  158. #define real_profile_trap_handler(scp) essential_profile_trap_handler(scp)
  159. #else
  160. #define real_profile_trap_handler(scp)    do                      \
  161. {                                          \
  162.   essential_profile_trap_handler(scp);                          \
  163.   outf_console ("\n; Profile trap handler called while interval = %d.\n",     \
  164.         profile_interval) ;                          \
  165.   outf_flush_console () ;                              \
  166. } while (FALSE)
  167. #endif
  168.  
  169. static void
  170. DEFUN (profile_trap_handler, (scp), struct FULL_SIGCONTEXT * scp)
  171. {
  172.  
  173. #ifndef  PCS_TRAP_HANDLER_PARANOIA
  174.  
  175.   real_profile_trap_handler (scp) ;
  176.   return;
  177.  
  178. #else /* PCS_TRAP_HANDLER_PARANOIA */
  179.  
  180.   if (   (! (pc_sample_halted))
  181.       && (profile_interval != ((clock_t) 0)))
  182.     real_profile_trap_handler (scp) ;
  183.  
  184. #ifndef PCS_TACIT_PUNT_BELATED    /* Sample debuggery */
  185.   else if (profile_interval == ((clock_t) 0))
  186.   {
  187.     /* This shouldn't arise since now de-activate trap handler @ timer clear */
  188.     outf_console ("\n\
  189.                    \n;----------------------------------------------\
  190.                    \n; Profile trap handler punted a belated sample.\
  191.                    \n;----------------------------------------------\
  192.                    \n\
  193.                    \n") ;
  194.     outf_flush_console () ;
  195.   }
  196. #endif
  197.  
  198. #ifndef PCS_TACIT_WIZARD_HALT    /* Sample gestalt debuggery */
  199.   else if (pc_sample_halted)
  200.   {
  201.     /* Only official wizards should ever witness this. FNORD! */
  202.  
  203.     outf_console ("!") ;
  204.     outf_flush_console ();
  205.   }
  206. #endif
  207.  
  208. #ifndef PCS_TACIT_MUSIC_MAN    /* Sample debuggery */
  209.   else
  210.   { 
  211.     outf_error ("\n ; There's trouble, right here in Sample City.\n") ;
  212.     outf_flush_error () ;
  213.   }
  214. #endif
  215.  
  216. #endif  /* PCS_TRAP_HANDLER_PARANOIA */
  217. }
  218.  
  219. #endif /* HAVE_SIGCONTEXT and HAS_COMPILER_SUPPORT and not USE_STACKLETS */
  220.  
  221.  
  222. DEFUN_STD_HANDLER (sighnd_profile,
  223.   {
  224.     profile_trap_handler (scp);
  225.   })           
  226.  
  227. DEFINE_PRIMITIVE ("PC-SAMPLE/TIMER-CLEAR", Prim_pc_sample_timer_clear, 0, 0,
  228.   "()\n\
  229.   Turn off the PC sample timer.\
  230.   ")
  231. {
  232.   PRIMITIVE_HEADER (0);
  233.   OS_pc_sample_timer_clear ();
  234.   PRIMITIVE_RETURN (UNSPECIFIC);
  235. }
  236.  
  237. DEFINE_PRIMITIVE ("PC-SAMPLE/TIMER-SET", Prim_pc_sample_timer_set, 2, 2,
  238.   "(first interval)\n\
  239.   Set the PC sample timer.\n\
  240.   First arg FIRST says how long to wait until the first interrupt;\n\
  241.   second arg INTERVAL says how long to wait between interrupts after that.\n\
  242.   Both arguments are in units of milliseconds.\
  243.   ")
  244. {
  245.   PRIMITIVE_HEADER (2);
  246.   OS_pc_sample_timer_set ((arg_nonnegative_integer (1)),
  247.               (arg_nonnegative_integer (2)));
  248.   PRIMITIVE_RETURN (UNSPECIFIC);
  249. }
  250.  
  251. DEFINE_PRIMITIVE ("%PC-SAMPLE/HALTED?", Prim_pc_sample_halted_p, 0, 0,
  252.  "()\n\
  253.  Specifies whether PC sampling has been brute forcably disabled.\n\
  254.  \n\
  255.  Only officially designated wizards should even think of using this\n\
  256.  super secret primitive. FNORD!\
  257.  ")
  258. {
  259.   PRIMITIVE_HEADER(0);
  260.   PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (pc_sample_halted)) ;
  261. }
  262.  
  263. DEFINE_PRIMITIVE ("%PC-SAMPLE/HALTED?/TOGGLE!",
  264.           Prim_pc_sample_halted_p_toggle_bang, 0, 0,
  265.  "()\n\
  266.  Toggles the Boolean sense of whether PC sampling is brute forcably disabled.\n\
  267.  \n\
  268.  It returns the newly installed sense of the flag.\n\
  269.  \n\
  270.  -------\n\
  271.  WARNING! If pc-sample/init has not been called (to initialize profiling\n\
  272.  -------  tables) then you will lose big if you naively toggle halted-flag\n\
  273.           to #F because that will start the profile timer.\n\
  274.  \n\
  275.  Only officially designated moby wizards should even think of thinking of\n\
  276.  using this most ultra super duper secret primitive. FNORD!\
  277.  ")
  278. {
  279.   PRIMITIVE_HEADER(0);
  280.   pc_sample_halted = (! (pc_sample_halted)) ;
  281.   if (   (! (pc_sample_halted))
  282.       && (profile_interval != ((clock_t) 0)))
  283.     OS_pc_sample_timer_set(1, profile_interval) ; /* Throw the switch, Igor! */
  284.   PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (pc_sample_halted)) ;
  285. }
  286.  
  287. /*****************************************************************************
  288.  * Mondo hack to keep track of where the primitive GARBAGE-COLLECT is so we
  289.  *  can still sample GC calls during GC despite the PC_Sample_Primitive_Table
  290.  *  can shift about
  291.  *****************************************************************************/
  292.  
  293. long Garbage_Collect_Primitive_Index = -1;    /* installed later */
  294.  
  295. static void
  296. DEFUN_VOID (pc_sample_cache_GC_primitive_index)
  297. {
  298.   SCHEME_OBJECT primitive = make_primitive("GARBAGE-COLLECT");
  299.   Garbage_Collect_Primitive_Index = ((primitive != SHARP_F)
  300.                      ? PRIMITIVE_NUMBER(primitive) : -1) ;
  301. #ifdef PCS_LOG_GCI_CACHE
  302.   outf_console ("\n  GC Index %d (0x%x)\n",
  303.         Garbage_Collect_Primitive_Index,
  304.         Garbage_Collect_Primitive_Index) ;
  305.   outf_flush_console () ;
  306. #endif
  307.  
  308. }
  309.  
  310. DEFINE_PRIMITIVE ("%PC-SAMPLE/CACHE-GC-PRIMITIVE-INDEX",
  311.           Prim_pc_sample_cache_GC_primitive_index, 0, 0,
  312.  "()\n\
  313.   Signals the microcode to go find the GARBAGE-COLLECT primitive and cache\n\
  314.   away its index into the Primitive Table.\n\
  315.   \n\
  316.   This should be invoked each time the Primitive Table is altered in such a\n\
  317.   way that existing primitives can shift about.\
  318.  ")
  319. {
  320.   PRIMITIVE_HEADER(0);
  321.   pc_sample_cache_GC_primitive_index();
  322.   PRIMITIVE_RETURN(UNSPECIFIC);
  323. }
  324.  
  325.  
  326. static volatile Boolean pc_sample_within_GC_flag    = false;
  327. static volatile double                   GC_samples = 0    ;
  328.  
  329. static void
  330. DEFUN_VOID (pc_sample_spill_GC_samples_into_primitive_table)
  331. {
  332.   if (   (                     GC_samples !=  0) /* Something to tally       */
  333.       && (Garbage_Collect_Primitive_Index != -1) /* Safe to tally GC samples */
  334.      )
  335.   {
  336.     /* flush GC_samples into GARBAGE-COLLECT entry w/in Primitive Table */
  337.     double * fpp
  338.       = ((double *)
  339.      (MEMORY_LOC
  340.       ((VECTOR_REF((Get_Fixed_Obj_Slot(PC_Sample_Primitive_Table)),
  341.                Garbage_Collect_Primitive_Index)),
  342.        1))) ;
  343.     (* fpp) = ((* fpp) + ((double) GC_samples)) ;
  344.   }
  345.   GC_samples = 0 ;        /* reset counter */
  346. }
  347.  
  348. DEFINE_PRIMITIVE ("PC-SAMPLE/SPILL-GC-SAMPLES-INTO-PRIMITIVE-TABLE",
  349.           Prim_pc_sample_spill_GC_samples_into_primitive_table, 0, 0,
  350.  "()\n\
  351.   Make sure all samples taken during GC are present and accounted for in the\n\
  352.   Primitive Sample Table.\
  353.  ")
  354. {
  355.   PRIMITIVE_HEADER(0);
  356.   pc_sample_spill_GC_samples_into_primitive_table();
  357.   PRIMITIVE_RETURN(UNSPECIFIC);
  358. }
  359.  
  360.  
  361. static void
  362. DEFUN_VOID (pc_sample__pre_gc_gc_synch_hook)
  363. {
  364.   pc_sample_within_GC_flag = true;     /* will count samples during GC */
  365. }
  366.  
  367. static void
  368. DEFUN_VOID (pc_sample_post_gc_gc_synch_hook)
  369. {
  370.   if ((Get_Fixed_Obj_Slot(PC_Sample_Primitive_Table)) != SHARP_F) /* enabled */
  371.     pc_sample_spill_GC_samples_into_primitive_table() ;
  372.   pc_sample_within_GC_flag = false;
  373.   /***************************************************************************
  374.    * Moby hack: may still get a few samples after this hook runs but they will
  375.    * not be lost since we reset the counter *after* GC appears to be over, not
  376.    * at the beginning of the next GC. Thus, eventually these GCs will be coun-
  377.    * ted, just not necessarily right away. To be sure, however, that they get
  378.    * appropriately charged to the current sample run, we will manually call
  379.    * this hook whenever we try to access the primitive table in runtime code.
  380.    ***************************************************************************/
  381. }
  382.  
  383. /****************************************************************************
  384.  *  Following debuggery was used to isolate bug with unwarranted samples.   *
  385.  ****************************************************************************/
  386. static Boolean
  387. DEFUN (repugnant_sample_block_addr_p, (block_addr), SCHEME_OBJECT * block_addr)
  388. {
  389.   /*    If you uncomment the next lines, add 0x10+ to each constant below  */
  390.   /* outf_error ("Block addr = %lx\n", ((unsigned long) block_addr));
  391.      outf_flush_error () ;
  392.    */
  393.   return (   (((unsigned long) block_addr) == 0x411F60FC) /* IPPB/flush      */
  394.       || (((unsigned long) block_addr) == 0x411EEBD0) /* IPPB/need2flush?*/
  395.       || (((unsigned long) block_addr) == 0x410C6A94) /* name->package   */
  396.       || (((unsigned long) block_addr) == 0x410EB880) /* package/child   */
  397.       || (((unsigned long) block_addr) == 0x410AEB24) /* ->environment   */
  398.       ); /*                               block-off+0x40000000           */
  399. }
  400.  
  401. static void            /* debuggery hook */
  402. DEFUN (flame_block, (block_addr), SCHEME_OBJECT * block_addr)
  403. {
  404.   if (pc_sample_halted)
  405.     outf_console ("\n\nAAAHH!! 0x%x\n\n",((unsigned long) block_addr));
  406.   else
  407.     outf_console ("MADRE!! Bad ass = %lx ; P(h) = %d ; P(i) = %d\n",
  408.           ((unsigned long) block_addr),
  409.           pc_sample_halted,
  410.           profile_interval) ;
  411.  
  412.   outf_flush_console () ;
  413. }
  414.  
  415. static struct trap_recovery_info *
  416. DEFUN (find_sigcontext_ptr_pc, (scp, trinfo),
  417.        struct FULL_SIGCONTEXT    * scp    AND
  418.        struct trap_recovery_info * trinfo
  419.        )
  420. {
  421.   /* Recover the PC from the signal context ptr.     */
  422.   /* (Extracted from continue_from_trap in uxtrap.c) */
  423.  
  424.   long the_pc = ((FULL_SIGCONTEXT_PC (scp)) & PC_VALUE_MASK);
  425.  
  426.   int builtin_index;
  427.   int utility_index;
  428.  
  429.   int pc_in_builtin;
  430.   int pc_in_utility;
  431.   int pc_in_C;
  432.   int pc_in_heap;
  433.   int pc_in_constant_space;
  434.   int pc_in_scheme;
  435.   int pc_in_hyper_space;
  436.  
  437.   if ((the_pc & PC_ALIGNMENT_MASK) != 0)
  438.   {
  439.     pc_in_builtin      = false;
  440.     pc_in_utility      = false;
  441.     pc_in_C            = false;
  442.     pc_in_heap           = false;
  443.     pc_in_constant_space = false;
  444.     pc_in_scheme      = false;
  445.     pc_in_hyper_space      =  true;
  446.   }
  447.   else
  448.   {
  449.     extern int EXFUN (pc_to_builtin_index, (unsigned long));
  450.     extern int EXFUN (pc_to_utility_index, (unsigned long));
  451.  
  452.     builtin_index = (pc_to_builtin_index (the_pc));
  453.     utility_index = (pc_to_utility_index (the_pc));
  454.  
  455.     pc_in_builtin        = (builtin_index != -1);
  456.     pc_in_utility        = (utility_index != -1);    
  457.     pc_in_heap           = (   (the_pc <  ((long) Heap_Top   ))
  458.                 && (the_pc >= ((long) Heap_Bottom)));
  459.     pc_in_constant_space = (   (the_pc <  ((long) Free_Constant ))
  460.                 && (the_pc >= ((long) Constant_Space)));
  461.     pc_in_scheme         = (   pc_in_heap
  462.                 || pc_in_constant_space
  463.                 || pc_in_builtin);
  464.     /* This doesnt work for dynamically loaded libraries, e.g. libc.sl:
  465.     pc_in_C              = (   (the_pc <= ((long) (get_etext ())))
  466.                 && (!pc_in_builtin));
  467.     */
  468.     pc_in_C              = (   (!pc_in_scheme)
  469.                 && (!pc_in_builtin));
  470.     pc_in_hyper_space    = (   (! pc_in_C     )
  471.                 && (! pc_in_scheme));
  472.   }
  473.  
  474.   if (    pc_in_hyper_space
  475.       || (pc_in_scheme && ALLOW_ONLY_C)) /* In hyper space. */
  476.   {
  477.     (trinfo -> state)           = STATE_UNKNOWN;
  478.     (trinfo -> pc_info_1)       = 0; /* UFO[0]: Doesnt look like a primitive */
  479.     (trinfo -> pc_info_2)       = the_pc;
  480.     (trinfo -> extra_trap_info) = pc_in_hyper_space;
  481.   }
  482.   else if (pc_in_scheme)            /* In compiled code. */
  483.   {
  484.     SCHEME_OBJECT * block_addr = (pc_in_builtin
  485.                   ? ((SCHEME_OBJECT *) NULL)
  486.                   : (find_block_address (((PTR) the_pc),
  487.                              (pc_in_heap
  488.                               ? Heap_Bottom
  489.                               : Constant_Space))));
  490.     if (block_addr != ((SCHEME_OBJECT *) NULL))
  491.     {
  492.       (trinfo -> state)           = STATE_COMPILED_CODE;
  493.       (trinfo -> pc_info_1)       = /* code block */
  494.     (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, block_addr));
  495.       (trinfo -> pc_info_2)       = /* offset w/in block */
  496.     (LONG_TO_UNSIGNED_FIXNUM (the_pc - ((long) block_addr)));
  497.       (trinfo -> extra_trap_info) = pc_in_constant_space;
  498. #ifdef PCS_LOG_REPUGNANCE
  499.       if (repugnant_sample_block_addr_p (block_addr))
  500.     flame_block (block_addr);
  501. #endif
  502.     }
  503.     else if (pc_in_builtin)        /* In builtin */
  504.     {
  505.       (trinfo -> state)           = STATE_BUILTIN;
  506.       (trinfo -> pc_info_1)       = builtin_index;
  507.       (trinfo -> pc_info_2)       = SHARP_T;
  508.       (trinfo -> extra_trap_info) = true;
  509.     }
  510.     else                /* In Probably Compiled frobby */
  511.     {
  512.       int prob_comp_index = (pc_in_constant_space ? 0 : 1) ;
  513.  
  514.       (trinfo -> state)           = STATE_PROBABLY_COMPILED;
  515.       (trinfo -> pc_info_1)       = prob_comp_index;
  516.       (trinfo -> pc_info_2)       = the_pc;
  517.       (trinfo -> extra_trap_info) = pc_in_constant_space;
  518.     }
  519.   }
  520.   else                    /* pc_in_C */
  521.   {
  522.     /* In the interpreter, a primitive, or a compiled code utility. */
  523.  
  524.     SCHEME_OBJECT primitive = (Regs[REGBLOCK_PRIMITIVE]);
  525.  
  526.     if (pc_in_utility)            /* In Utility */
  527.     {
  528.       (trinfo -> state)           = STATE_UTILITY;
  529.       (trinfo -> pc_info_1)       = utility_index;
  530.       (trinfo -> pc_info_2)       = SHARP_F;
  531.       (trinfo -> extra_trap_info) = false;
  532.     }
  533.     else if ((OBJECT_TYPE (primitive)) == TC_PRIMITIVE)    /* In Primitive */
  534.     {
  535.       (trinfo -> state)           = STATE_PRIMITIVE;
  536.       (trinfo -> pc_info_1)       = (PRIMITIVE_NUMBER (primitive));
  537.       (trinfo -> pc_info_2)       = primitive;
  538.       (trinfo -> extra_trap_info) = true;
  539.     }
  540.     else                /* In Interpreted or In UFO ?!?!?!?! */
  541.     {
  542.       (trinfo -> state)           = STATE_UNKNOWN;
  543.       (trinfo -> pc_info_1)       = 1; /* UFO[1]: Looked like a primitive */
  544.       (trinfo -> pc_info_2)       = the_pc;
  545.       (trinfo -> extra_trap_info) = primitive;
  546.     }
  547.   }
  548.   return (trinfo) ;
  549. }
  550.  
  551. /*****************************************************************************/
  552. static SCHEME_OBJECT
  553. DEFUN (pc_sample_flame_bad_table, (table_no, table), unsigned int  table_no AND
  554.                                                      SCHEME_OBJECT table)
  555. {
  556.   outf_error ("\nPC sample table (0x%x) find fault: ", table_no);
  557.  
  558.   if (table_no >= NFixed_Objects)
  559.     outf_error ("bad ucode band--- table out of range.") ;
  560.   else if (! (VECTOR_P(table)))
  561.     outf_error ("table was not a Scheme VECTOR.") ;
  562.   else
  563.     outf_error("Bloody mess, that!") ;
  564.  
  565.   outf_error ("\n") ;
  566.   outf_flush_error () ;
  567.  
  568.   return (UNSPECIFIC) ;        /* Fault: signal UNSPECIFIC */
  569. }
  570.  
  571. #ifndef PCS_TABLE_PARANOIA
  572. #define pc_sample_find_table(table_no) Get_Fixed_Obj_Slot (table_no)
  573. #else
  574. #define pc_sample_find_table(table_no) do                      \
  575. {                                          \
  576.   SCHEME_OBJECT table;                                  \
  577.                                           \
  578.   if (     (table_no < NFixed_Objects)                /* in band? */\
  579.       && ((table = (Get_Fixed_Obj_Slot (table_no))) != SHARP_F) /* enabled? */\
  580.       && (VECTOR_P(table))                    /*   valid? */\
  581.      )                /* Success: return vector */              \
  582.     return (table) ;                                  \
  583.   else if (table == SHARP_F)    /* Disabled: percolate #F */              \
  584.     return (SHARP_F) ;                                  \
  585.   else                /* fault: lay blame */                  \
  586.     pc_sample_flame_bad_table (table_no, table);                  \
  587. } while (FALSE)
  588. #endif    /* PCS_TABLE_PARANOIA */
  589.  
  590.  
  591. static unsigned long
  592. DEFUN (pc_sample_cc_block_index, (trinfo), struct trap_recovery_info * trinfo)
  593. {
  594.   /*  SCHEME_OBJECT block  = (trinfo -> pc_info_1);
  595.    *  unsigned int  offset = (trinfo -> pc_info_2);
  596.    */
  597.   /* SOME DAY....
  598.    * Compute unique ID for the entry in the code block as:
  599.    * code_block_ID + index_of_current_cc_block_entry
  600.    */
  601.   /* MUCH LATER             CC_BLOCK_ID    (block_addr) +
  602.    *       INDEX_OF_CURRENT_CC_BLOCK_ENTRY (block_addr, offset)) ;
  603.    *
  604.    * .... BUT UNTIL THAT DAY ARRIVES, just store a count
  605.    */
  606.  
  607.   return((unsigned long) 0) ;
  608. }
  609.  
  610. /*****************************************************************************/
  611. static unsigned long
  612. DEFUN (pc_sample_counter_index, (trinfo), struct trap_recovery_info * trinfo)
  613. {
  614.   /* For now, we just increment a single counter. Later a more exotic structure
  615.    * may be maintained.. like discriminated counters and a real-time histogram.
  616.    */
  617.  
  618.   return ((unsigned long) 0) ;
  619. }
  620.  
  621. /*****************************************************************************/
  622. static unsigned long
  623. DEFUN (pc_sample_indexed_table_index, (trinfo), struct trap_recovery_info * trinfo)
  624. {
  625.   /* pc_info_1 = index into Mumble_Procedure_Table */
  626.  
  627.   return ((unsigned long) (trinfo -> pc_info_1)) ;
  628. }
  629.  
  630. /*****************************************************************************/
  631. static void
  632. DEFUN (pc_sample_record_table_entry, (table, index), unsigned int  table  AND
  633.                                                      unsigned long index)
  634. {
  635.  
  636. #ifdef PCS_LOG_PUNTS        /* Punt warnings */
  637.   if (pc_sample_halted)
  638.   {
  639.     outf_console
  640.       ("\n; PC sample punted in the nick of time from table 0x%x[%d].\n",
  641.        table, index) ;
  642.     outf_flush_console () ;
  643.   }
  644.   else
  645. #endif
  646.  
  647.   {
  648.     /* For now, we just increment a counter. Later a more exotic structure
  649.      * may be maintained here.. like a counter and a real-time histogram...
  650.      */
  651.     double * fpp = ((double *) (MEMORY_LOC ((VECTOR_REF (table, index)), 1)));
  652.     
  653.     (*fpp) += 1.0;
  654.   }
  655. }
  656.  
  657.  
  658.  
  659.  
  660.  
  661.  
  662.  
  663.  
  664.  
  665. /*****************************************************************************
  666.  * Sample verbosity (console logging)...
  667.  *****************************************************************************/
  668.  
  669. /*---------------------------------------------------------------------------*/
  670. static void
  671. DEFUN (log_cobl_sample, (trinfo), struct trap_recovery_info * trinfo)
  672. { 
  673.   /* pc_info_1 = code block
  674.    * pc_info_2 = offset into block
  675.    * xtra_info = pc_in_constant_space
  676.    */
  677.   outf_console
  678.     ("; PC Sampler encountered a Compiled FNORD! 0x%x (off = %d, P(c) = %d%%)\n",
  679.      ((unsigned           long)(trinfo -> pc_info_1)       ),
  680.      ( UNSIGNED_FIXNUM_TO_LONG((trinfo -> pc_info_2))      ),
  681.      ((                    int)(trinfo -> extra_trap_info) )) ;
  682.   outf_flush_console () ;
  683. }
  684. /*---------------------------------------------------------------------------*/
  685. static void
  686. DEFUN (log_prob_comp_sample, (trinfo), struct trap_recovery_info * trinfo)
  687. {
  688.   /* pc_info_2 = the_pc (long)
  689.    * xtra_info = pc_in_constant_space
  690.    */
  691.   outf_console
  692.     ("; PC Sampler stumbled into a Prob Comp FNORD! at addr 0x%x (P(c) = %d%%)\n",
  693.      (trinfo -> pc_info_2), ((Boolean)(trinfo -> extra_trap_info))) ;
  694.   outf_flush_console () ;
  695. }
  696.  
  697. /*****************************************************************************
  698.  * More Sample verbosity (console logging)...
  699.  *****************************************************************************/
  700.  
  701. /*---------------------------------------------------------------------------*/
  702. static void
  703. DEFUN (log_UNKNOWN_STATE_sample, (trinfo), struct trap_recovery_info * trinfo)
  704. {
  705.   /* ``UNKNOWN_STATE'' samples are either interpreted procs or UFOs.
  706.    *     Any way you look at it, you lose. What's that you say...?
  707.    */
  708.   outf_console
  709.     ((((trinfo -> pc_info_1) == SHARP_T) /* pc_apparent_prim? */
  710.       ? "; PC Sampler taught it taw a pwimitive...\
  711.        \n; But it didn't.  It didn't taw a pwimitive."
  712.       : (((trinfo -> extra_trap_info) == SHARP_T) /* dreaded hyper space */
  713.      /*------------------------------------------------------------------*/
  714.      ? "; **** WARNING! WARNING! DANGER, WILL ROBINSON! DANGER!       ****\
  715.           \n; **** LOST IN HYPER SPACE! WE'RE DOOMED! DOOMED, I TELL YOU! ****\
  716.           \n; **** ALL DOOMED!! OH, THE PAIN!! THE PAIN!!!                ****"
  717.      /*------------------------------------------------------------------*/
  718.      : "; PC Sampler had a close encounter with an Unidentifiable Functional Object\
  719.           \n;  -- i.e., This is a UFO sighting!  Run for your life!!\
  720.       \n; ``You will be assimilated. Resistance is futile.''"))) ;
  721.      /*------------------------------------------------------------------*/
  722.   outf_console ("\n") ;
  723. }
  724. /*---------------------------------------------------------------------------*/
  725. static void
  726. DEFUN (log_interp_proc_sample, (trinfo), struct trap_recovery_info * trinfo)
  727. { 
  728.   /* pc_info_1 = pc_an_apparent_primitive
  729.    * pc_info_2 = the_pc
  730.    * extra_trap_info = /prim                if pc_info_1 = #T
  731.    *                   \pc_in_hyper_space   otherwise
  732.    */
  733.   outf_console
  734.     ("\n\
  735.       \n;---------------------------------------------------------------------\
  736.       \n; PC Sampler slogged down inside an interpreted bog\
  737.       \n;    in Loch 0x%x at Glen 0x%x.",
  738.      (trinfo -> pc_info_2),
  739.      (trinfo -> extra_trap_info)) ;
  740.   outf_console ("\n; The context was as follows:\n") ;
  741.   log_UNKNOWN_STATE_sample (trinfo) ;
  742.   outf_flush_console () ;
  743. }
  744. /*---------------------------------------------------------------------------*/
  745. static void
  746. DEFUN (log_UFO_sample, (trinfo), struct trap_recovery_info * trinfo)
  747. {
  748.   /* pc_info_1 = pc_an_apparent_primitive_flag
  749.    * pc_info_2 = the_pc
  750.    * xtra_info = /prim                if pc_info_1 = #T
  751.    *             \pc_in_hyper_space   otherwise
  752.    */
  753.   outf_console
  754.     ("\n\
  755.       \n;---------------------------------------------------------------------\
  756.       \n; BEGIN TRANSMISSION    \n;                           \
  757.       \n;          ^        \n;         ` `            \
  758.       \n;      _ `   ` _        \n;    \"  `     `  \"      \
  759.       \n;  \"   `       `   \"    \n;  \"   ` .` `. `   \"    \
  760.       \n;    \" `` _ _ `` \"    \n;      `       `        \n;\
  761.       \n; CAPTAINS'S LOG: ``UFO'' sighting at sector [0x%x] at warp [%d])\n",
  762.      ((unsigned long)(trinfo -> pc_info_2)),
  763.      (((trinfo -> pc_info_1) == SHARP_T)
  764.       ? ((unsigned long) (trinfo -> extra_trap_info))  /* pwimitive   */
  765.       : (      (Boolean) (trinfo -> extra_trap_info))) /* hyperspace? */
  766.      ) ;
  767.   log_UNKNOWN_STATE_sample (trinfo) ;
  768.   outf_console
  769.     ("\n\
  770.       \n; END TRANSMISSION\
  771.       \n;---------------------------------------------------------------------\
  772.       \n") ;
  773.   outf_flush_console () ;
  774. }
  775.  
  776. /*****************************************************************************/
  777. static void
  778. DEFUN (pc_sample_update_table, (PC_Sample_Table, trinfo, index_func_ptr),
  779.                                 unsigned int PC_Sample_Table        AND
  780.                                 struct trap_recovery_info * trinfo  AND
  781.                                 unsigned long (* index_func_ptr)())
  782. {
  783.   SCHEME_OBJECT table = UNSPECIFIC;
  784.   unsigned long index;
  785.  
  786. #if (   defined(PCS_LOG)        /* Sample logging */              \
  787.      || defined(PCS_LOG_PROB_COMP)                          \
  788.      )
  789.   if (PC_Sample_Table == PC_Sample_Prob_Comp_Table)
  790.     log_prob_comp_sample (trinfo) ;
  791. #endif
  792.  
  793. #if (   defined(PCS_LOG)        /* Sample logging */              \
  794.      || defined(PCS_LOG_UFO)                              \
  795.      )
  796.   if (PC_Sample_Table == PC_Sample_UFO_Table)
  797.     log_UFO_sample (trinfo) ;
  798. #endif
  799.  
  800.   if ((table = pc_sample_find_table (PC_Sample_Table)) == SHARP_F)
  801.   {
  802.     /* Samples of this type are disabled, so drop the sample on the floor */
  803.     /* for now... later count drops */
  804.     return;
  805.   }
  806.   else
  807.   {
  808.     index = ((* index_func_ptr)(trinfo)) ;
  809.  
  810. #ifdef PCS_TABLE_PARANOIA
  811.     if (   (VECTOR_P     (table)        )
  812.     && (VECTOR_LENGTH(table) > index)
  813.     )
  814.     {
  815. #endif    /* ------------------------------ PARANOIA OVERDRIVE --------------. */
  816.                                         /* | */
  817.       if (   (PC_Sample_Table == PC_Sample_Primitive_Table)        /* | */
  818.       && (            index == Garbage_Collect_Primitive_Index)    /* | */
  819.       )                                /* | */
  820.     /* Yow! The primitives sample table will be moved by the GC   *//* | */
  821.     /*      so storing into it can lose by storing into the old   *//* | */
  822.     /*      (broken heart) address.                      *//* | */
  823.     /*                                  *//* | */
  824.     /*      To avoid this, we keep a count of GC samples until    *//* | */
  825.     /*      the GC is over then add the GC_samples to the GC      *//* | */
  826.     /*      primitive's sample entry.                  *//* | */
  827.     /*                                  *//* | */
  828.     /*      GJR installed gc_hooks for just this purpose.          *//* | */
  829.     /*      Damned sporting of him, I must say.              *//* | */
  830.     /*                                  *//* | */
  831.     GC_samples += 1;                        /* | */
  832.       else                                /* | */
  833.     (pc_sample_record_table_entry (table, index)) ;            /* | */
  834.                                         /* | */
  835. #ifdef PCS_TABLE_PARANOIA /* <----------- PARANOIA OVERDRIVE --------------' */
  836.     }
  837.     else if (VECTOR_P(table))      /* index was out of range */
  838.     {
  839.       outf_error
  840.     ("\nPC sample table (0x%x) update fault: index out of range-- %d >= %d.\n",
  841.      PC_Sample_Table, index, (VECTOR_LENGTH(table))) ;
  842.       outf_flush_error () ;
  843.     }
  844.     else if (table == UNSPECIFIC) /* fault */
  845.       return; /* Let it slide: already flamed about it in finder. */
  846.     else               /* something's broken */
  847.     {
  848.       outf_error ("\nPC sample find table do a poo-poo, do a poo-poo.\n") ;
  849.       outf_flush_error () ;
  850.     }
  851. #endif  /*  PCS_TABLE_PARANOIA */
  852.   }
  853. }
  854.  
  855. /*****************************************************************************/
  856. struct profile_buffer_state
  857. {
  858.      char * name;            /* name string */
  859.  
  860.   unsigned  int ID;                /* indices into the Fixed Obj Vector */
  861.   unsigned  int ID_aux;                /*    ... for the buffer(s)          */
  862.  
  863.     Boolean enabled_flag;            /* the buffer qua buffer, as it were */
  864.   SCHEME_OBJECT buffer;
  865.   SCHEME_OBJECT buffer_aux;
  866.   unsigned long length;
  867.   unsigned long next_empty_slot_index;
  868.  
  869.   unsigned long slack;            /* flush/extend nearness thresholds */
  870.        long slack_increment;
  871.  
  872.   unsigned  int     flush_INT;        /* Interrupt request bits */
  873.   unsigned  int extend_INT;
  874.  
  875.     Boolean       flush_noisy_flag;     /* verbosity flags for monitoring    */
  876.     Boolean      extend_noisy_flag;    /*  ... buffer parameter performance */
  877.         Boolean overflow_noisy_flag;
  878.  
  879.     Boolean     flush_immed_flag;    /* debuggery hook */
  880.  
  881.     Boolean        debug_flag;     /* random hook */
  882.     Boolean      monitor_flag;     /* random hook */
  883.  
  884.   unsigned long    flush_count;        /* Counts for performance monitoring */
  885.   unsigned long   extend_count;
  886.   unsigned long overflow_count;
  887.  
  888.   SCHEME_OBJECT extra_buffer_state_info; /* etc hook for future extensions */
  889. };
  890.  
  891. /*****************************************************************************/
  892. static void
  893. DEFUN (init_profile_buffer_state, (pbs_ptr,
  894.                    name, ID, ID_aux, slack, slack_increment,
  895.                    flush_INT, extend_INT),
  896.        struct profile_buffer_state * pbs_ptr          AND
  897.                   char * name          AND
  898.                unsigned int  ID              AND
  899.                unsigned int  ID_aux          AND
  900.                unsigned long slack          AND
  901.                 long slack_increment  AND
  902.                unsigned int   flush_INT          AND
  903.                unsigned int  extend_INT)
  904. {
  905.   (pbs_ptr -> name)            = name;            /* arg */
  906.   (pbs_ptr -> ID)            = ID;            /* arg */
  907.   (pbs_ptr -> ID_aux)            = ID_aux;        /* arg */
  908.   (pbs_ptr -> enabled_flag)        = false;
  909.   (pbs_ptr -> buffer)            = UNSPECIFIC;
  910.   (pbs_ptr -> buffer_aux)        = UNSPECIFIC;
  911.   (pbs_ptr -> length)            = ((unsigned long) 0);
  912.   (pbs_ptr -> next_empty_slot_index)    = ((unsigned long) 0);
  913.   (pbs_ptr -> slack)            = slack;        /* arg */
  914.   (pbs_ptr -> slack_increment)        = slack_increment;    /* arg */
  915.   (pbs_ptr ->  flush_INT)        =  flush_INT;        /* arg */
  916.   (pbs_ptr -> extend_INT)        = extend_INT;        /* arg */
  917.   (pbs_ptr ->    flush_noisy_flag)    = false;
  918.   (pbs_ptr ->   extend_noisy_flag)    = false;
  919.   (pbs_ptr -> overflow_noisy_flag)    =  true;
  920.   (pbs_ptr ->    flush_immed_flag)    = false;
  921.   (pbs_ptr ->           debug_flag)    = false; /* i.e. no count flush/xtnd */
  922.   (pbs_ptr ->         monitor_flag)    =  true; /* i.e. count buf overflows */
  923.   (pbs_ptr ->    flush_count)        = ((unsigned long) 0);
  924.   (pbs_ptr ->   extend_count)        = ((unsigned long) 0);
  925.   (pbs_ptr -> overflow_count)        = ((unsigned long) 0);
  926.   (pbs_ptr -> extra_buffer_state_info)    = SHARP_F;
  927. }
  928. /*---------------------------------------------------------------------------*/
  929. #define init_profile_bi_buffer_state(pbs_ptr,                      \
  930.                      name, ID, ID_aux, slack, slack_increment,\
  931.                      flush_INT, extend_INT)              \
  932.        init_profile_buffer_state(pbs_ptr,                      \
  933.                      name, ID, ID_aux, slack, slack_increment,\
  934.                      flush_INT, extend_INT)
  935.  
  936. #define init_profile_uni_buffer_state(pbs_ptr,                      \
  937.                      name, ID,           slack, slack_increment,\
  938.                      flush_INT, extend_INT)              \
  939.        init_profile_buffer_state(pbs_ptr,                      \
  940.                      name, ID, false,  slack, slack_increment,\
  941.                      flush_INT, extend_INT)
  942. /*...........................................................................*\
  943. |*. For example...                                 *|
  944. \*...........................................................................*/
  945.  
  946. static struct profile_buffer_state dummy_profile_buffer_state;
  947.  
  948. static void
  949. DEFUN_VOID (init_dummy_profile_buffer_state)
  950. {
  951.   init_profile_buffer_state(&dummy_profile_buffer_state,
  952.                 "PBS Fnord!",        /* name         */
  953.                 false,            /* ID         */
  954.                 false,            /* ID_aux    */
  955.                 ((unsigned long) 0),    /* slack     */
  956.                 ((         long) 0),    /* slack_inc */
  957.                 ((unsigned  int) 0),    /* flush_INT */
  958.                 ((unsigned  int) 0)        /* extnd_INT */
  959.                 );
  960. }
  961. /*---------------------------------------------------------------------------*/
  962.  
  963. /*****************************************************************************/
  964. static void
  965. DEFUN (pc_sample_record_bi_buffer_entry, (entry, entry_aux, PBS),
  966.        SCHEME_OBJECT entry                AND
  967.        SCHEME_OBJECT entry_aux          AND
  968.        struct profile_buffer_state * PBS)
  969. {
  970.   /* Cache some useful state values */
  971.  
  972.   unsigned long buffer_length         = (PBS -> length               ) ;
  973.   unsigned long next_empty_slot_index = (PBS -> next_empty_slot_index) ;
  974.  
  975.   if (next_empty_slot_index >= buffer_length)
  976.   {
  977.     (PBS -> next_empty_slot_index) = buffer_length - 1 ;
  978.     if (PBS -> overflow_noisy_flag)
  979.     {
  980.       outf_error ("\n\nBloody Hell! The bloody %s bloody overflowed.\n",
  981.           (PBS -> name)) ;
  982.       outf_flush_error () ;
  983.     }
  984.     if (PBS -> monitor_flag)
  985.       (PBS -> overflow_count) += 1;
  986.   }
  987.  
  988. #ifdef PCS_LOG_PUNTS        /* Punt warnings */
  989.   else if (pc_sample_halted)
  990.   {
  991.     outf_console ("\n; PC sample %s entry punted in the nick of time.\n",
  992.           (PBS -> name)) ;
  993.     outf_flush_console () ;
  994.  
  995.     return;
  996.   }
  997. #endif
  998.  
  999.   else
  1000.   {
  1001.     unsigned long next_index_plus_slack ;
  1002.  
  1003.     /* Cache some more useful state values */
  1004.  
  1005.     Boolean uni_buffer_flag = (! (PBS -> ID_aux)) ;
  1006.  
  1007.     SCHEME_OBJECT  buffer     = (PBS -> buffer    ) ;
  1008.     SCHEME_OBJECT  buffer_aux = (PBS -> buffer_aux) ;
  1009.     unsigned long slack       = (PBS -> slack     ) ;
  1010.     unsigned  int  flush_INT  = (PBS ->  flush_INT) ;
  1011.     unsigned  int extend_INT  = (PBS -> extend_INT) ;
  1012.  
  1013.     (  VECTOR_SET(buffer    , next_empty_slot_index, entry    )) ;
  1014.     if (! uni_buffer_flag)
  1015.       (VECTOR_SET(buffer_aux, next_empty_slot_index, entry_aux)) ;
  1016.  
  1017.     next_empty_slot_index += 1 ;                  /* incr  cache */
  1018.     (PBS -> next_empty_slot_index) = next_empty_slot_index ; /* synch cache */
  1019.  
  1020.     next_index_plus_slack = next_empty_slot_index + slack ;
  1021.  
  1022. #ifdef PCS_FLUSH_DEBUGGERY    /* Flush debuggering */
  1023.     outf_console (";============================================\n") ;
  1024.     outf_console ("; name == %s\n", (PBS -> name)                  ) ;
  1025.     outf_console ("; ni+s == %d\n", next_index_plus_slack          ) ;
  1026.     outf_console ("; blen == %d\n", buffer_length                  ) ;
  1027.     outf_console ("; nmti == %d\n", next_empty_slot_index          ) ;
  1028.     outf_console ("; slak == %d\n", slack                          ) ;
  1029.     outf_console ("; BFQP == %d\n", INTERRUPT_QUEUED_P ( flush_INT)) ;
  1030.     outf_console ("; BFXP == %d\n", INTERRUPT_QUEUED_P (extend_INT)) ;
  1031.     outf_flush_console () ;
  1032. #endif
  1033.  
  1034.  
  1035.     /* ... continued on next page ... */
  1036.  
  1037.     /* ... pc_sample_record_bi_buffer_entry: continued from previous page... */
  1038.  
  1039.     /* Buffer Nearly Full (or unsigned overflow) ? */
  1040.  
  1041.     if (   (next_index_plus_slack > buffer_length)        /* nearfull */
  1042.     || (next_index_plus_slack < next_empty_slot_index) /* overflow */
  1043.     || (next_index_plus_slack < slack                ) /* overflow */
  1044.     || (PBS -> flush_immed_flag)             /* Flush debuggering */
  1045.     )
  1046.     { 
  1047.       if (! (INTERRUPT_QUEUED_P(flush_INT)))
  1048.       {
  1049.     REQUEST_INTERRUPT(flush_INT) ;
  1050.     if    (PBS -> flush_noisy_flag)
  1051.     { outf_console ("\n;>>>>>>>>>  %s Flush Request issued.",
  1052.             (PBS -> name)) ;  outf_flush_console () ;
  1053.     }
  1054.     if   ((PBS -> debug_flag) && (PBS -> monitor_flag)) /* can monitor */
  1055.       (PBS -> flush_count) += 1;                 /*  in runtime */
  1056.       }
  1057.       else if (PBS -> flush_noisy_flag)
  1058.       { outf_console ("\n;>>  >>  >  %s Flush Request still queued.",
  1059.               (PBS -> name)) ;  outf_flush_console () ;
  1060.       }
  1061.     }
  1062.  
  1063.     /* Buffer Full? */
  1064.  
  1065.     if (   (! (INTERRUPT_QUEUED_P (extend_INT)))
  1066.     && (next_empty_slot_index >= buffer_length)     /* > is PARANOIA */
  1067.     )
  1068.     { 
  1069.       int slack_inc_neg_p     ; /* Gonna cut the slack a little slack */
  1070.       unsigned long new_slack ; /*  to increase our margin of safety. */
  1071.  
  1072.       /* Cache one last useful state value */
  1073.  
  1074.       long slack_increment = (PBS -> slack_increment) ;
  1075.  
  1076.       /* Back up the next slot pointer so we don't go out of range */
  1077.  
  1078.       (PBS -> next_empty_slot_index) = buffer_length - 1 ;
  1079.  
  1080.       /* Increase slack to attempt to avoid additional overflows */
  1081.  
  1082.       slack_inc_neg_p = (slack_increment < 0) ;
  1083.       new_slack = (slack_inc_neg_p
  1084.            ? slack - ((unsigned long) (- slack_increment))
  1085.            : slack + ((unsigned long)    slack_increment )) ;
  1086.  
  1087.       if      (   slack_inc_neg_p  && (new_slack > slack)) 
  1088.     new_slack = 1     ;    /* unsigned underflow: min to 1 */
  1089.       else if ((! slack_inc_neg_p) && (new_slack < slack))
  1090.     new_slack = slack ;    /* unsigned  overflow: max to old value */
  1091.  
  1092.       (PBS -> slack) = new_slack ;
  1093.  
  1094.       /* Issue extend request */
  1095.  
  1096.       REQUEST_INTERRUPT (extend_INT) ;
  1097.       if     (PBS -> extend_noisy_flag)
  1098.       { outf_console ("\n;>>>>>>>>>  %s Extend Request issued.", 
  1099.               (PBS -> name)) ;  outf_flush_console () ;
  1100.       }
  1101.       if    ((PBS -> debug_flag) && (PBS -> monitor_flag)) /* can monitor */
  1102.     (PBS -> extend_count) += 1;                /*  in runtime */
  1103.     }
  1104.     else if ((PBS -> extend_noisy_flag) && (INTERRUPT_QUEUED_P (extend_INT)))
  1105.     { outf_console ("\n;>>  >>  >  %s Extend Request still queued.",
  1106.             (PBS -> name)) ;  outf_flush_console () ;
  1107.     }
  1108.   }
  1109. }
  1110. /*...........................................................................*/
  1111. #define FNORD UNSPECIFIC
  1112.  
  1113. #define pc_sample_record_buffer_entry(entry,        PBS) /* uni_buffer is a */\
  1114.      pc_sample_record_bi_buffer_entry(entry, FNORD, PBS) /* ...special case */
  1115.  
  1116. /*****************************************************************************/
  1117. static void
  1118. DEFUN (pc_sample_update_bi_buffer, (buffer_state, trinfo, record_func_ptr),
  1119.        struct profile_buffer_state * buffer_state  AND
  1120.        struct   trap_recovery_info * trinfo        AND
  1121.        void (* record_func_ptr)())
  1122. {
  1123.   /* Like interp-procs, wanna maintain a hashtable of instances encountered,
  1124.    * so we maintain a buffer and defer to an interrupt handler to flush and
  1125.    * extend the buffer as needed. Both the code block and the offset into the
  1126.    * code block are informative (since code blocks can contain multiple
  1127.    * definitions) so both are stored in synchronized buffers [i.e., slot N of
  1128.    * each of two buffers stores the Nth sampled code block and its associated
  1129.    * code block offset].
  1130.    *
  1131.    * Moreover, purified (non-relocateable) code blocks are distinguished from
  1132.    * non-purified (``heathen''?) code blocks since the GC can move the latter
  1133.    * around but not the former...meaning that purified ones can be hashed off
  1134.    * their addr/offset alone whereas heathens must be obj hashed (christened?).
  1135.    *
  1136.    * FOR PURIFIED CODE BLOCKS...
  1137.    * Win. Location is fixed so needn't sweat GC re-location
  1138.    * For now, buffer addr/offset pairs for later hashing.
  1139.    *
  1140.    * FOR HEATHEN CODE BLOCKS...
  1141.    * Sigh. GC can re-locate, so buffer SCHEME_OBJ ptr for hashing.
  1142.    * For now, buffer away the re-locatable addr & offset for later hashing.
  1143.    *
  1144.    * Once we arrange for the linker/loader to embed a hash code, we can just
  1145.    * use that instead of buffered add/offset pairs.
  1146.    */
  1147.  
  1148. #ifndef PCS_FOV_SNARK_HUNT
  1149.  
  1150.   if (buffer_state -> enabled_flag)
  1151.     ((* record_func_ptr)(trinfo)) ;
  1152.   else
  1153.   {
  1154.     /* Samples of this type are disabled, so drop the sample on the floor */
  1155.     /* for now... later count drops */
  1156.     return;
  1157.   }
  1158.  
  1159.   return;
  1160.  
  1161.  
  1162.     /* ... continued on next page ... */
  1163.  
  1164.       /* ... pc_sample_update_bi_buffer: continued from previous page ... */
  1165.  
  1166.  
  1167.  
  1168. #else  /* PCS_FOV_SNARK_HUNT */
  1169.  
  1170.   Boolean uni_buffer_flag = (! (buffer_state -> ID_aux)) ;
  1171.  
  1172.   SCHEME_OBJECT buffer_1 =    (pc_sample_find_table (buffer_state -> ID    )) ;
  1173.   SCHEME_OBJECT buffer_2 = (uni_buffer_flag
  1174.                 ? SHARP_F         /* treat as if disabled */
  1175.                 : (pc_sample_find_table (buffer_state -> ID_aux)));
  1176.  
  1177.   if (   (VECTOR_P (buffer_1))            /* massive paranoia...           */
  1178.       && (uni_buffer_flag || (VECTOR_P (buffer_2)))
  1179.       && (buffer_state -> enabled_flag)    /* ... flag alone should suffice */
  1180.       )
  1181.     ((* record_func_ptr)(trinfo)) ;
  1182.  
  1183.   /* very paranoid debuggery... should just return now, no questions asked */
  1184.  
  1185.   else if (   (buffer_1 == SHARP_F   )            /* buffer_1 disabled?       */
  1186.        || (buffer_1 == UNSPECIFIC)            /* buffer_1 un-initialized  */
  1187.        || (   (!  uni_buffer_flag)            /* regardez buffer_2?       */
  1188.            && (   (buffer_2 == SHARP_F   ) /* buffer_2 disabled?       */
  1189.            || (buffer_2 == UNSPECIFIC) /* buffer_2 un-initialized? */
  1190.            )
  1191.           )
  1192.       )
  1193.   {
  1194.  
  1195. #ifdef PCS_PBS_ENABLE_PARANOIA            /* Paranoia */
  1196.     if (buffer_state -> enabled_flag)
  1197.     {
  1198.       outf_error ("\nSigh. %s looked enabled but is disabled.\n",
  1199.           (buffer_state -> name)) ;
  1200.       outf_flush_error () ;
  1201.     }
  1202. #endif
  1203.  
  1204.     return;  /* Let it slide: find_table will have flamed if appropriate. */
  1205.   }
  1206.   else
  1207.   {
  1208.     outf_error ("\nThere's something rotten in the state of update_buffer\n") ;
  1209.     outf_flush_error () ;
  1210.   }
  1211.  
  1212. #endif  /* PCS_FOV_SNARK_HUNT */
  1213.  
  1214. }
  1215. /*...........................................................................*/
  1216.  
  1217. #define pc_sample_update_buffer(buffer_state, trinfo, record_func_ptr)        \
  1218.      pc_sample_update_bi_buffer(buffer_state, trinfo, record_func_ptr)/* aka */
  1219.  
  1220. /*****************************************************************************/
  1221. #include "pcsiproc.c"        /* (Interpreted) Interp-Proc sampling */
  1222. #include "pcscobl.c"        /*    (Compiled)  Code Block sampling */ 
  1223.  
  1224. #define VALID_PC_SAMPLE_ENV_P(env) ((OBJECT_TYPE (env) == TC_ENVIRONMENT))
  1225. /*****************************************************************************/
  1226. static void
  1227. DEFUN (pc_sample_record, (trinfo), struct trap_recovery_info * trinfo)
  1228. {
  1229.  
  1230. #ifdef PCS_LOG_PUNTS        /* Punt warnings */
  1231.   if (pc_sample_halted)
  1232.   {
  1233.     outf_console
  1234.       ("\n; PC sample punted at the last moment: HALTED flag set.\n");
  1235.     outf_flush_console ();
  1236.   }
  1237.   else
  1238. #endif
  1239.  
  1240.   {
  1241.     switch (trinfo -> state)
  1242.     {
  1243.       case STATE_BUILTIN:
  1244.            pc_sample_update_table (PC_Sample_Builtin_Table,     trinfo,
  1245.                    pc_sample_indexed_table_index);
  1246.        break;
  1247.       case STATE_UTILITY:
  1248.        pc_sample_update_table (PC_Sample_Utility_Table,     trinfo,
  1249.                    pc_sample_indexed_table_index);
  1250.        break;
  1251.       case STATE_PRIMITIVE:
  1252.        pc_sample_update_table (PC_Sample_Primitive_Table,   trinfo,
  1253.                    pc_sample_indexed_table_index);
  1254.        break;
  1255.       case STATE_PROBABLY_COMPILED:
  1256.        pc_sample_update_table (PC_Sample_Prob_Comp_Table,   trinfo,
  1257.                    pc_sample_indexed_table_index);
  1258.        break;
  1259.       case STATE_COMPILED_CODE:
  1260.        pc_sample_update_table (PC_Sample_Code_Block_Table,  trinfo,
  1261.                    pc_sample_cc_block_index);
  1262.  
  1263.        /* Above line is a back door for future expansion...real code is: */
  1264.  
  1265.        (((Boolean)(trinfo -> extra_trap_info)) /* pc_in_constant_space */
  1266.         ? (pc_sample_update_bi_buffer (&purified_cobl_profile_buffer_state,
  1267.                        trinfo,
  1268.                        pc_sample_record_purified_cobl))
  1269.         : (pc_sample_update_bi_buffer (& heathen_cobl_profile_buffer_state,
  1270.                        trinfo,
  1271.                        pc_sample_record_heathen_cobl))) ;
  1272.        break;
  1273.       case STATE_UNKNOWN:  /* i.e., in interpreted code or in hyper space */
  1274.        /* Hope we're in interpreted code and attempt to deduce the current
  1275.         * interp-proc from the current active environment frame anyway.
  1276.         * GJR suggested nabbing the current ENV to find the current PROC,
  1277.         * warning that the current ENV may be invalid, e.g. in the middle
  1278.         * of a LOAD.  In that case we are S.O.L., so record a UFO.  Sigh.
  1279.         */
  1280.        ((VALID_PC_SAMPLE_ENV_P (pc_sample_current_env_frame = Fetch_Env()))
  1281.         ? pc_sample_update_buffer (&interp_proc_profile_buffer_state,
  1282.                        trinfo,
  1283.                        pc_sample_record_interp_proc)
  1284.         : pc_sample_update_table  (PC_Sample_UFO_Table,
  1285.                        trinfo,
  1286.                        pc_sample_indexed_table_index)) ;
  1287.        break;
  1288.     }
  1289.   }
  1290. }
  1291.  
  1292. /*****************************************************************************/
  1293. void
  1294. DEFUN (pc_sample, (scp), struct FULL_SIGCONTEXT * scp)
  1295. {
  1296.  
  1297. #ifdef PCS_LOG_PUNTS        /* Punt warnings */
  1298.   if (pc_sample_halted)
  1299.   {
  1300.     outf_console ("\n; PC sample called but punted due to halt flag.\n") ;
  1301.     outf_flush_console () ;
  1302.   }
  1303.   else
  1304. #endif
  1305.  
  1306.     if (pc_sample_within_GC_flag)
  1307.       GC_samples += 1;
  1308.     else
  1309.     {
  1310.       struct trap_recovery_info                        trinfo ;
  1311.  
  1312.       (pc_sample_record (find_sigcontext_ptr_pc (scp, &trinfo)));
  1313.  
  1314. #ifdef PCS_LOG            /* Sample logging */
  1315.       outf_console ("; PC sample called.\n") ;
  1316.       outf_flush_console () ;
  1317. #endif
  1318.  
  1319.     }
  1320. }
  1321.  
  1322. /*****************************************************************************/
  1323. static int
  1324. DEFUN_VOID (pc_sample_install_gc_synch_gc_hooks)
  1325. {
  1326.   static int stat = -1;        /* some clown may call this more than once */
  1327.  
  1328.   if (stat != 0)
  1329.   {
  1330.     if      ((stat =  add_pre_gc_hook(pc_sample__pre_gc_gc_synch_hook)) != 0)
  1331.       outf_error (";Could not add pre_gc GC synch hook. You.lose\n");
  1332.  
  1333.     else if ((stat = add_post_gc_hook(pc_sample_post_gc_gc_synch_hook)) != 0)
  1334.       outf_error (";Could not add post_gc GC synch hook. You.lose\n");
  1335.  
  1336.     else if ((stat = add_post_gc_hook(resynch_IPPB_post_gc_hook)) != 0)
  1337.       outf_error (";Could not add post GC IPPB re-synch hook. You.lose\n");
  1338.  
  1339.     else if ((stat = add_post_gc_hook(resynch_CBPBs_post_gc_hook)) != 0)
  1340.       outf_error (";Could not add post GC CBPB re-synch hook. You.lose\n");
  1341.  
  1342.     outf_flush_error () ;
  1343.   }
  1344.   return (stat);
  1345. }
  1346. /*---------------------------------------------------------------------------*/
  1347. DEFINE_PRIMITIVE ("%PC-SAMPLE/INSTALL-GC-SYNCH-GC-HOOKS",
  1348.           Prim_pc_sample_install_gc_synch_gc_hooks, 0, 0,
  1349.  "()\n\
  1350.   This must be called once when PC sampling is enabled.\n\
  1351.   \n\
  1352.   If it returns #F then PC sampling must be disabled.  You.lose\
  1353.  ")
  1354. {
  1355.   PRIMITIVE_HEADER(0);
  1356.   PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT ((pc_sample_install_gc_synch_gc_hooks() == 0)));
  1357. }
  1358.  
  1359. /*****************************************************************************/
  1360. static void
  1361. DEFUN_VOID (pc_sample_disable_microcode)
  1362. {
  1363.     IPPB_disable ();        /* From pcsiproc.c */
  1364.    CBPBs_disable ();        /* From pcscobl.c  */
  1365. }
  1366. /*---------------------------------------------------------------------------*/
  1367. /*---------------------------------------------------------------------------*/
  1368. static void
  1369. DEFUN_VOID (pc_sample_init_profile_buffer_states)
  1370. {
  1371.   init_dummy_profile_buffer_state ();
  1372.    init_IPPB_profile_buffer_state ();
  1373.    init_CBPB_profile_buffer_states();
  1374. }
  1375. /*---------------------------------------------------------------------------*/
  1376. static int
  1377. DEFUN_VOID (pc_sample_install_microcode)
  1378. {
  1379.   static int stat = -1;        /* Some clown may call this more than once */
  1380.  
  1381.   if (stat != 0)
  1382.   {
  1383.     if (! (Valid_Fixed_Obj_Vector ())) /* Profile tables are in the FOV */
  1384.     {
  1385.       outf_error
  1386.     ("\npc_sample_install_microcode encountered an invalid Fixed Obj Vector.\n") ;
  1387.       outf_flush_error () ;
  1388.     }
  1389.     else            /* safe to init */
  1390.     {
  1391.       pc_sample_cache_GC_primitive_index();
  1392.  
  1393.       pc_sample_init_profile_buffer_states();
  1394.  
  1395.       if ((stat = pc_sample_install_gc_synch_gc_hooks()) != 0) /* Once only! */
  1396.       {
  1397.     outf_error
  1398.       ("; PC Sample GC synch GC hooks installation failed (0x%x)\n");
  1399.     outf_flush_error () ;
  1400.       }
  1401.       /* ... maybe more stuff here later ... */
  1402.  
  1403.       if (stat != 0)
  1404.       {
  1405.     outf_error ("; PC Sample installation failed.  You.lose\n");
  1406.     outf_flush_error () ;
  1407.       }
  1408.     }
  1409.   }
  1410.   return (stat);
  1411. }
  1412. /*---------------------------------------------------------------------------*/
  1413. /*---------------------------------------------------------------------------*/
  1414. DEFINE_PRIMITIVE ("%PC-SAMPLE/INSTALL-MICROCODE",
  1415.           Prim_pc_sample_install_microcode, 0, 0,
  1416.  "()\n\
  1417.   Installs the microcode support structures for PC sampling.\
  1418.  ")
  1419. {
  1420.   PRIMITIVE_HEADER(0);
  1421.   PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT ((pc_sample_install_microcode() == 0)));
  1422. }
  1423. /*---------------------------------------------------------------------------*/
  1424. DEFINE_PRIMITIVE ("%PC-SAMPLE/DISABLE-MICROCODE",
  1425.           Prim_pc_sample_disable_microcode, 0, 0,
  1426.   "()\n\
  1427.   Disables the microcode support structures for PC sampling.\
  1428.  ")
  1429. {
  1430.   PRIMITIVE_HEADER(0);
  1431.   pc_sample_disable_microcode ();
  1432.   PRIMITIVE_RETURN (UNSPECIFIC) ;
  1433. }
  1434. /*****************************************************************************/
  1435.  
  1436. /* Zone operations
  1437.  
  1438.    These are not locked agains PC-Sampling activity but they are safe
  1439.    in the sense that they will at worst gain or lose a sample
  1440. */
  1441.  
  1442. DEFINE_PRIMITIVE ("%PC-SAMPLE/SET-ZONE!",
  1443.           Prim_pc_sample_set_current_zone, 1, 1,
  1444.   "(index)\n\
  1445. Set current pc-sampling zone to INDEX (a small exact integer), returning \
  1446. the previous value if different, else #F if same.")
  1447. {
  1448.     PRIMITIVE_HEADER(1);
  1449.     {
  1450.     int  old_zone = current_zone;
  1451.     int  new_zone = arg_index_integer (1, INITIAL_ZONE_LIMIT);
  1452.     if (old_zone == new_zone) {
  1453.         PRIMITIVE_RETURN (SHARP_F);
  1454.     } else {
  1455.         current_zone = new_zone;
  1456.         PRIMITIVE_RETURN (LONG_TO_FIXNUM(old_zone));
  1457.     }
  1458.     }
  1459. }
  1460.  
  1461. DEFINE_PRIMITIVE ("%PC-SAMPLE/MAX-ZONE",
  1462.           Prim_pc_sample_get_max_zone, 0, 0, 0)
  1463. {
  1464.     PRIMITIVE_HEADER(0);
  1465.     PRIMITIVE_RETURN(LONG_TO_FIXNUM(max_zone));
  1466. }
  1467.  
  1468. DEFINE_PRIMITIVE ("%PC-SAMPLE/CLEAR-ZONES!", Prim_pc_sample_clear_zones, 0, 0,
  1469.   "()\n\
  1470. Zero zone counts.")
  1471. {
  1472.     PRIMITIVE_HEADER (0);
  1473.     {
  1474.     int  i;
  1475.     for (i = 0; i < max_zone; i++) zones[i] = 0.0;
  1476.     }
  1477.     PRIMITIVE_RETURN(UNSPECIFIC);
  1478. }
  1479.  
  1480. DEFINE_PRIMITIVE ("%PC-SAMPLE/READ-ZONES!", Prim_pc_sample_read_zones, 1, 1,
  1481.   "(flonum-vector)\n\
  1482. Copy zone counts into FLONUM-VECTOR.  Returns the number copied, which \
  1483. is limited by either the number of zones to the capacity of FLONUM-VECTOR.")
  1484. {
  1485.     PRIMITIVE_HEADER (1);
  1486.     {
  1487.     SCHEME_OBJECT vector = (FLOATING_VECTOR_ARG (1));
  1488.     int length = FLOATING_VECTOR_LENGTH (vector);
  1489.     int limit = (length<max_zone) ? length : max_zone;
  1490.     int i;
  1491.     for (i = 0; i < limit; i++)
  1492.       FLOATING_VECTOR_SET (vector, i, zones[i]);
  1493.     PRIMITIVE_RETURN (LONG_TO_FIXNUM(limit));    
  1494.     }
  1495. }
  1496.  
  1497. #endif /* HAVE_ITIMER */
  1498. #endif /* REALLY_INCLUDE_PROFILE_CODE */
  1499.