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

/*!
    @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)
        Else
            _System_pGC = _System_calloc( SizeOf( _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 Detail._System_CThreadCollection()

        ' 自身のThreadオブジェクトを生成
        Dim thread = New 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 (iAllSize<limitMemorySize and countOfMemoryObjects<limitMemoryObjectNum) Then
            'メモリ使用量が上限値を超えていないとき
            Exit Sub
        End If

        Sweep()
    End Sub

    /*!
    @brief  スウィープする
    @author Daisuke Yamamoto
    @date   2007/10/21
    */
    Sub Sweep()
        Dim hThread As HANDLE
        Dim ThreadId As DWord
        hThread=_beginthreadex(NULL,0,AddressOf(SweepOnOtherThread),VarPtr(This),0,ThreadId)
        WaitForSingleObject(hThread,INFINITE)
        CloseHandle(hThread)
        isSweeping = False
    End Sub

Private

    Static Function IsNull( object As Object ) As Boolean
        Return Object.ReferenceEquals(object, Nothing)
    End Function

    /*!
    @brief  メモリオブジェクトの生存検地
    @param  pSample メモリオブジェクトへのポインタ
    @author Daisuke Yamamoto
    @date   2007/10/21
    */
    Function HitTest(pSample As VoidPtr) As Long
        If pSample = NULL Then
            Return -1
        End If
        If not( minPtr <= pSample and pSample <= maxPtr ) Then
            Return -1
        End If

        Dim i As Long
        For i=0 To ELM(countOfMemoryObjects)
            If (pMemoryObjects[i].ptr As LONG_PTR)<=(pSample As LONG_PTR) and (pSample As LONG_PTR)<((pMemoryObjects[i].ptr As LONG_PTR)+pMemoryObjects[i].size) Then
                Return i
            End If
        Next
        Return -1
    End Function

    /*!
    @brief  オブジェクトのスキャン
    @param  pObject オブジェクトへのポインタ
            pbMark マークリスト
    @author Daisuke Yamamoto
    @date   2007/10/21
    */
    Function ScanObject( classTypeInfo As ActiveBasic.Core._System_TypeForClass, pObject As *Object, pbMark As *Byte) As Boolean
        If IsNull( classTypeInfo ) Then
            Return False
        End If

        ' 基底クラスをスキャン
        If Not IsNull( classTypeInfo.BaseType ) Then
            Dim baseClassTypeInfo = Nothing As ActiveBasic.Core._System_TypeForClass
            baseClassTypeInfo = classTypeInfo.BaseType As ActiveBasic.Core._System_TypeForClass
            ScanObject( baseClassTypeInfo, pObject, pbMark )
        End If

        /*
        _System_DebugOnly_OutputDebugString( "  (scanning object)" )
        _System_DebugOnly_OutputDebugString( classTypeInfo.Name )
        _System_DebugOnly_OutputDebugString( Ex"\r\n" )
        */

        Dim i As Long
        For i = 0 To ELM(classTypeInfo.numOfReference)
            Scan( (pObject + classTypeInfo.referenceOffsets[i]) As *LONG_PTR, 1, pbMark )
        Next

        Return True
    End Function
    Function ScanObject(pObject As *Object, pbMark As *Byte) As Boolean
        Dim classTypeInfo = Nothing As ActiveBasic.Core._System_TypeForClass
        classTypeInfo = pObject->GetType() 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 (iAllSize<limitMemorySize and countOfMemoryObjects<limitMemoryObjectNum) Then
        '   ExitThread(0)
        'End If
        isSweeping = True

        ' すべてのスレッドを一時停止
        _System_pobj_AllThreads->SuspendAllThread()

        ' マークリストを生成
        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 Long) As VoidPtr
    ' sweep
    _System_pGC->TrySweep()

    'allocate
    Return _System_pGC->__malloc(size,0)
End Function

Function GC_malloc_atomic(size As Long) 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 Long) 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 Long) 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