source: Include/system/gc.sbp@ 1

/*
※これらの変数はコンパイラが自動的に定義します。
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

    'スレッド情報
    phThread As *HANDLE
    pStackBase As **LONG_PTR
    ThreadNum As Long

    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

        'スレッド情報
        phThread=HeapAlloc(_System_hProcessHeap,0,1)
        pStackBase=HeapAlloc(_System_hProcessHeap,0,1)
        ThreadNum=0

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

        '開始時のスレッドを通知
        Dim hTargetThread As HANDLE
        DuplicateHandle(GetCurrentProcess(),
            GetCurrentThread(),
            GetCurrentProcess(),
            hTargetThread, 0, FALSE, DUPLICATE_SAME_ACCESS)     'カレントスレッドのハンドルを複製
        BeginThread(hTargetThread,_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
        '-------------------------------------
        ' すべてのスレッドを一時停止
        '-------------------------------------
        Dim i As Long
        For i=0 To ELM(ThreadNum)
            If phThread[i] Then
                SuspendThread(phThread[i])
            End If
        Next


        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

        'スレッド情報
        HeapFree(_System_hProcessHeap,0,phThread)
        phThread=0
        HeapFree(_System_hProcessHeap,0,pStackBase)
        pStackBase=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
        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)
                Return ppPtr[i]
            End If
        Next
        Return 0
    End Function

    Sub __free(lpMem As VoidPtr)
        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
    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

        '-------------------------------------
        ' すべてのスレッドを一時停止
        '-------------------------------------
        Dim i As Long
        For i=0 To ELM(ThreadNum)
            If phThread[i] Then
                SuspendThread(phThread[i])
            End If
        Next


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


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

        '-----------------------------------------------
        'ローカル領域をルートに指定してスキャン
        '-----------------------------------------------
        Dim NowSp As *LONG_PTR
        Dim Context As CONTEXT
        Dim size As LONG_PTR
        For i=0 To ELM(ThreadNum)
            If phThread[i] Then
                FillMemory(VarPtr(Context),SizeOf(CONTEXT),0)
                Context.ContextFlags=CONTEXT_CONTROL
                If GetThreadContext(phThread[i],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=(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


        '-------------------------------------
        ' すべてのスレッドを再開
        '-------------------------------------
        For i=0 To ELM(ThreadNum)
            If phThread[i] Then
                ResumeThread(phThread[i])
            End If
        Next
    End Function



    '----------------------------
    ' スレッド制御のメソッド
    '----------------------------
    Sub BeginThread(hThread As HANDLE,NowSp As *LONG_PTR)
        EnterCriticalSection(CriticalSection)
            Dim i As Long
            For i=0 To ELM(ThreadNum)
                If phThread[i]=0 Then
                    phThread[i]=hThread
                    pStackBase[i]=NowSp
                    Exit For
                End If
            Next

            If i=ThreadNum Then
                phThread=HeapReAlloc(_System_hProcessHeap,0,phThread,(ThreadNum+1)*SizeOf(HANDLE))
                phThread[ThreadNum]=hThread
                pStackBase=HeapReAlloc(_System_hProcessHeap,0,pStackBase,(ThreadNum+1)*SizeOf(LONG_PTR))
                pStackBase[ThreadNum]=NowSp
                ThreadNum++
            End If
        LeaveCriticalSection(CriticalSection)
    End Sub
    Sub EndThread(hThread As HANDLE)
        EnterCriticalSection(CriticalSection)
            Dim i As Long
            For i=0 To ELM(ThreadNum)
                If phThread[i]=hThread Then
                    phThread[i]=0
                    pStackBase[i]=0
                    Exit For
                End If
            Next
        LeaveCriticalSection(CriticalSection)
    End Sub


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