/*! @brief このファイルでは、ABのガベージコレクションの実装を行います。 */ /* ※これらの変数はコンパイラが自動的に定義します。 Dim _System_gc_StackRoot_StartPtr As VoidPtr */ Const _System_GC_FLAG_ATOMIC = 1 Const _System_GC_FLAG_NEEDFREE = 2 Const _System_GC_FLAG_INITZERO = 4 Const _System_GC_FLAG_OBJECT = 8 Type _System_GlobalRoot ptr As *LONG_PTR count As Long End Type Type _System_MemoryObject ptr As VoidPtr size As SIZE_T flags As DWord generationCount As Long End Type Class _System_CGarbageCollection hHeap As HANDLE ' GC用のヒープ pMemoryObjects As *_System_MemoryObject ' メモリオブジェクト countOfMemoryObjects As Long ' 管理するメモリオブジェクトの個数 iAllSize As SIZE_T isSweeping As Boolean ' スウィープ中かどうか minPtr As ULONG_PTR maxPtr As ULONG_PTR ' クリティカルセクション CriticalSection As CRITICAL_SECTION ' メモリの上限値(この値を超えるとGCが発動します) limitMemorySize As LONG_PTR ' バイト単位 limitMemoryObjectNum As Long ' メモリオブジェクトの個数単位 isFinish As Boolean ' GC管理が終了したかどうか ' Global Root pGlobalRoots As *_System_GlobalRoot globalRootNum As Long Sub AddGlobalRootPtr( ptr As *LONG_PTR, count As Long ) pGlobalRoots = _System_realloc( pGlobalRoots, (globalRootNum + 1) * SizeOf(_System_GlobalRoot) ) pGlobalRoots[globalRootNum].ptr = ptr pGlobalRoots[globalRootNum].count = count globalRootNum++ End Sub Sub RegisterGlobalRoots() ' このメソッドの実装はコンパイラが自動生成する ' AddGlobalRootPtr(...) ' ... End Sub ' 特殊クラスのため、コンストラクタ・デストラクタは呼ばれません Sub _System_CGarbageCollection() End Sub Sub ~_System_CGarbageCollection() End Sub Public /*! @brief 環境変数にGCを登録する @author Daisuke Yamamoto @date 2007/10/21 */ Static Sub Initialize() Dim temporary[255] As Char If GetEnvironmentVariable( "ActiveBasicGarbageCollection", temporary, 255 ) Then ' 既にGCがプロセスに存在するとき _stscanf( temporary, "%08x", VarPtr( _System_pGC ) ) MessageBox(0,temporary,"GetEnvironmentVariable",0) ' TODO: Else _System_pGC = _System_calloc( __ClassSizeOf( _System_CGarbageCollection ) ) _System_pGC->Begin() ' GCをプロセスに登録する _stprintf( temporary, "%08x", _System_pGC ) SetEnvironmentVariable( "ActiveBasicGarbageCollection", temporary ) End If End Sub /*! @brief メモリサイズの上限を指定する @param limitMemorySize メモリサイズの上限(単位はバイト) limitMemoryObjectNum メモリ個数の上限 @author Daisuke Yamamoto @date 2007/10/21 */ Sub SetLimit( limitMemorySize As LONG_PTR, limitMemoryObjectNum As Long ) This.limitMemorySize = limitMemorySize This.limitMemoryObjectNum = limitMemoryObjectNum End Sub /*! @brief 初期化 @author Daisuke Yamamoto @date 2007/10/21 */ Sub Begin() If pMemoryObjects Then Exit Sub isFinish = False 'メモリの上限値(この値を超えるとGCが発動します) SetLimit( 1024*1024, ' バイト単位 2000 ' メモリオブジェクトの個数単位 ) hHeap = HeapCreate( 0, 0, 0 ) pMemoryObjects = _System_calloc( 1 ) countOfMemoryObjects=0 ' Global Root pGlobalRoots = _System_calloc( 1 ) globalRootNum = 0 RegisterGlobalRoots() iAllSize=0 ' スウィープ中かどうか isSweeping = False minPtr = &HFFFFFFFFFFFFFFFF As ULONG_PTR maxPtr = 0 'クリティカルセッションを生成 InitializeCriticalSection(CriticalSection) '--------------------------- ' 開始時のスレッドを通知 '--------------------------- Dim hTargetThread As HANDLE DuplicateHandle(GetCurrentProcess(), GetCurrentThread(), GetCurrentProcess(), hTargetThread, 0, FALSE, DUPLICATE_SAME_ACCESS) 'カレントスレッドのハンドルを複製 ' スレッド管理用オブジェクトを生成 _System_pobj_AllThreads = New System.Threading.Detail._System_CThreadCollection() ' 自身のThreadオブジェクトを生成 Dim thread = New System.Threading.Thread(hTargetThread, GetCurrentThreadId(), 0) thread.Name = "main" _System_pobj_AllThreads->BeginThread(thread, _System_gc_StackRoot_StartPtr As *LONG_PTR) End Sub /*! @brief 終了処理 @author Daisuke Yamamoto @date 2007/10/21 */ Sub Finish() If pMemoryObjects = NULL Then Exit Sub isFinish = True ' スレッド管理用オブジェクトを破棄 Delete _System_pobj_AllThreads ' 自分以外のスレッドを一時停止 '_System_pobj_AllThreads->SuspendAnotherThread() _System_DebugOnly_OutputDebugString( Ex"garbage colletion sweeping all memory objects!\r\n" ) DeleteAllGarbageMemories() ' 未解放のメモリオブジェクトをトレース DumpMemoryLeaks() ' 自分以外のスレッドを再開 '_System_pobj_AllThreads->ResumeAnotherThread() _System_free( pMemoryObjects ) pMemoryObjects = NULL _System_free( pGlobalRoots ) pGlobalRoots = NULL 'クリティカルセッションを破棄 DeleteCriticalSection(CriticalSection) End Sub /*! @brief メモリオブジェクトからインデックスを取得する @param new_ptr メモリオブジェクトへのポインタ @author Daisuke Yamamoto @date 2007/10/21 */ Function GetMemoryObjectPtr( ptr As VoidPtr ) As *_System_MemoryObject ' メモリオブジェクトの先頭部分からインデックスを取得する Dim index = Get_LONG_PTR( ptr - SizeOf(LONG_PTR) ) As Long If pMemoryObjects[index].ptr <> ptr Then ' メモリイメージが壊れている(先頭に存在するインデックスの整合性が取れない) Dim temporary[1024] As Char #ifdef _WIN64 'wsprintfでは、Windows 2000以降でしか%pが使えない。 wsprintf( temporary, Ex"indexOfMemoryObjects: %d\r\npMemoryObjects[index].ptr: &H%p\r\nptr: &H%p\r\n", index, pMemoryObjects[index].ptr, ptr ) #else wsprintf( temporary, Ex"indexOfMemoryObjects: %d\r\npMemoryObjects[index].ptr: &H%08x\r\nptr: &H%08x\r\n", index, pMemoryObjects[index].ptr, ptr ) #endif _System_DebugOnly_OutputDebugString( temporary ) debug End If Return VarPtr( pMemoryObjects[index] ) End Function /*! @brief メモリオブジェクトを追加する @param new_ptr メモリオブジェクトへのポインタ size メモリオブジェクトのサイズ flags メモリオブジェクトの属性 @author Daisuke Yamamoto @date 2007/10/21 */ Sub add(new_ptr As VoidPtr, size As SIZE_T, flags As DWord) EnterCriticalSection(CriticalSection) iAllSize+=size ' メモリオブジェクトインスタンスの先頭にインデックスをセットする Set_LONG_PTR( new_ptr - SizeOf( LONG_PTR ), countOfMemoryObjects ) pMemoryObjects = _System_realloc( pMemoryObjects, (countOfMemoryObjects+1)*SizeOf(_System_MemoryObject) ) pMemoryObjects[countOfMemoryObjects].ptr = new_ptr pMemoryObjects[countOfMemoryObjects].size = size pMemoryObjects[countOfMemoryObjects].flags = flags pMemoryObjects[countOfMemoryObjects].generationCount = 0 If minPtr > new_ptr As ULONG_PTR Then minPtr = new_ptr As ULONG_PTR End If If maxPtr < ( new_ptr + size ) As ULONG_PTR Then maxPtr = ( new_ptr + size ) As ULONG_PTR End If countOfMemoryObjects++ LeaveCriticalSection(CriticalSection) /* ' デバッグ用 If countOfMemoryObjects = 1996 Then debug End If */ End Sub /*! @brief メモリオブジェクトを確保する @param size メモリオブジェクトのサイズ flags メモリオブジェクトの属性 @author Daisuke Yamamoto @date 2007/10/21 */ Function __malloc(size As SIZE_T,flags As Byte) As VoidPtr Dim dwFlags As DWord If flags and _System_GC_FLAG_INITZERO Then dwFlags=HEAP_ZERO_MEMORY Else dwFlags=0 End If ' 実際のメモリバッファはインデックスの分だけ多めに確保する __malloc = HeapAlloc( hHeap, dwFlags, size + SizeOf( LONG_PTR ) ) throwIfAllocationFailed( __malloc, size ) __malloc += SizeOf( LONG_PTR ) ' 管理対象のメモリオブジェクトとして追加 add( __malloc, size, flags ) End Function /*! @brief メモリオブジェクトを再確保する @param lpMem メモリオブジェクトへのポインタ size メモリオブジェクトのサイズ flags メモリオブジェクトの属性 @author Daisuke Yamamoto @date 2007/10/21 */ Function __realloc(lpMem As VoidPtr, size As SIZE_T) As VoidPtr EnterCriticalSection(CriticalSection) ' メモリオブジェクトを取得 Dim pTempMemoryObject = GetMemoryObjectPtr( lpMem ) iAllSize += size - pTempMemoryObject->size pTempMemoryObject->size = size __realloc = HeapReAlloc( hHeap, HEAP_ZERO_MEMORY, pTempMemoryObject->ptr - SizeOf(LONG_PTR), size + SizeOf(LONG_PTR) ) If __realloc = 0 Then LeaveCriticalSection(CriticalSection) throwIfAllocationFailed(0, size) End If __realloc += SizeOf(LONG_PTR) pTempMemoryObject->ptr = __realloc If minPtr > pTempMemoryObject->ptr As ULONG_PTR Then minPtr = pTempMemoryObject->ptr As ULONG_PTR End If If maxPtr < ( pTempMemoryObject->ptr + size ) As ULONG_PTR Then maxPtr = ( pTempMemoryObject->ptr + size ) As ULONG_PTR End If LeaveCriticalSection(CriticalSection) End Function /*! @brief メモリ確保に失敗したか(NULLかどうか)を調べ、失敗していたら例外を投げる。 @param[in] p メモリへのポインタ @param[in] size 確保しようとした大きさ @exception OutOfMemoryException pがNULLだったとき @author Egtra @date 2007/12/24 ただし、sizeがあまりにも小さい場合は、例外を投げず、即座に終了する。 */ Sub throwIfAllocationFailed(p As VoidPtr, size As SIZE_T) If p = 0 Then If size < 256 Then /*  これだけのメモリも確保できない状況では、OutOfMemoryException のインスタンスすら作成できないかもしれないし、例え作成できても、 その後、結局メモリ不足でろくなことを行えないはず。そのため、 ここですぐに終了することにする。  なお、この値は特に根拠があって定められた値ではない。 */ HeapDestroy(hHeap) OutputDebugString("AB malloc: Out of memory.") ExitProcess(-1) End If Dim s2 = Nothing As Object '#145 s2 = New System.UInt64(size) Throw New System.OutOfMemoryException(ActiveBasic.Strings.SPrintf("malloc: Failed to allocate %zu (%&zx) byte(s) memory.", s2, s2)) End If End Sub /*! @brief メモリオブジェクトを解放する @param lpMem メモリオブジェクトへのポインタ isSweeping スウィープ中にこのメソッドが呼ばれるときはTrue、それ以外はFalse @author Daisuke Yamamoto @date 2007/10/21 */ Sub __free_ex(lpMem As VoidPtr, isSweeping As Boolean) EnterCriticalSection(CriticalSection) ' メモリオブジェクトを取得 Dim pTempMemoryObject = GetMemoryObjectPtr( lpMem ) If (pTempMemoryObject->flags and _System_GC_FLAG_NEEDFREE)<>0 or isSweeping Then iAllSize -= pTempMemoryObject->size HeapFree( hHeap, 0, pTempMemoryObject->ptr - SizeOf(LONG_PTR) ) pTempMemoryObject->ptr = NULL pTempMemoryObject->size = 0 Else If isFinish = False Then _System_DebugOnly_OutputDebugString( Ex"heap free missing!\r\n" ) End If End If LeaveCriticalSection(CriticalSection) End Sub /*! @brief メモリオブジェクトを解放する @param lpMem メモリオブジェクトへのポインタ @author Daisuke Yamamoto @date 2007/10/21 */ Sub __free(lpMem As VoidPtr) __free_ex( lpMem, False ) End Sub /*! @brief 必要であればスウィープする @author Daisuke Yamamoto @date 2007/10/21 */ Sub TrySweep() If isSweeping <> False or (iAllSizeGetType() As ActiveBasic.Core._System_TypeForClass If Object.ReferenceEquals( classTypeInfo, ActiveBasic.Core._System_TypeBase.selfTypeInfo ) Then ' TypeInfoクラスの場合はTypeBaseImplクラスとして扱う classTypeInfo = _System_TypeBase_Search( "ActiveBasic.Core.TypeBaseImpl" ) As ActiveBasic.Core._System_TypeForClass End If Return ScanObject( classTypeInfo, pObject, pbMark ) End Function /*! @brief メモリオブジェクトのスキャン @param pStartPtr メモリオブジェクトへのポインタ maxNum スキャンするメモリオブジェクトの個数 pbMark マークリスト @author Daisuke Yamamoto @date 2007/10/21 */ Sub Scan(pStartPtr As *LONG_PTR, maxNum As Long, pbMark As *Byte) Dim i As Long, index As Long For i=0 To ELM(maxNum) index=HitTest(pStartPtr[i] As VoidPtr) If index<>-1 Then If pbMark[index]=0 Then pbMark[index]=1 ' ジェネレーションカウントを増やす pMemoryObjects[index].generationCount ++ If pMemoryObjects[index].flags and _System_GC_FLAG_OBJECT Then ' オブジェクトの場合 If ScanObject( (pMemoryObjects[index].ptr + 4*SizeOf(LONG_PTR)) As *Object, pbMark) = False Then Dim maxNum = (pMemoryObjects[index].size\SizeOf(LONG_PTR)) As Long Scan(pMemoryObjects[index].ptr As *LONG_PTR, maxNum, pbMark) End If ElseIf (pMemoryObjects[index].flags and _System_GC_FLAG_ATOMIC)=0 Then ' ヒープ領域がポインタ値を含む可能性があるとき If pMemoryObjects[index].ptr = NULL Then 'エラー End If Dim maxNum = (pMemoryObjects[index].size\SizeOf(LONG_PTR)) As Long Scan(pMemoryObjects[index].ptr As *LONG_PTR, maxNum, pbMark) End If End If End If Next End Sub /*! @brief グローバル領域をルートに指定してスキャン @param pbMark マークリスト @author Daisuke Yamamoto @date 2007/10/21 */ Sub GlobalScan( pbMark As *Byte ) Dim i As Long For i = 0 To ELM( globalRootNum ) Scan( pGlobalRoots[i].ptr, pGlobalRoots[i].count, pbMark ) Next End Sub /*! @brief ローカル領域をルートに指定してスキャン @param pbMark マークリスト @author Daisuke Yamamoto @date 2007/10/21 */ Sub LocalScan( pbMark As *Byte ) Dim Context As CONTEXT Dim NowSp As *LONG_PTR Dim size As LONG_PTR Dim i As Long For i=0 To ELM(_System_pobj_AllThreads->ThreadNum) Dim thread = _System_pobj_AllThreads->collection[i].thread If Not ActiveBasic.IsNothing(thread) Then FillMemory(VarPtr(Context),SizeOf(CONTEXT),0) Context.ContextFlags=CONTEXT_CONTROL If thread.__GetContext(Context)=0 Then _System_DebugOnly_OutputDebugString(Ex"レジスタ情報の取得に失敗しました。\r\n") End If #ifdef _WIN64 NowSp=Context.Rsp As *LONG_PTR #else NowSp=Context.Esp As *LONG_PTR #endif Dim size=(_System_pobj_AllThreads->collection[i].stackBase As LONG_PTR)-(NowSp As LONG_PTR) Dim maxNum = (size\SizeOf(LONG_PTR)) As Long If NowSp = 0 Then debug Exit Sub End If /* _System_DebugOnly_OutputDebugString( "(scanning thread local)" ) _System_DebugOnly_OutputDebugString( thread.Name ) _System_DebugOnly_OutputDebugString( Ex"\r\n" ) */ Scan( NowSp, maxNum, pbMark ) End If Next End Sub /*! @brief 生存していないメモリオブジェクトを解放する @param pbMark マークリスト @author Daisuke Yamamoto @date 2007/10/21 */ Sub DeleteGarbageMemories( pbMark As *Byte ) Dim isAllDelete = False If pbMark = NULL Then ' すべてを破棄するとき isAllDelete = True pbMark = _System_calloc( countOfMemoryObjects ) End If Dim i As Long For i=0 To ELM(countOfMemoryObjects) If pbMark[i]=0 and pMemoryObjects[i].ptr<>0 and (pMemoryObjects[i].flags and _System_GC_FLAG_NEEDFREE)=0 Then If pMemoryObjects[i].ptr = NULL Then If isAllDelete Then Continue Else debug End If End If Dim ptr = pMemoryObjects[i].ptr Dim size = pMemoryObjects[i].size If (pMemoryObjects[i].flags and _System_GC_FLAG_OBJECT) <> 0 Then /* ・オブジェクトの個数 ・オブジェクトのサイズ ・デストラクタの関数ポインタ ・リザーブ領域 を考慮 */ _System_SweepingDelete (ptr + SizeOf( LONG_PTR ) * 4 ) Else __free_ex( ptr, True ) End If End If Next If isAllDelete Then _System_free( pbMark ) End If End Sub /*! @brief GCが管理するすべてのメモリオブジェクトを解放する @author Daisuke Yamamoto @date 2007/10/21 */ Sub DeleteAllGarbageMemories() DeleteGarbageMemories( NULL ) End Sub /*! @brief コンパクション @author Daisuke Yamamoto @date 2007/10/21 */ Sub Compaction() Dim i As Long, i2 = 0 As Long For i=0 To ELM(countOfMemoryObjects) pMemoryObjects[i2] = pMemoryObjects[i] If pMemoryObjects[i2].ptr Then ' メモリオブジェクトの先頭部分にあるインデックスを書き換える Set_LONG_PTR( pMemoryObjects[i2].ptr - SizeOf(LONG_PTR), i2 ) i2++ End If Next countOfMemoryObjects = i2 End Sub /*! @brief スウィープ(新規スレッドで呼び出す必要あり) @author Daisuke Yamamoto @date 2007/10/21 */ Function SweepOnOtherThread() As Long Imports System.Threading.Detail EnterCriticalSection(CriticalSection) Dim startTime = GetTickCount() _System_DebugOnly_OutputDebugString( Ex"garbage colletion sweep start!\r\n" ) 'If isSweeping <> False or (iAllSizeSuspendAllThread() ' マークリストを生成 Dim pbMark = _System_calloc(countOfMemoryObjects*SizeOf(Byte)) As *Byte ' グローバル領域をルートに指定してスキャン GlobalScan( pbMark ) ' ローカル領域をルートに指定してスキャン LocalScan( pbMark ) ' スウィープ前のメモリサイズを退避 Dim iBackAllSize = iAllSize ' スウィープ前のメモリオブジェクトの数 Dim iBeforeN = countOfMemoryObjects '使われていないメモリを解放する DeleteGarbageMemories(pbMark) 'コンパクション Compaction() 'マークリストを解放 _System_free(pbMark) If iBackAllSize <= iAllSize * 2 Then If iAllSize > limitMemorySize Then limitMemorySize = iAllSize End If '許容量を拡張する limitMemorySize *= 2 limitMemoryObjectNum *= 2 _System_DebugOnly_OutputDebugString( Ex"memory size is extended for gc!\r\n" ) End If Dim temp[100] As Char wsprintf(temp,Ex"object items ... %d -> %d ( %d MB -> %d MB )\r\n",iBeforeN,countOfMemoryObjects, iBackAllSize\1024\1024, iAllSize\1024\1024) _System_DebugOnly_OutputDebugString( temp ) wsprintf(temp,Ex"limit size of memory ... %d\r\n",limitMemorySize) _System_DebugOnly_OutputDebugString( temp ) wsprintf(temp,Ex"garbage colletion sweep finish! (%d ms)\r\n\r\n", GetTickCount()-startTime) _System_DebugOnly_OutputDebugString( temp ) '------------------------------------- ' すべてのスレッドを再開 '------------------------------------- _System_pobj_AllThreads->ResumeAllThread() LeaveCriticalSection(CriticalSection) End Function /*! @brief 未解放のメモリオブジェクトをデバッグ出力する @author Daisuke Yamamoto @date 2007/10/21 */ Sub DumpMemoryLeaks() Dim isLeak = False Dim i As Long For i=0 To ELM(countOfMemoryObjects) If pMemoryObjects[i].ptr Then If (pMemoryObjects[i].flags and _System_GC_FLAG_NEEDFREE)<>0 Then If isLeak = False Then _System_DebugOnly_OutputDebugString( Ex"Detected memory leaks!\r\n" ) isLeak = True End If Dim temp[100] As Char _System_DebugOnly_OutputDebugString( Ex"heap free missing!\r\n" ) #ifdef _WIN64 wsprintf(temp,Ex"{%d} normal block at &H%p, %d bytes long.\r\n", i, pMemoryObjects[i].ptr, pMemoryObjects[i].size) #else wsprintf(temp,Ex"{%d} normal block at &H%08X, %d bytes long.\r\n", i, pMemoryObjects[i].ptr, pMemoryObjects[i].size) #endif _System_DebugOnly_OutputDebugString( temp ) End If End If Next If isLeak Then _System_DebugOnly_OutputDebugString( Ex"Object dump complete.\r\n" ) End If End Sub End Class 'GC管理用の特殊なシステムオブジェクト(デストラクタは最終のタイミングで呼び出されます) Dim _System_pGC As *_System_CGarbageCollection Function GC_malloc(size As SIZE_T) As VoidPtr ' sweep _System_pGC->TrySweep() 'allocate Return _System_pGC->__malloc(size,0) End Function Function GC_malloc_atomic(size As SIZE_T) As VoidPtr ' sweep _System_pGC->TrySweep() 'allocate Return _System_pGC->__malloc(size,_System_GC_FLAG_ATOMIC) End Function Function _System_GC_malloc_ForObject(size As SIZE_T) As VoidPtr ' sweep _System_pGC->TrySweep() 'allocate Return _System_pGC->__malloc(size,_System_GC_FLAG_OBJECT or _System_GC_FLAG_INITZERO) End Function Function _System_GC_malloc_ForObjectPtr(size As SIZE_T) As VoidPtr ' sweep _System_pGC->TrySweep() 'allocate Return _System_pGC->__malloc(size,_System_GC_FLAG_OBJECT or _System_GC_FLAG_INITZERO or _System_GC_FLAG_NEEDFREE) End Function Sub _System_GC_free_for_SweepingDelete( ptr As *Object ) ' free _System_pGC->__free_ex( ptr, True ) End Sub