source: Include/system/gc.sbp@ 298

Last change on this file since 298 was 284, checked in by dai, 17 years ago

呼び出し元が_beginthreadex関数になっているため、SweepOnOtherThreadメソッドのcdecl指定を外した(stdcallにした)

File size: 14.2 KB
Line 
1/*
2 このファイルでは、ABのガベージコレクションの実装を行います。
3*/
4
5
6/*
7※これらの変数はコンパイラが自動的に定義します。
8Dim _System_gc_GlobalRoot_StartPtr As VoidPtr
9Dim _System_gc_GlobalRoot_Size As Long
10Dim _System_gc_StackRoot_StartPtr As VoidPtr
11*/
12
13Function _System_GetSp() As LONG_PTR 'dummy
14End Function
15
16
17Const _System_GC_FLAG_ATOMIC = 1
18Const _System_GC_FLAG_NEEDFREE = 2
19Const _System_GC_FLAG_INITZERO = 4
20Const _System_GC_FLAG_OBJECT = 8
21
22Type _System_GlobalRoot
23 ptr As *LONG_PTR
24 count As Long
25End Type
26
27Class _System_CGarbageCollection
28
29 ppPtr As *VoidPtr
30 pSize As *SIZE_T
31 pdwFlags As *DWord
32 n As Long
33
34 iAllSize As SIZE_T
35
36 isSweeping As Boolean
37
38 CriticalSection As CRITICAL_SECTION
39
40 ' メモリの上限値(この値を超えるとGCが発動します)
41 limitMemorySize As LONG_PTR ' バイト単位
42 limitMemoryObjectNum As Long ' メモリオブジェクトの個数単位
43
44 isFinish As Boolean
45
46
47 ' Global Root
48 pGlobalRoots As *_System_GlobalRoot
49 globalRootNum As Long
50 Sub AddGlobalRootPtr( ptr As *LONG_PTR, count As Long )
51 pGlobalRoots = _System_realloc( pGlobalRoots, (globalRootNum + 1) * SizeOf(_System_GlobalRoot) )
52 pGlobalRoots[globalRootNum].ptr = ptr
53 pGlobalRoots[globalRootNum].count = count
54 globalRootNum++
55 End Sub
56
57 Sub RegisterGlobalRoots()
58 ' このメソッドの実装はコンパイラが自動生成する
59
60 ' AddGlobalRootPtr(...)
61 ' ...
62 End Sub
63
64 ' 特殊クラスのため、コンストラクタ・デストラクタは呼ばれません
65 Sub _System_CGarbageCollection()
66 End Sub
67 Sub ~_System_CGarbageCollection()
68 End Sub
69
70Public
71
72 Static Sub Initialize()
73 Dim temporary[255] As Char
74 If GetEnvironmentVariable( "ActiveBasicGarbageCollection", temporary, 255 ) Then
75 ' 既にGCがプロセスに存在するとき
76 sscanf( temporary, "%08x", VarPtr( _System_pGC ) )
77 MessageBox(0,temporary,"GetEnvironmentVariable",0)
78 Else
79 _System_pGC = _System_calloc( SizeOf( _System_CGarbageCollection ) )
80 _System_pGC->Begin()
81
82 ' GCをプロセスに登録する
83 sprintf( temporary, "%08x", _System_pGC )
84 SetEnvironmentVariable( "ActiveBasicGarbageCollection", temporary )
85 End If
86 End Sub
87
88 Sub Begin()
89 If ppPtr Then Exit Sub
90
91 isFinish = False
92
93 'メモリの上限値(この値を超えるとGCが発動します)
94 limitMemorySize = 1024*1024 As LONG_PTR ' バイト単位
95 limitMemoryObjectNum = 2000 ' メモリオブジェクトの個数単位
96
97 ppPtr=_System_calloc( 1 )
98 pSize=_System_calloc( 1 )
99 pdwFlags=_System_calloc( 1 )
100 n=0
101
102 ' Global Root
103 pGlobalRoots = _System_calloc( 1 )
104 globalRootNum = 0
105 RegisterGlobalRoots()
106
107 iAllSize=0
108
109 ' スウィープ中かどうか
110 isSweeping = False
111
112 'クリティカルセッションを生成
113 InitializeCriticalSection(CriticalSection)
114
115
116 '---------------------------
117 ' 開始時のスレッドを通知
118 '---------------------------
119 Dim hTargetThread As HANDLE
120 DuplicateHandle(GetCurrentProcess(),
121 GetCurrentThread(),
122 GetCurrentProcess(),
123 hTargetThread, 0, FALSE, DUPLICATE_SAME_ACCESS) 'カレントスレッドのハンドルを複製
124
125 ' スレッド管理用オブジェクトを生成
126 _System_pobj_AllThreads = New _System_CThreadCollection()
127
128 ' 自身のThreadオブジェクトを生成
129 Dim thread As Thread(hTargetThread,GetCurrentThreadId(),0)
130
131 _System_pobj_AllThreads->BeginThread(ObjPtr( thread ),_System_gc_StackRoot_StartPtr As *LONG_PTR)
132
133 End Sub
134 Sub Finish()
135 If ppPtr=0 Then Exit Sub
136
137 isFinish = True
138
139 ' スレッド管理用オブジェクトを破棄
140 Delete _System_pobj_AllThreads
141
142 ' 自分以外のスレッドを一時停止
143 '_System_pobj_AllThreads->SuspendAnotherThread()
144
145 _System_DebugOnly_OutputDebugString( Ex"garbage colletion sweeping all memory objects!\r\n" )
146 DeleteAllGarbageMemories()
147
148 ' 未解放のメモリオブジェクトをトレース
149 DumpMemoryLeaks()
150
151 ' 自分以外のスレッドを再開
152 '_System_pobj_AllThreads->ResumeAnotherThread()
153
154 _System_free( ppPtr )
155 ppPtr = NULL
156
157 _System_free( pSize )
158 pSize = NULL
159 _System_free( pdwFlags )
160 pdwFlags = NULL
161
162 _System_free( pGlobalRoots )
163 pGlobalRoots = NULL
164
165 'クリティカルセッションを破棄
166 DeleteCriticalSection(CriticalSection)
167
168 End Sub
169
170 Sub add(new_ptr As VoidPtr, size As SIZE_T, flags As DWord)
171 iAllSize+=size
172
173 EnterCriticalSection(CriticalSection)
174 ppPtr=HeapReAlloc(_System_hProcessHeap,0,ppPtr,(n+1)*SizeOf(VoidPtr))
175 ppPtr[n]=new_ptr
176
177 pSize=HeapReAlloc(_System_hProcessHeap,0,pSize,(n+1)*SizeOf(SIZE_T))
178 pSize[n]=size
179
180 pdwFlags=HeapReAlloc(_System_hProcessHeap,0,pdwFlags,(n+1)*SizeOf(DWord))
181 pdwFlags[n]=flags
182 LeaveCriticalSection(CriticalSection)
183
184 n++
185 End Sub
186
187
188 Function __malloc(size As SIZE_T,flags As Byte) As VoidPtr
189' EnterCriticalSection(CriticalSection)
190 Dim dwFlags As DWord
191 If flags and _System_GC_FLAG_INITZERO Then
192 dwFlags=HEAP_ZERO_MEMORY
193 Else
194 dwFlags=0
195 End If
196
197 Dim ptr = HeapAlloc(_System_hProcessHeap,dwFlags,size)
198 add( ptr, size, flags )
199' LeaveCriticalSection(CriticalSection)
200
201 Return ptr
202 End Function
203
204 Function __realloc(lpMem As VoidPtr, size As SIZE_T) As VoidPtr
205 EnterCriticalSection(CriticalSection)
206 Dim i As Long
207 For i=0 To ELM(n)
208 If ppPtr[i]=lpMem Then
209 iAllSize+=size-pSize[i]
210
211 pSize[i]=size
212 ppPtr[i]=HeapReAlloc(_System_hProcessHeap,HEAP_ZERO_MEMORY,lpMem,size)
213
214 LeaveCriticalSection(CriticalSection)
215 Return ppPtr[i]
216 End If
217 Next
218 LeaveCriticalSection(CriticalSection)
219 Return 0
220 End Function
221
222 Sub __free_ex(lpMem As VoidPtr, isSweeping As Boolean)
223 EnterCriticalSection(CriticalSection)
224 Dim i As Long
225 For i=0 To ELM(n)
226 If ppPtr[i]=lpMem Then
227 If (pdwFlags[i] and _System_GC_FLAG_NEEDFREE)<>0 or isSweeping Then
228 iAllSize-=pSize[i]
229
230 HeapFree(_System_hProcessHeap,0,ppPtr[i])
231 ppPtr[i]=0
232 pSize[i]=0
233 Else
234 If isFinish = False Then
235 _System_DebugOnly_OutputDebugString( Ex"heap free missing!\r\n" )
236 End If
237 End If
238 End If
239 Next
240 LeaveCriticalSection(CriticalSection)
241 End Sub
242
243 Sub __free(lpMem As VoidPtr)
244 __free_ex( lpMem, False )
245 End Sub
246
247 Sub sweep()
248 If isSweeping <> False or (iAllSize<limitMemorySize and n<limitMemoryObjectNum) Then
249 'メモリ使用量が上限値を超えていないとき
250 Exit Sub
251 End If
252
253 Dim hThread As HANDLE
254 Dim ThreadId As DWord
255 hThread=_beginthreadex(NULL,0,AddressOf(SweepOnOtherThread),VarPtr(This),0,ThreadId)
256 WaitForSingleObject(hThread,INFINITE)
257 CloseHandle(hThread)
258 isSweeping = False
259 End Sub
260
261Private
262
263 Static Function IsNull( object As Object ) As Boolean
264 Return Object.ReferenceEquals(object, Nothing)
265 End Function
266
267 ' 生存検知
268 Function HitTest(pSample As VoidPtr) As Long
269 Dim i As Long
270 For i=0 To ELM(n)
271 If (ppPtr[i] As LONG_PTR)<=(pSample As LONG_PTR) and (pSample As LONG_PTR)<((ppPtr[i] As LONG_PTR)+pSize[i]) Then
272 Return i
273 End If
274 Next
275 Return -1
276 End Function
277
278 ' オブジェクトのスキャン
279 Function ScanObject(pObject As *Object, pbMark As *Byte) As Boolean
280 Dim classTypeInfo = Nothing As ActiveBasic.Core._System_TypeForClass
281 classTypeInfo = pObject->GetType() As ActiveBasic.Core._System_TypeForClass
282
283 If IsNull( classTypeInfo ) Then
284 Return False
285 End If
286
287 Dim i As Long
288 For i = 0 To ELM(classTypeInfo.numOfReference)
289 Scan( (pObject + classTypeInfo.referenceOffsets[i]) As *LONG_PTR, 1, pbMark )
290 Next
291
292 Return True
293 End Function
294
295 ' 指定領域のスキャン
296 Sub Scan(pStartPtr As *LONG_PTR, maxNum As Long, pbMark As *Byte)
297 Dim i As Long, index As Long
298
299 For i=0 To ELM(maxNum)
300 index=HitTest(pStartPtr[i] As VoidPtr)
301 If index<>-1 Then
302 If pbMark[index]=0 Then
303 pbMark[index]=1
304
305 If pdwFlags[index] and _System_GC_FLAG_OBJECT Then
306 ' オブジェクトの場合
307 If ScanObject( (ppPtr[index] + 4*SizeOf(LONG_PTR)) As *Object, pbMark) = False Then
308 Dim maxNum = (pSize[index]\SizeOf(LONG_PTR)) As Long
309 Scan(ppPtr[index] As *LONG_PTR, maxNum, pbMark)
310 End If
311
312 ElseIf (pdwFlags[index] and _System_GC_FLAG_ATOMIC)=0 Then
313 ' ヒープ領域がポインタ値を含む可能性があるとき
314 If ppPtr[index] = 0 Then
315 'エラー
316
317 End If
318
319 Dim maxNum = (pSize[index]\SizeOf(LONG_PTR)) As Long
320 Scan(ppPtr[index] As *LONG_PTR, maxNum, pbMark)
321 End If
322 End If
323 End If
324 Next
325 End Sub
326
327 ' ローカル領域をルートに指定してスキャン
328 Sub LocalScan( pbMark As *Byte )
329 Dim Context As CONTEXT
330 Dim NowSp As *LONG_PTR
331 Dim size As LONG_PTR
332 Dim i As Long
333 For i=0 To ELM(_System_pobj_AllThreads->ThreadNum)
334 If _System_pobj_AllThreads->ppobj_Thread[i] Then
335 FillMemory(VarPtr(Context),SizeOf(CONTEXT),0)
336 Context.ContextFlags=CONTEXT_CONTROL
337 If _System_pobj_AllThreads->ppobj_Thread[i]->__GetContext(Context)=0 Then
338 _System_DebugOnly_OutputDebugString(Ex"レジスタ情報の取得に失敗しました。\r\n")
339 End If
340
341#ifdef _WIN64
342 NowSp=Context.Rsp As *LONG_PTR
343#else
344 NowSp=Context.Esp As *LONG_PTR
345#endif
346
347 Dim size=(_System_pobj_AllThreads->pStackBase[i] As LONG_PTR)-(NowSp As LONG_PTR)
348 Dim maxNum = (size\SizeOf(LONG_PTR)) As Long
349
350 If NowSp = 0 Then
351 debug
352 Exit Sub
353 End If
354
355 Scan( NowSp, maxNum, pbMark )
356 End If
357 Next
358 End Sub
359
360 Sub DeleteGarbageMemories( pbMark As *Byte )
361
362 Dim isAllDelete = False
363 If pbMark = NULL Then
364 ' すべてを破棄するとき
365 isAllDelete = True
366 pbMark = _System_calloc( n )
367 End If
368
369 Dim i As Long
370 For i=0 To ELM(n)
371 If pbMark[i]=0 and ppPtr[i]<>0 and (pdwFlags[i] and _System_GC_FLAG_NEEDFREE)=0 Then
372 If ppPtr[i] = 0 Then
373 If isAllDelete Then
374 Continue
375 Else
376 debug
377 End If
378 End If
379
380 Dim ptr = ppPtr[i]
381 Dim size = pSize[i]
382
383 ppPtr[i]=0
384 pSize[i]=0
385
386 If (pdwFlags[i] and _System_GC_FLAG_OBJECT) <> 0 Then
387 /* ・オブジェクトの個数
388 ・オブジェクトのサイズ
389 ・デストラクタの関数ポインタ
390 ・リザーブ領域
391 を考慮 */
392 _System_SweepingDelete (ptr + SizeOf( LONG_PTR ) * 4 )
393 Else
394 HeapFree(_System_hProcessHeap,0,ptr)
395 End If
396
397 iAllSize-=size
398 End If
399 Next
400
401 If isAllDelete Then
402 _System_free( pbMark )
403 End If
404
405 End Sub
406
407 Sub DeleteAllGarbageMemories()
408 DeleteGarbageMemories( NULL )
409 End Sub
410
411 Sub Compaction()
412 Dim i As Long, i2 = 0 As Long
413 For i=0 To ELM(n)
414 ppPtr[i2] = ppPtr[i]
415 pSize[i2] = pSize[i]
416 pdwFlags[i2] = pdwFlags[i]
417
418 If ppPtr[i] Then
419 i2++
420 End If
421 Next
422 n = i2
423 End Sub
424
425 ' スウィープ(新規スレッドで呼び出し)
426 Function SweepOnOtherThread() As Long
427 EnterCriticalSection(CriticalSection)
428
429
430 Dim startTime = GetTickCount()
431
432 _System_DebugOnly_OutputDebugString( Ex"garbage colletion sweep start!\r\n" )
433
434
435 If isSweeping <> False or (iAllSize<limitMemorySize and n<limitMemoryObjectNum) Then
436 ExitThread(0)
437 End If
438 isSweeping = True
439
440 ' すべてのスレッドを一時停止
441 _System_pobj_AllThreads->SuspendAllThread()
442
443 ' マークリストを生成
444 Dim pbMark = HeapAlloc(_System_hProcessHeap,HEAP_ZERO_MEMORY,n*SizeOf(Byte)) As *Byte
445
446 ' グローバル領域をルートに指定してスキャン
447 Dim i As Long
448 For i = 0 To ELM( globalRootNum )
449 Scan( pGlobalRoots[i].ptr, pGlobalRoots[i].count, pbMark )
450 Next
451
452 ' ローカル領域をルートに指定してスキャン
453 LocalScan( pbMark )
454
455 ' スウィープ前のメモリサイズを退避
456 Dim iBackAllSize = iAllSize
457
458 ' スウィープ前のメモリオブジェクトの数
459 Dim iBeforeN = n
460
461 '使われていないメモリを解放する
462 DeleteGarbageMemories(pbMark)
463
464 'コンパクション
465 Compaction()
466
467 'マークリストを解放
468 HeapFree(_System_hProcessHeap,0,pbMark)
469
470 If iBackAllSize=iAllSize Then
471 If iAllSize > limitMemorySize Then
472 limitMemorySize = iAllSize
473 End If
474
475 '許容量を拡張する
476 limitMemorySize *= 2
477 limitMemoryObjectNum *= 2
478
479 _System_DebugOnly_OutputDebugString( Ex"memory size is extended for gc!\r\n" )
480 End If
481
482 Dim temp[100] As Char
483 wsprintf(temp,Ex"object items ... %d -> %d ( %d MB -> %d MB )\r\n",iBeforeN,n, iBackAllSize\1024\1024, iAllSize\1024\1024)
484 _System_DebugOnly_OutputDebugString( temp )
485 wsprintf(temp,Ex"limit size of memory ... %d\r\n",limitMemorySize)
486 _System_DebugOnly_OutputDebugString( temp )
487 wsprintf(temp,Ex"garbage colletion sweep finish! (%d ms)\r\n\r\n", GetTickCount()-startTime)
488 _System_DebugOnly_OutputDebugString( temp )
489
490
491 '-------------------------------------
492 ' すべてのスレッドを再開
493 '-------------------------------------
494 _System_pobj_AllThreads->ResumeAllThread()
495
496 LeaveCriticalSection(CriticalSection)
497 End Function
498
499 ' 未解放のメモリオブジェクトをトレース
500 Sub DumpMemoryLeaks()
501 Dim isLeak = False
502 Dim i As Long
503 For i=0 To ELM(n)
504 If ppPtr[i] Then
505 If (pdwFlags[i] and _System_GC_FLAG_NEEDFREE)<>0 Then
506 If isLeak = False Then
507 _System_DebugOnly_OutputDebugString( Ex"Detected memory leaks!\r\n" )
508 isLeak = True
509 End If
510
511 Dim temp[100] As Char
512 _System_DebugOnly_OutputDebugString( Ex"heap free missing!\r\n" )
513 wsprintf(temp,Ex"{%d} normal block at &H%08X, %d bytes long.\r\n", i, ppPtr[i], pSize[i])
514 _System_DebugOnly_OutputDebugString( temp )
515 End If
516 End If
517 Next
518
519 If isLeak Then
520 _System_DebugOnly_OutputDebugString( Ex"Object dump complete.\r\n" )
521 End If
522
523 End Sub
524
525End Class
526
527'GC管理用の特殊なシステムオブジェクト(デストラクタは最終のタイミングで呼び出されます)
528Dim _System_pGC As *_System_CGarbageCollection
529
530
531
532Function GC_malloc(size As Long) As VoidPtr
533 ' sweep
534 _System_pGC->sweep()
535
536 'allocate
537 Return _System_pGC->__malloc(size,0)
538End Function
539
540Function GC_malloc_atomic(size As Long) As VoidPtr
541 ' sweep
542 _System_pGC->sweep()
543
544 'allocate
545 Return _System_pGC->__malloc(size,_System_GC_FLAG_ATOMIC)
546End Function
547
548Function _System_GC_malloc_ForObject(size As Long) As VoidPtr
549 ' sweep
550 _System_pGC->sweep()
551
552 'allocate
553 Return _System_pGC->__malloc(size,_System_GC_FLAG_OBJECT or _System_GC_FLAG_INITZERO)
554End Function
555
556Function _System_GC_malloc_ForObjectPtr(size As Long) As VoidPtr
557 ' sweep
558 _System_pGC->sweep()
559
560 'allocate
561 Return _System_pGC->__malloc(size,_System_GC_FLAG_OBJECT or _System_GC_FLAG_INITZERO or _System_GC_FLAG_NEEDFREE)
562End Function
563
564Function _System_GC_free_for_SweepingDelete( ptr As *Object )
565 ' free
566 _System_pGC->__free_ex( ptr, True )
567End Function
Note: See TracBrowser for help on using the repository browser.