source: Include/system/gc.sbp@ 78

/*
※これらの変数はコンパイラが自動的に定義します。
Dim _System_gc_GlobalRoot_StartPtr As VoidPtr
Dim _System_gc_GlobalRoot_Size As Long
Dim _System_gc_StackRoot_StartPtr As VoidPtr
*/

Function _System_GetSp() As LONG_PTR                    'dummy
End Function


'メモリの上限値（この値を超えるとGCが発動します）
'※バイト単位
Dim _System_SWEEP_LIMIT_MEMORY = 1024*1024*30 As LONG_PTR

Const _System_GC_FLAG_ATOMIC = 1
Const _System_GC_FLAG_NEEDFREE = 2
Const _System_GC_FLAG_INITZERO = 4

Const THREAD_GET_CONTEXT  = &H0008

Class _System_CGarbageCollection
    ppPtr As **VoidPtr
    pSize As *SIZE_T
    pbFlags As *Byte
    n As Long

    iAllSize As SIZE_T

    CriticalSection As CRITICAL_SECTION

Public
    Sub _System_CGarbageCollection()
        If ppPtr Then Exit Sub

        ppPtr=HeapAlloc(_System_hProcessHeap,0,1)
        pSize=HeapAlloc(_System_hProcessHeap,0,1)
        pbFlags=HeapAlloc(_System_hProcessHeap,0,1)
        n=0

        iAllSize=0

        'スレッド情報管理用オブジェクトを生成
        _System_pobj_AllThreads=_System_malloc(SizeOf(_System_CThreadCollection)+SizeOf(LONG_PTR))
        _System_pobj_AllThreads->_System_CThreadCollection()

        'クリティカルセッションを生成
        InitializeCriticalSection(CriticalSection)


        '---------------------------
        ' 開始時のスレッドを通知
        '---------------------------
        Dim hTargetThread As HANDLE
        DuplicateHandle(GetCurrentProcess(),
            GetCurrentThread(),
            GetCurrentProcess(),
            hTargetThread, 0, FALSE, DUPLICATE_SAME_ACCESS)     'カレントスレッドのハンドルを複製


        '自身のThreadオブジェクトを生成
        Dim obj_Thread As Thread(hTargetThread,GetCurrentThreadId(),0)

        _System_pobj_AllThreads->BeginThread(obj_Thread,_System_gc_StackRoot_StartPtr As *LONG_PTR)
    End Sub
    Sub ~_System_CGarbageCollection()
        If ppPtr=0 Then Exit Sub

        '解放スレッドを生成
        Dim hThread As HANDLE
        Dim ThreadId As DWord
        hThread=_beginthreadex(NULL,0,AddressOf(DestructorThread),VarPtr(This),0,ThreadId)
        CloseHandle(hThread)
        Sleep(INFINITE)
    End Sub

Private
    Function Cdecl DestructorThread() As Long
        '-------------------------------------
        ' すべてのスレッドを一時停止
        '-------------------------------------
        _System_pobj_AllThreads->SuspendAllThread()


        Dim i As Long
        For i=0 To ELM(n)
            If ppPtr[i] Then HeapFree(_System_hProcessHeap,0,ppPtr[i])
        Next
        HeapFree(_System_hProcessHeap,0,ppPtr)
        ppPtr=0

        HeapFree(_System_hProcessHeap,0,pSize)
        pSize=0
        HeapFree(_System_hProcessHeap,0,pbFlags)
        pbFlags=0

        'スレッド情報管理用オブジェクトを破棄
        _System_pobj_AllThreads->Finalize()
        _System_free(_System_pobj_AllThreads)
        _System_pobj_AllThreads=0

        'クリティカルセッションを破棄
        DeleteCriticalSection(CriticalSection)


        'プロセスを終了
        ExitProcess(0)
    End Function
Public



    Sub add(new_ptr As VoidPtr, size As SIZE_T,flags As Byte)
        iAllSize+=size

        Dim i As Long
        For i=0 To ELM(n)
            If ppPtr[i]=0 Then
                ppPtr[i]=new_ptr
                pSize[i]=size
                pbFlags[i]=flags
                Exit Sub
            End If
        Next

        ppPtr=HeapReAlloc(_System_hProcessHeap,0,ppPtr,(n+1)*SizeOf(VoidPtr))
        ppPtr[n]=new_ptr

        pSize=HeapReAlloc(_System_hProcessHeap,0,pSize,(n+1)*SizeOf(SIZE_T))
        pSize[n]=size

        pbFlags=HeapReAlloc(_System_hProcessHeap,0,pbFlags,(n+1)*SizeOf(Byte))
        pbFlags[n]=flags

        n++
    End Sub


    Function __malloc(size As SIZE_T,flags As Byte) As VoidPtr
        EnterCriticalSection(CriticalSection)
            Dim dwFlags As DWord
            If flags and _System_GC_FLAG_INITZERO Then
                dwFlags=HEAP_ZERO_MEMORY
            Else
                dwFlags=0
            End If


            Dim pTemp As VoidPtr
            pTemp=HeapAlloc(_System_hProcessHeap,dwFlags,size)
            add(pTemp,size,flags)
        LeaveCriticalSection(CriticalSection)
        Return pTemp
    End Function

    Function __realloc(lpMem As VoidPtr, size As SIZE_T) As VoidPtr
        EnterCriticalSection(CriticalSection)
            Dim i As Long
            For i=0 To ELM(n)
                If ppPtr[i]=lpMem Then
                    iAllSize+=size-pSize[i]

                    pSize[i]=size
                    ppPtr[i]=HeapReAlloc(_System_hProcessHeap,HEAP_ZERO_MEMORY,lpMem,size)

                    LeaveCriticalSection(CriticalSection)
                    Return ppPtr[i]
                End If
            Next
        LeaveCriticalSection(CriticalSection)
        Return 0
    End Function

    Sub __free(lpMem As VoidPtr)
        EnterCriticalSection(CriticalSection)
            Dim i As Long
            For i=0 To ELM(n)
                If ppPtr[i]=lpMem Then
                    If pbFlags[i] and _System_GC_FLAG_NEEDFREE Then
                        iAllSize-=pSize[i]

                        HeapFree(_System_hProcessHeap,0,ppPtr[i])
                        ppPtr[i]=0
                        pSize[i]=0
                    Else
                        OutputDebugString(Ex"GCが管理しているメモリ空間を解放しようとしました。\r\n")
                    End If
                End If
            Next
        LeaveCriticalSection(CriticalSection)
    End Sub

    Sub sweep()
        EnterCriticalSection(CriticalSection)

            If iAllSize<_System_SWEEP_LIMIT_MEMORY Then
                'メモリ使用量が上限値を超えていないとき
                LeaveCriticalSection(CriticalSection)
                Exit Sub
            End If

            Dim hThread As HANDLE
            Dim ThreadId As DWord
            hThread=_beginthreadex(NULL,0,AddressOf(SweepOnOtherThread),VarPtr(This),0,ThreadId)
            WaitForSingleObject(hThread,INFINITE)
            CloseHandle(hThread)

        LeaveCriticalSection(CriticalSection)
    End Sub

    Function Cdecl SweepOnOtherThread() As Long

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


        'マークリストを生成
        pbMark=HeapAlloc(_System_hProcessHeap,HEAP_ZERO_MEMORY,n*SizeOf(Byte))


        '-----------------------------------------------
        ' グローバル領域をルートに指定してスキャン
        '-----------------------------------------------
        scan(_System_gc_GlobalRoot_StartPtr,_System_gc_GlobalRoot_Size)

        '-----------------------------------------------
        'ローカル領域をルートに指定してスキャン
        '-----------------------------------------------
        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)
            If _System_pobj_AllThreads->ppobj_Thread[i] Then
                FillMemory(VarPtr(Context),SizeOf(CONTEXT),0)
                Context.ContextFlags=CONTEXT_CONTROL
                If _System_pobj_AllThreads->ppobj_Thread[i]->__GetContext(Context)=0 Then
                    OutputDebugString(Ex"レジスタ情報の取得に失敗しました。\r\n")
                End If

#ifdef _WIN64
                NowSp=Context.Rsp As *LONG_PTR
#else
                NowSp=Context.Esp As *LONG_PTR
#endif

                size=(_System_pobj_AllThreads->pStackBase[i] As LONG_PTR)-(NowSp As LONG_PTR)

                scan(NowSp,size)
            End If
        Next


        Dim iBackAllSize As SIZE_T
        iBackAllSize=iAllSize

        '使われていないメモリを解放する
        For i=0 To ELM(n)
            If pbMark[i]=0 and ppPtr[i]<>0 and (pbFlags[i] and _System_GC_FLAG_NEEDFREE)=0 Then
                iAllSize-=pSize[i]

                HeapFree(_System_hProcessHeap,0,ppPtr[i])
                ppPtr[i]=0
                pSize[i]=0
            End If
        Next

        'マークリストを解放
        HeapFree(_System_hProcessHeap,0,pbMark)

        If iBackAllSize=iAllSize Then
            '許容量を拡張する
            _System_SWEEP_LIMIT_MEMORY*=2
        End If


        '-------------------------------------
        ' すべてのスレッドを再開
        '-------------------------------------
        _System_pobj_AllThreads->ResumeAllThread()
    End Function


Private

    pbMark As *Byte

    Function HitTest(pSample As VoidPtr) As Long
        Dim i As Long
        For i=0 To ELM(n)
            If (ppPtr[i] As LONG_PTR)<=(pSample As LONG_PTR) and (pSample As LONG_PTR)<((ppPtr[i] As LONG_PTR)+pSize[i]) Then
                Return i
            End If
        Next
        Return -1
    End Function

    Sub scan(pStartPtr As *LONG_PTR, size As LONG_PTR)
        Dim i As Long, count As Long, index As Long
        count=(size\SizeOf(LONG_PTR)) As Long
        For i=0 To ELM(count)
            index=HitTest(pStartPtr[i] As VoidPtr)
            If index<>-1 Then
                If pbMark[index]=0 Then
                    pbMark[index]=1

                    If (pbFlags[index] and _System_GC_FLAG_ATOMIC)=0 Then
                        'ヒープ領域がポインタ値を含む可能性があるとき
                        scan(ppPtr[index] As *LONG_PTR,pSize[index])
                    End If
                End If
            End If
        Next
    End Sub
End Class

'GC管理用の特殊なシステムオブジェクト（デストラクタは最終のタイミングで呼び出されます）
Dim _System_GC As _System_CGarbageCollection



Function GC_malloc(size As Long) As VoidPtr
    ' sweep
    _System_GC.sweep()

    'allocate
    Return _System_GC.__malloc(size,0)
End Function

Function GC_malloc_atomic(size As Long) As VoidPtr
    ' sweep
    _System_GC.sweep()

    'allocate
    Return _System_GC.__malloc(size,_System_GC_FLAG_ATOMIC)
End Function