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 / microcode / xdebug.c < prev    next >
C/C++ Source or Header  |  2000-12-05  |  8KB  |  296 lines
  1. /* -*-C-*-
  2.  
  3. $Id: xdebug.c,v 9.34 2000/12/05 21:23:49 cph Exp $
  4.  
  5. Copyright (c) 1987-2000 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. /* This file contains primitives to debug memory management. */
  23.  
  24. #include "scheme.h"
  25. #include "prims.h"
  26.  
  27. /* New debugging utilities */
  28.  
  29. #define FULL_EQ        0
  30. #define ADDRESS_EQ    2
  31. #define DATUM_EQ    3
  32.  
  33. static SCHEME_OBJECT *
  34. DEFUN (Find_Occurrence, (From, To, What, Mode),
  35.        fast SCHEME_OBJECT * From
  36.        AND fast SCHEME_OBJECT * To
  37.        AND SCHEME_OBJECT What
  38.        AND int Mode)
  39. {
  40.   fast SCHEME_OBJECT Obj;
  41.  
  42.   switch (Mode)
  43.   { default:
  44.     case FULL_EQ:
  45.     {
  46.       Obj = What;
  47.       for (; From < To; From++)
  48.       {
  49.     if (OBJECT_TYPE (*From) == TC_MANIFEST_NM_VECTOR)
  50.     {
  51.       From += OBJECT_DATUM (*From);
  52.     }
  53.     else if (*From == Obj)
  54.     {
  55.       return From;
  56.     }
  57.       }
  58.      return To;
  59.     }
  60.  
  61.     case ADDRESS_EQ:
  62.     {
  63.       Obj = OBJECT_DATUM (What);
  64.       for (; From < To; From++)
  65.       {
  66.     if (OBJECT_TYPE (*From) == TC_MANIFEST_NM_VECTOR)
  67.     {
  68.       From += OBJECT_DATUM (*From);
  69.     }
  70.     else if ((OBJECT_DATUM (*From) == Obj) &&
  71.          (!(GC_Type_Non_Pointer(*From))))
  72.     {
  73.       return From;
  74.     }
  75.       }
  76.       return To;
  77.     }
  78.     case DATUM_EQ:
  79.     {
  80.       Obj = OBJECT_DATUM (What);
  81.       for (; From < To; From++)
  82.       {
  83.     if (OBJECT_TYPE (*From) == TC_MANIFEST_NM_VECTOR)
  84.     {
  85.       From += OBJECT_DATUM (*From);
  86.     }
  87.     else if (OBJECT_DATUM (*From) == Obj)
  88.     {
  89.       return From;
  90.     }
  91.       }
  92.       return To;
  93.     }
  94.   }
  95. }
  96.  
  97. #define PRINT_P        1
  98. #define STORE_P        2
  99.  
  100. static long
  101. DEFUN (Find_In_Area, (Name, From, To, Obj, Mode, print_p, store_p),
  102.        char * Name
  103.        AND SCHEME_OBJECT * From AND SCHEME_OBJECT * To AND SCHEME_OBJECT Obj
  104.        AND int Mode
  105.        AND Boolean print_p AND Boolean store_p)
  106. {
  107.   fast SCHEME_OBJECT *Where;
  108.   fast long occurrences = 0;
  109.  
  110.   if (print_p)
  111.   {
  112.     outf_console("    Looking in %s:\n", Name);
  113.   }
  114.   Where = From-1;
  115.  
  116.   while ((Where = Find_Occurrence(Where+1, To, Obj, Mode)) < To)
  117.   {
  118.     occurrences += 1;
  119.     if (print_p)
  120. #if (SIZEOF_UNSIGNED_LONG == 4)
  121.       outf_console("Location = 0x%08lx; Contents = 0x%08lx\n",
  122.          ((long) Where), ((long) (*Where)));
  123. #else
  124.       outf_console("Location = 0x%lx; Contents = 0x%lx\n",
  125.          ((long) Where), ((long) (*Where)));
  126. #endif
  127.     if (store_p)
  128.       *Free++ = (LONG_TO_UNSIGNED_FIXNUM ((long) Where));
  129.   }
  130.   return occurrences;
  131. }
  132.  
  133. SCHEME_OBJECT
  134. DEFUN (Find_Who_Points, (Obj, Find_Mode, Collect_Mode),
  135.        SCHEME_OBJECT Obj
  136.        AND int Find_Mode AND int Collect_Mode)
  137. {
  138.   long n = 0;
  139.   SCHEME_OBJECT *Saved_Free = Free;
  140.   Boolean print_p = (Collect_Mode & PRINT_P);
  141.   Boolean store_p = (Collect_Mode & STORE_P);
  142.  
  143.   /* No overflow check done. Hopefully referenced few times, or invoked before
  144.      to find the count and insure that there is enough space. */
  145.   if (store_p)
  146.   {
  147.     Free += 1;
  148.   }
  149.   if (print_p)
  150.   {
  151.     putchar('\n');
  152. #if (SIZEOF_UNSIGNED_LONG == 4)
  153.     outf_console("*** Looking for Obj = 0x%08lx; Find_Mode = %2ld ***\n",
  154.        ((long) Obj), ((long) Find_Mode));
  155. #else
  156.     outf_console("*** Looking for Obj = 0x%lx; Find_Mode = %2ld ***\n",
  157.        ((long) Obj), ((long) Find_Mode));
  158. #endif
  159.   }
  160.   n += Find_In_Area("Constant Space",
  161.             Constant_Space, Free_Constant, Obj,
  162.             Find_Mode, print_p, store_p);
  163.   n += Find_In_Area("the Heap",
  164.             Heap_Bottom, Saved_Free, Obj,
  165.             Find_Mode, print_p, store_p);
  166. #ifndef USE_STACKLETS
  167.   n += Find_In_Area("the Stack",
  168.             Stack_Pointer, Stack_Top, Obj,
  169.             Find_Mode, print_p, store_p);
  170. #endif
  171.   if (print_p)
  172.   {
  173.     outf_console("Done.\n");
  174.   }
  175.   if (store_p)
  176.   {
  177.     *Saved_Free = (MAKE_OBJECT (TC_MANIFEST_VECTOR, n));
  178.     return (MAKE_POINTER_OBJECT (TC_VECTOR, Saved_Free));
  179.   }
  180.   else
  181.   {
  182.     return (LONG_TO_FIXNUM (n));
  183.   }
  184. }
  185.  
  186. void
  187. DEFUN (Print_Memory, (Where, How_Many),
  188.        SCHEME_OBJECT * Where
  189.        AND long How_Many)
  190. {
  191.   fast SCHEME_OBJECT *End   = &Where[How_Many];
  192.  
  193. #if (SIZEOF_UNSIGNED_LONG == 4)
  194.   outf_console ("\n*** Memory from 0x%08lx to 0x%08lx (excluded) ***\n",
  195.       ((long) Where), ((long) End));
  196.   while (Where < End)
  197.   {
  198.     outf_console ("0x%0l8x\n", ((long) (*Where++)));
  199.   }
  200. #else
  201.   outf_console ("\n*** Memory from 0x%lx to 0x%lx (excluded) ***\n",
  202.       ((long) Where), ((long) End));
  203.   while (Where < End)
  204.   {
  205.     outf_console ("0x%lx\n", ((long) (*Where++)));
  206.   }
  207. #endif
  208.   outf_console ("Done.\n");
  209.   return;
  210. }
  211.  
  212. /* Primitives to give scheme a handle on utilities from DEBUG.C */
  213.  
  214. DEFINE_PRIMITIVE ("DEBUG-SHOW-PURE", Prim_debug_show_pure, 0, 0, 0)
  215. {
  216.   PRIMITIVE_HEADER (0);
  217.  
  218.   outf_console ("\n*** Constant & Pure Space: ***\n");
  219.   Show_Pure ();
  220.   PRIMITIVE_RETURN (UNSPECIFIC);
  221. }
  222.  
  223. DEFINE_PRIMITIVE ("DEBUG-SHOW-ENV", Prim_debug_show_env, 1, 1, 0)
  224. {
  225.   SCHEME_OBJECT environment;
  226.   PRIMITIVE_HEADER (1);
  227.  
  228.   environment = (ARG_REF (1));
  229.   outf_console ("\n*** Environment = 0x%lx ***\n", ((long) environment));
  230.   Show_Env (environment);
  231.   PRIMITIVE_RETURN (UNSPECIFIC);
  232. }
  233.  
  234. DEFINE_PRIMITIVE ("DEBUG-STACK-TRACE", Prim_debug_stack_trace, 0, 0, 0)
  235. {
  236.   PRIMITIVE_HEADER (0);
  237.  
  238.   outf_console ("\n*** Back Trace: ***\n");
  239.   Back_Trace (console_output);
  240.   PRIMITIVE_RETURN (UNSPECIFIC);
  241. }
  242.  
  243. DEFINE_PRIMITIVE ("DEBUG-FIND-SYMBOL", Prim_debug_find_symbol, 1, 1, 0)
  244. {
  245.   extern SCHEME_OBJECT EXFUN (find_symbol, (long, unsigned char *));
  246.   PRIMITIVE_HEADER (1);
  247.  
  248.   CHECK_ARG (1, STRING_P);
  249.   {
  250.     fast SCHEME_OBJECT string = (ARG_REF (1));
  251.     fast SCHEME_OBJECT symbol = (find_symbol ((STRING_LENGTH (string)),
  252.                           (STRING_LOC (string, 0))));
  253.     if (symbol == SHARP_F)
  254.       outf_console ("\nNot interned.\n");
  255.     else
  256.       {
  257.     outf_console ("\nInterned Symbol: 0x%lx", ((long) symbol));
  258.     Print_Expression (MEMORY_REF (symbol, SYMBOL_GLOBAL_VALUE), "Value");
  259.     outf_console ("\n");
  260.       }
  261.   }
  262.   PRIMITIVE_RETURN (UNSPECIFIC);
  263. }
  264.  
  265. /* Primitives to give scheme a handle on utilities in this file. */
  266.  
  267. DEFINE_PRIMITIVE ("DEBUG-EDIT-FLAGS", Prim_debug_edit_flags, 0, 0, 0)
  268. {
  269.   PRIMITIVE_HEADER (0);
  270.   debug_edit_flags ();
  271.   PRIMITIVE_RETURN (UNSPECIFIC);
  272. }
  273.  
  274. DEFINE_PRIMITIVE ("DEBUG-FIND-WHO-POINTS", Prim_debug_find_who_points, 3, 3, 0)
  275. {
  276.   PRIMITIVE_HEADER (3);
  277.   PRIMITIVE_RETURN
  278.     (Find_Who_Points
  279.      ((ARG_REF (1)),
  280.       (OBJECT_DATUM (ARG_REF (2))),
  281.       (OBJECT_DATUM (ARG_REF (3)))));
  282. }
  283.  
  284. DEFINE_PRIMITIVE ("DEBUG-PRINT-MEMORY", Prim_debug_print_memory, 2, 2, 0)
  285. {
  286.   SCHEME_OBJECT object;
  287.   PRIMITIVE_HEADER (2);
  288.   object = (ARG_REF (1));
  289.   Print_Memory
  290.     (((GC_Type_Non_Pointer (object))
  291.       ? ((SCHEME_OBJECT *) (OBJECT_DATUM (object)))
  292.       : (OBJECT_ADDRESS (object))),
  293.      (OBJECT_DATUM (ARG_REF (2))));
  294.   PRIMITIVE_RETURN (UNSPECIFIC);
  295. }
  296.