source: trunk/Include/system/gc.sbp@ 337

Last change on this file since 337 was 330, checked in by dai, 17 years ago

コンストラクタパラメータを処理中にGCがかかると、初期化中オブジェクトのスキャンで強制終了してしまうバグを修正。
グローバル領域に保持されるオブジェクトの一部がGCによって不正に回収されてしまうバグを修正。
Thread.Nameプロパティを実装

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