1 /*
2 * Part of Scheme 48 1.9. See file COPYING for notices and license.
3 *
4 * Authors: David Frese, Mike Sperber
5 */
6
7 #include <stdlib.h>
8 #include <stdio.h>
9 #include "scheme48.h"
10 #include "generation_gc.h"
11 #include "utils.h"
12 #include "data.h"
13 #include "memory.h"
14 #include "memory_map.h"
15
16 /* how many errors are left before program termination */
17 static long errors_left;
18
s48_stob_in_heapP(s48_value stob)19 char s48_stob_in_heapP(s48_value stob) {
20 s48_address addr = S48_ADDRESS_AT_HEADER(stob);
21 Area* area = s48_memory_map_ref(addr);
22 return ((area != NULL) && (area->start <= addr) && (addr < area->frontier));
23 }
24
error_found(char * message)25 static void error_found(char* message) {
26 fprintf(stderr, "check heap: %s\n", message);
27 if (errors_left == 0) {
28 s48_gc_error("check heap: too many errors!");
29 } else {
30 errors_left--;
31 }
32 }
33
try_describe_area_at(s48_address addr)34 static void try_describe_area_at(s48_address addr) {
35 Area* a = s48_memory_map_ref(addr);
36 fprintf(stderr, "Area containing 0x%p", addr);
37 if (a != NULL) {
38 fprintf(stderr, "\n 0x%p-[0x%p]-0x%p\n", a->start, a->frontier, a->end);
39 fprintf(stderr, " generation: %d\n", a->generation_index);
40 fprintf(stderr, " type: %d\n", a->area_type_size);
41 fprintf(stderr, " %s last in chain\n", a->next ? "not" : "");
42 }
43 else
44 fprintf(stderr, " could not be found\n");
45 }
46
check_area(s48_address start,s48_address end)47 static void check_area(s48_address start, s48_address end) {
48 s48_address addr = start;
49 while (addr < end) {
50 long header = *((long*)addr);
51 if (!S48_HEADER_P(header)) {
52 char s[512];
53 try_describe_area_at(addr);
54 sprintf(s, "corrupted header 0x%lX at 0x%p!", header, addr);
55 error_found(s);
56 addr = S48_ADDRESS_INC(addr);
57 } else {
58 s48_address next = addr + S48_STOB_OVERHEAD_IN_A_UNITS
59 + S48_HEADER_LENGTH_IN_A_UNITS(header);
60 if (!S48_B_VECTOR_HEADER_P(header)) {
61 s48_value v; int i;
62 int len = S48_HEADER_LENGTH_IN_CELLS(header);
63 s48_value* this_addr = ((s48_value*)addr); /* increased in the first loop */
64 for (i = 0; i < len; i++) {
65 this_addr++;
66 v = *this_addr;
67 if ( S48_HEADER_P(v) ) {
68 char s[512];
69 sprintf(s, "content value 0x%lX at 0x%p is a header!",
70 v, this_addr);
71 error_found(s);
72 } else if ( S48_STOB_P(v) && (!s48_stob_in_heapP(v)) ) {
73 char s[512];
74 sprintf(s, "stob value 0x%lX in object of type %ld at 0x%p pointing outside the heap!", v, S48_HEADER_TYPE(header), this_addr);
75 error_found(s);
76 }
77 }
78 }
79 addr = next;
80 }
81 }
82 }
83
84 /* error_count : maximal errors allowed */
85
s48_check_heap(long error_count)86 char s48_check_heap(long error_count) {
87 errors_left = error_count;
88 s48_walk_heap(&check_area);
89 /* If errors_left ist not decremented
90 means there was no error => s48_check_heap = TRUE */
91 return (errors_left == error_count);
92 }
93