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

Last change on this file since 323 was 299, checked in by dai, 17 years ago

【32bitコンパイラ】
静的リンクライブラリを実装
ジェネリクスを実装
※64bitコンパイラは未実装

File size: 14.1 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
129 _System_pobj_AllThreads->BeginThread(ObjPtr( thread ),_System_gc_StackRoot_StartPtr As *LONG_PTR)
130
131 End Sub
132 Sub Finish()
133 If ppPtr=0 Then Exit Sub
134
135 isFinish = True
136
137 ' スレッド管理用オブジェクトを破棄
138 Delete _System_pobj_AllThreads
139
140 ' 自分以外のスレッドを一時停止
141 '_System_pobj_AllThreads->SuspendAnotherThread()
142
143 _System_DebugOnly_OutputDebugString( Ex"garbage colletion sweeping all memory objects!\r\n" )
144 DeleteAllGarbageMemories()
145
146 ' 未解放のメモリオブジェクトをトレース
147 DumpMemoryLeaks()
148
149 ' 自分以外のスレッドを再開
150 '_System_pobj_AllThreads->ResumeAnotherThread()
151
152 _System_free( ppPtr )
153 ppPtr = NULL
154
155 _System_free( pSize )
156 pSize = NULL
157 _System_free( pdwFlags )
158 pdwFlags = NULL
159
160 _System_free( pGlobalRoots )
161 pGlobalRoots = NULL
162
163 'クリティカルセッションを破棄
164 DeleteCriticalSection(CriticalSection)
165
166 End Sub
167
168 Sub add(new_ptr As VoidPtr, size As SIZE_T, flags As DWord)
169 iAllSize+=size
170
171 EnterCriticalSection(CriticalSection)
172 ppPtr=HeapReAlloc(_System_hProcessHeap,0,ppPtr,(n+1)*SizeOf(VoidPtr))
173 ppPtr[n]=new_ptr
174
175 pSize=HeapReAlloc(_System_hProcessHeap,0,pSize,(n+1)*SizeOf(SIZE_T))
176 pSize[n]=size
177
178 pdwFlags=HeapReAlloc(_System_hProcessHeap,0,pdwFlags,(n+1)*SizeOf(DWord))
179 pdwFlags[n]=flags
180 LeaveCriticalSection(CriticalSection)
181
182 n++
183 End Sub
184
185
186 Function __malloc(size As SIZE_T,flags As Byte) As VoidPtr
187' EnterCriticalSection(CriticalSection)
188 Dim dwFlags As DWord
189 If flags and _System_GC_FLAG_INITZERO Then
190 dwFlags=HEAP_ZERO_MEMORY
191 Else
192 dwFlags=0
193 End If
194
195 Dim ptr = HeapAlloc(_System_hProcessHeap,dwFlags,size)
196 add( ptr, size, flags )
197' LeaveCriticalSection(CriticalSection)
198
199 Return ptr
200 End Function
201
202 Function __realloc(lpMem As VoidPtr, size As SIZE_T) As VoidPtr
203 EnterCriticalSection(CriticalSection)
204 Dim i As Long
205 For i=0 To ELM(n)
206 If ppPtr[i]=lpMem Then
207 iAllSize+=size-pSize[i]
208
209 pSize[i]=size
210 ppPtr[i]=HeapReAlloc(_System_hProcessHeap,HEAP_ZERO_MEMORY,lpMem,size)
211
212 LeaveCriticalSection(CriticalSection)
213 Return ppPtr[i]
214 End If
215 Next
216 LeaveCriticalSection(CriticalSection)
217 Return 0
218 End Function
219
220 Sub __free_ex(lpMem As VoidPtr, isSweeping As Boolean)
221 EnterCriticalSection(CriticalSection)
222 Dim i As Long
223 For i=0 To ELM(n)
224 If ppPtr[i]=lpMem Then
225 If (pdwFlags[i] and _System_GC_FLAG_NEEDFREE)<>0 or isSweeping Then
226 iAllSize-=pSize[i]
227
228 HeapFree(_System_hProcessHeap,0,ppPtr[i])
229 ppPtr[i]=0
230 pSize[i]=0
231 Else
232 If isFinish = False Then
233 _System_DebugOnly_OutputDebugString( Ex"heap free missing!\r\n" )
234 End If
235 End If
236 End If
237 Next
238 LeaveCriticalSection(CriticalSection)
239 End Sub
240
241 Sub __free(lpMem As VoidPtr)
242 __free_ex( lpMem, False )
243 End Sub
244
245 Sub sweep()
246 If isSweeping <> False or (iAllSize<limitMemorySize and n<limitMemoryObjectNum) Then
247 'メモリ使用量が上限値を超えていないとき
248 Exit Sub
249 End If
250
251 Dim hThread As HANDLE
252 Dim ThreadId As DWord
253 hThread=_beginthreadex(NULL,0,AddressOf(SweepOnOtherThread),VarPtr(This),0,ThreadId)
254 WaitForSingleObject(hThread,INFINITE)
255 CloseHandle(hThread)
256 isSweeping = False
257 End Sub
258
259Private
260
261 Static Function IsNull( object As Object ) As Boolean
262 Return Object.ReferenceEquals(object, Nothing)
263 End Function
264
265 ' 生存検知
266 Function HitTest(pSample As VoidPtr) As Long
267 Dim i As Long
268 For i=0 To ELM(n)
269 If (ppPtr[i] As LONG_PTR)<=(pSample As LONG_PTR) and (pSample As LONG_PTR)<((ppPtr[i] As LONG_PTR)+pSize[i]) Then
270 Return i
271 End If
272 Next
273 Return -1
274 End Function
275
276 ' オブジェクトのスキャン
277 Function ScanObject(pObject As *Object, pbMark As *Byte) As Boolean
278 Dim classTypeInfo = Nothing As ActiveBasic.Core._System_TypeForClass
279 classTypeInfo = pObject->GetType() As ActiveBasic.Core._System_TypeForClass
280
281 If IsNull( classTypeInfo ) Then
282 Return False
283 End If
284
285 Dim i As Long
286 For i = 0 To ELM(classTypeInfo.numOfReference)
287 Scan( (pObject + classTypeInfo.referenceOffsets[i]) As *LONG_PTR, 1, pbMark )
288 Next
289
290 Return True
291 End Function
292
293 ' 指定領域のスキャン
294 Sub Scan(pStartPtr As *LONG_PTR, maxNum As Long, pbMark As *Byte)
295 Dim i As Long, index As Long
296
297 For i=0 To ELM(maxNum)
298 index=HitTest(pStartPtr[i] As VoidPtr)
299 If index<>-1 Then
300 If pbMark[index]=0 Then
301 pbMark[index]=1
302
303 If pdwFlags[index] and _System_GC_FLAG_OBJECT Then
304 ' オブジェクトの場合
305 If ScanObject( (ppPtr[index] + 4*SizeOf(LONG_PTR)) As *Object, pbMark) = False Then
306 Dim maxNum = (pSize[index]\SizeOf(LONG_PTR)) As Long
307 Scan(ppPtr[index] As *LONG_PTR, maxNum, pbMark)
308 End If
309
310 ElseIf (pdwFlags[index] and _System_GC_FLAG_ATOMIC)=0 Then
311 ' ヒープ領域がポインタ値を含む可能性があるとき
312 If ppPtr[index] = 0 Then
313 'エラー
314
315 End If
316
317 Dim maxNum = (pSize[index]\SizeOf(LONG_PTR)) As Long
318 Scan(ppPtr[index] As *LONG_PTR, maxNum, pbMark)
319 End If
320 End If
321 End If
322 Next
323 End Sub
324
325 ' ローカル領域をルートに指定してスキャン
326 Sub LocalScan( pbMark As *Byte )
327 Dim Context As CONTEXT
328 Dim NowSp As *LONG_PTR
329 Dim size As LONG_PTR
330 Dim i As Long
331 For i=0 To ELM(_System_pobj_AllThreads->ThreadNum)
332 If _System_pobj_AllThreads->ppobj_Thread[i] Then
333 FillMemory(VarPtr(Context),SizeOf(CONTEXT),0)
334 Context.ContextFlags=CONTEXT_CONTROL
335 If _System_pobj_AllThreads->ppobj_Thread[i]->__GetContext(Context)=0 Then
336 _System_DebugOnly_OutputDebugString(Ex"レジスタ情報の取得に失敗しました。\r\n")
337 End If
338
339#ifdef _WIN64
340 NowSp=Context.Rsp As *LONG_PTR
341#else
342 NowSp=Context.Esp As *LONG_PTR
343#endif
344
345 Dim size=(_System_pobj_AllThreads->pStackBase[i] As LONG_PTR)-(NowSp As LONG_PTR)
346 Dim maxNum = (size\SizeOf(LONG_PTR)) As Long
347
348 If NowSp = 0 Then
349 debug
350 Exit Sub
351 End If
352
353 Scan( NowSp, maxNum, pbMark )
354 End If
355 Next
356 End Sub
357
358 Sub DeleteGarbageMemories( pbMark As *Byte )
359
360 Dim isAllDelete = False
361 If pbMark = NULL Then
362 ' すべてを破棄するとき
363 isAllDelete = True
364 pbMark = _System_calloc( n )
365 End If
366
367 Dim i As Long
368 For i=0 To ELM(n)
369 If pbMark[i]=0 and ppPtr[i]<>0 and (pdwFlags[i] and _System_GC_FLAG_NEEDFREE)=0 Then
370 If ppPtr[i] = 0 Then
371 If isAllDelete Then
372 Continue
373 Else
374 debug
375 End If
376 End If
377
378 Dim ptr = ppPtr[i]
379 Dim size = pSize[i]
380
381 ppPtr[i]=0
382 pSize[i]=0
383
384 If (pdwFlags[i] and _System_GC_FLAG_OBJECT) <> 0 Then
385 /* ・オブジェクトの個数
386 ・オブジェクトのサイズ
387 ・デストラクタの関数ポインタ
388 ・リザーブ領域
389 を考慮 */
390 _System_SweepingDelete (ptr + SizeOf( LONG_PTR ) * 4 )
391 Else
392 HeapFree(_System_hProcessHeap,0,ptr)
393 End If
394
395 iAllSize-=size
396 End If
397 Next
398
399 If isAllDelete Then
400 _System_free( pbMark )
401 End If
402
403 End Sub
404
405 Sub DeleteAllGarbageMemories()
406 DeleteGarbageMemories( NULL )
407 End Sub
408
409 Sub Compaction()
410 Dim i As Long, i2 = 0 As Long
411 For i=0 To ELM(n)
412 ppPtr[i2] = ppPtr[i]
413 pSize[i2] = pSize[i]
414 pdwFlags[i2] = pdwFlags[i]
415
416 If ppPtr[i] Then
417 i2++
418 End If
419 Next
420 n = i2
421 End Sub
422
423 ' スウィープ(新規スレッドで呼び出し)
424 Function SweepOnOtherThread() As Long
425 EnterCriticalSection(CriticalSection)
426
427
428 Dim startTime = GetTickCount()
429
430 _System_DebugOnly_OutputDebugString( Ex"garbage colletion sweep start!\r\n" )
431
432
433 If isSweeping <> False or (iAllSize<limitMemorySize and n<limitMemoryObjectNum) Then
434 ExitThread(0)
435 End If
436 isSweeping = True
437
438 ' すべてのスレッドを一時停止
439 _System_pobj_AllThreads->SuspendAllThread()
440
441 ' マークリストを生成
442 Dim pbMark = HeapAlloc(_System_hProcessHeap,HEAP_ZERO_MEMORY,n*SizeOf(Byte)) As *Byte
443
444 ' グローバル領域をルートに指定してスキャン
445 Dim i As Long
446 For i = 0 To ELM( globalRootNum )
447 Scan( pGlobalRoots[i].ptr, pGlobalRoots[i].count, pbMark )
448 Next
449
450 ' ローカル領域をルートに指定してスキャン
451 LocalScan( pbMark )
452
453 ' スウィープ前のメモリサイズを退避
454 Dim iBackAllSize = iAllSize
455
456 ' スウィープ前のメモリオブジェクトの数
457 Dim iBeforeN = n
458
459 '使われていないメモリを解放する
460 DeleteGarbageMemories(pbMark)
461
462 'コンパクション
463 Compaction()
464
465 'マークリストを解放
466 HeapFree(_System_hProcessHeap,0,pbMark)
467
468 If iBackAllSize <= iAllSize * 2 Then
469 If iAllSize > limitMemorySize Then
470 limitMemorySize = iAllSize
471 End If
472
473 '許容量を拡張する
474 limitMemorySize *= 2
475 limitMemoryObjectNum *= 2
476
477 _System_DebugOnly_OutputDebugString( Ex"memory size is extended for gc!\r\n" )
478 End If
479
480 Dim temp[100] As Char
481 wsprintf(temp,Ex"object items ... %d -> %d ( %d MB -> %d MB )\r\n",iBeforeN,n, iBackAllSize\1024\1024, iAllSize\1024\1024)
482 _System_DebugOnly_OutputDebugString( temp )
483 wsprintf(temp,Ex"limit size of memory ... %d\r\n",limitMemorySize)
484 _System_DebugOnly_OutputDebugString( temp )
485 wsprintf(temp,Ex"garbage colletion sweep finish! (%d ms)\r\n\r\n", GetTickCount()-startTime)
486 _System_DebugOnly_OutputDebugString( temp )
487
488
489 '-------------------------------------
490 ' すべてのスレッドを再開
491 '-------------------------------------
492 _System_pobj_AllThreads->ResumeAllThread()
493
494 LeaveCriticalSection(CriticalSection)
495 End Function
496
497 ' 未解放のメモリオブジェクトをトレース
498 Sub DumpMemoryLeaks()
499 Dim isLeak = False
500 Dim i As Long
501 For i=0 To ELM(n)
502 If ppPtr[i] Then
503 If (pdwFlags[i] and _System_GC_FLAG_NEEDFREE)<>0 Then
504 If isLeak = False Then
505 _System_DebugOnly_OutputDebugString( Ex"Detected memory leaks!\r\n" )
506 isLeak = True
507 End If
508
509 Dim temp[100] As Char
510 _System_DebugOnly_OutputDebugString( Ex"heap free missing!\r\n" )
511 wsprintf(temp,Ex"{%d} normal block at &H%08X, %d bytes long.\r\n", i, ppPtr[i], pSize[i])
512 _System_DebugOnly_OutputDebugString( temp )
513 End If
514 End If
515 Next
516
517 If isLeak Then
518 _System_DebugOnly_OutputDebugString( Ex"Object dump complete.\r\n" )
519 End If
520
521 End Sub
522
523End Class
524
525'GC管理用の特殊なシステムオブジェクト(デストラクタは最終のタイミングで呼び出されます)
526Dim _System_pGC As *_System_CGarbageCollection
527
528
529
530Function GC_malloc(size As Long) As VoidPtr
531 ' sweep
532 _System_pGC->sweep()
533
534 'allocate
535 Return _System_pGC->__malloc(size,0)
536End Function
537
538Function GC_malloc_atomic(size As Long) As VoidPtr
539 ' sweep
540 _System_pGC->sweep()
541
542 'allocate
543 Return _System_pGC->__malloc(size,_System_GC_FLAG_ATOMIC)
544End Function
545
546Function _System_GC_malloc_ForObject(size As Long) As VoidPtr
547 ' sweep
548 _System_pGC->sweep()
549
550 'allocate
551 Return _System_pGC->__malloc(size,_System_GC_FLAG_OBJECT or _System_GC_FLAG_INITZERO)
552End Function
553
554Function _System_GC_malloc_ForObjectPtr(size As Long) As VoidPtr
555 ' sweep
556 _System_pGC->sweep()
557
558 'allocate
559 Return _System_pGC->__malloc(size,_System_GC_FLAG_OBJECT or _System_GC_FLAG_INITZERO or _System_GC_FLAG_NEEDFREE)
560End Function
561
562Function _System_GC_free_for_SweepingDelete( ptr As *Object )
563 ' free
564 _System_pGC->__free_ex( ptr, True )
565End Function
Note: See TracBrowser for help on using the repository browser.