1 #include "alloc.h"
2 #include "debugger.h"
3 #include "gc.h"
4 #include "gc_ctrl.h"
5 #include "major_gc.h"
6 #include "minor_gc.h"
7 #include "mlvalues.h"
8 #include "memory.h"
9
10 long stat_minor_words = 0,
11 stat_promoted_words = 0,
12 stat_major_words = 0,
13 stat_minor_collections = 0,
14 stat_major_collections = 0,
15 stat_heap_size = 0; /* bytes */
16
17 extern asize_t major_heap_increment; /* bytes; cf. major_gc.c */
18 extern int percent_free; /* cf. major_gc.c */
19 extern int verb_gc; /* cf. misc.c */
20
21 #define Chunk_size(c) (((heap_chunk_head *) (c)) [-1]).size
22 #define Chunk_next(c) (((heap_chunk_head *) (c)) [-1]).next
23 #define Next(hp) ((hp) + Bhsize_hp (hp))
24
25 /* This will also thoroughly verify the heap if compiled in DEBUG mode. */
26
gc_stat(value v)27 value gc_stat (value v) /* ML */
28 {
29 value res;
30 long live_words = 0, live_blocks = 0,
31 free_words = 0, free_blocks = 0, largest_free = 0,
32 fragments = 0, heap_chunks = 0;
33 char *chunk = heap_start, *chunk_end;
34 char *cur_hp, *prev_hp;
35 header_t cur_hd;
36
37 Assert (v == Atom (0));
38
39 while (chunk != NULL){
40 ++ heap_chunks;
41 chunk_end = chunk + Chunk_size (chunk);
42 prev_hp = NULL;
43 cur_hp = chunk;
44 while (cur_hp < chunk_end){
45 cur_hd = Hd_hp (cur_hp);
46 switch (Color_hd (cur_hd)){
47 case White:
48 if (Wosize_hd (cur_hd) == 0){
49 ++fragments;
50 Assert (prev_hp == NULL
51 || (Color_hp (prev_hp) != Blue
52 && Wosize_hp (prev_hp) > 0));
53 Assert (Next (cur_hp) == chunk_end
54 || (Color_hp (Next (cur_hp)) != Blue
55 && Wosize_hp (Next (cur_hp)) > 0));
56 break;
57 }
58 /* FALLTHROUGH */
59 case Gray: case Black:
60 Assert (Wosize_hd (cur_hd) > 0);
61 ++ live_blocks;
62 live_words += Whsize_hd (cur_hd);
63 break;
64 case Blue:
65 Assert (Wosize_hd (cur_hd) > 0);
66 ++ free_blocks;
67 free_words += Whsize_hd (cur_hd);
68 if (Whsize_hd (cur_hd) > largest_free){
69 largest_free = Whsize_hd (cur_hd);
70 }
71 Assert (prev_hp == NULL
72 || (Color_hp (prev_hp) != Blue
73 && Wosize_hp (prev_hp) > 0));
74 Assert (Next (cur_hp) == chunk_end
75 || (Color_hp (Next (cur_hp)) != Blue
76 && Wosize_hp (Next (cur_hp)) > 0));
77 break;
78 }
79 prev_hp = cur_hp;
80 cur_hp = Next (cur_hp);
81 } Assert (cur_hp == chunk_end);
82 chunk = Chunk_next (chunk);
83 }
84
85 Assert (live_words + free_words + fragments == Wsize_bsize (stat_heap_size));
86 /* Order of elements changed for Moscow ML */
87 res = alloc (13, 0);
88 Field (res, 11) = Val_long (stat_minor_words
89 + Wsize_bsize (young_ptr - young_start));
90 Field (res, 12) = Val_long (stat_promoted_words);
91 Field (res, 9) = Val_long (stat_major_words + allocated_words);
92 Field (res, 10) = Val_long (stat_minor_collections);
93 Field (res, 8) = Val_long (stat_major_collections);
94 Field (res, 4) = Val_long (Wsize_bsize (stat_heap_size));
95 Field (res, 3) = Val_long (heap_chunks);
96 Field (res, 7) = Val_long (live_words);
97 Field (res, 6) = Val_long (live_blocks);
98 Field (res, 2) = Val_long (free_words);
99 Field (res, 1) = Val_long (free_blocks);
100 Field (res, 5) = Val_long (largest_free);
101 Field (res, 0) = Val_long (fragments);
102 return res;
103 }
104
gc_get(value v)105 value gc_get (value v) /* ML */
106 {
107 value res;
108
109 Assert (v == Atom (0));
110 /* Order of elements changed for Moscow ML */
111 res = alloc (4, 0);
112 Field (res, 1) = Wsize_bsize (Val_long (minor_heap_size));
113 Field (res, 0) = Wsize_bsize (Val_long (major_heap_increment));
114 Field (res, 2) = Val_long (percent_free);
115 Field (res, 3) = Val_bool (verb_gc);
116 return res;
117 }
118
norm_pfree(int p)119 static int norm_pfree (int p)
120 {
121 if (p < 1) return p = 1;
122 return p;
123 }
124
norm_heapincr(long i)125 static long norm_heapincr (long i)
126 {
127 i = ((i + (1 << Page_log) - 1) >> Page_log) << Page_log;
128 if (i < Heap_chunk_min) i = Heap_chunk_min;
129 if (i > Heap_chunk_max) i = Heap_chunk_max;
130 return i;
131 }
132
norm_minsize(long s)133 static long norm_minsize (long s)
134 {
135 if (s < Minor_heap_min) s = Minor_heap_min;
136 if (s > Minor_heap_max) s = Minor_heap_max;
137 return s;
138 }
139
gc_set(value v)140 value gc_set (value v) /* ML */
141 {
142 int newpf;
143 /* Order of elements changed for Moscow ML */
144 verb_gc = Bool_val (Field (v, 3));
145
146 newpf = norm_pfree (Long_val (Field (v, 2)));
147 if (newpf != percent_free){
148 percent_free = newpf;
149 gc_message ("New space overhead: %d%%\n", percent_free);
150 }
151
152 if (Bsize_wsize (Long_val (Field (v, 0))) != major_heap_increment){
153 major_heap_increment = norm_heapincr (Bsize_wsize (Long_val (Field(v,0))));
154 gc_message ("New heap increment size: %ldk\n", major_heap_increment/1024);
155 }
156
157 /* Minor heap size comes last because it will trigger a minor collection
158 (thus invalidating [v]) and it can raise [Out_of_memory]. */
159 if (Bsize_wsize (Long_val (Field (v, 1))) != minor_heap_size){
160 long new_size = norm_minsize (Bsize_wsize (Long_val (Field (v, 1))));
161 gc_message ("New minor heap size: %ldk\n", new_size/1024);
162 set_minor_heap_size (new_size);
163 }
164 return Atom (0);
165 }
166
gc_minor(value v)167 value gc_minor (value v) /* ML */
168 { Assert (v == Atom (0));
169 minor_collection ();
170 return Atom (0);
171 }
172
gc_major(value v)173 value gc_major (value v) /* ML */
174 { Assert (v == Atom (0));
175 minor_collection ();
176 finish_major_cycle ();
177 return Atom (0);
178 }
179
gc_full_major(value v)180 value gc_full_major (value v) /* ML */
181 { Assert (v == Atom (0));
182 minor_collection ();
183 finish_major_cycle ();
184 finish_major_cycle ();
185 return Atom (0);
186 }
187
init_gc(long minor_size,long major_incr,int percent_fr,int verb)188 void init_gc (long minor_size, long major_incr, int percent_fr, int verb)
189 {
190 #ifdef DEBUG
191 gc_message ("*** camlrunm: debug mode ***\n", 0);
192 #endif
193 verb_gc = verb;
194 set_minor_heap_size (Bsize_wsize (norm_minsize (minor_size)));
195 major_heap_increment = Bsize_wsize (norm_heapincr (major_incr));
196 percent_free = norm_pfree (percent_fr);
197 init_major_heap (major_heap_increment);
198 init_c_roots ();
199 gc_message ("Initial space overhead: %d%%\n", percent_free);
200 gc_message ("Initial heap increment: %ldk\n", major_heap_increment / 1024);
201 gc_message ("Initial minor heap size: %ldk\n", minor_heap_size / 1024);
202 }
203