source: Include/system/gc.sbp@ 298

/*
    このファイルでは、ABのガベージコレクションの実装を行います。
*/


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


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

Class _System_CGarbageCollection

    ppPtr As *VoidPtr
    pSize As *SIZE_T
    pdwFlags As *DWord
    n As Long

    iAllSize As SIZE_T

    isSweeping As Boolean

    CriticalSection As CRITICAL_SECTION

    ' メモリの上限値（この値を超えるとGCが発動します）
    limitMemorySize As LONG_PTR     ' バイト単位
    limitMemoryObjectNum As Long    ' メモリオブジェクトの個数単位

    isFinish As Boolean


    ' 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

    Static Sub Initialize()
        Dim temporary[255] As Char
        If GetEnvironmentVariable( "ActiveBasicGarbageCollection", temporary, 255 ) Then
            ' 既にGCがプロセスに存在するとき
            sscanf( temporary, "%08x", VarPtr( _System_pGC ) )
            MessageBox(0,temporary,"GetEnvironmentVariable",0)
        Else
            _System_pGC = _System_calloc( SizeOf( _System_CGarbageCollection ) )
            _System_pGC->Begin()

            ' GCをプロセスに登録する
            sprintf( temporary, "%08x", _System_pGC )
            SetEnvironmentVariable( "ActiveBasicGarbageCollection", temporary )
        End If
    End Sub

    Sub Begin()
        If ppPtr Then Exit Sub

        isFinish = False

        'メモリの上限値（この値を超えるとGCが発動します）
        limitMemorySize = 1024*1024 As LONG_PTR     ' バイト単位
        limitMemoryObjectNum = 2000                 ' メモリオブジェクトの個数単位

        ppPtr=_System_calloc( 1 )
        pSize=_System_calloc( 1 )
        pdwFlags=_System_calloc( 1 )
        n=0

        ' Global Root
        pGlobalRoots = _System_calloc( 1 )
        globalRootNum = 0
        RegisterGlobalRoots()

        iAllSize=0

        ' スウィープ中かどうか
        isSweeping = False

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


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

        ' スレッド管理用オブジェクトを生成
        _System_pobj_AllThreads = New _System_CThreadCollection()

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

        _System_pobj_AllThreads->BeginThread(ObjPtr( thread ),_System_gc_StackRoot_StartPtr As *LONG_PTR)

    End Sub
    Sub Finish()
        If ppPtr=0 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( ppPtr )
        ppPtr = NULL

        _System_free( pSize )
        pSize = NULL
        _System_free( pdwFlags )
        pdwFlags = NULL

        _System_free( pGlobalRoots )
        pGlobalRoots = NULL

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

    End Sub

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

        EnterCriticalSection(CriticalSection)
            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

            pdwFlags=HeapReAlloc(_System_hProcessHeap,0,pdwFlags,(n+1)*SizeOf(DWord))
            pdwFlags[n]=flags
        LeaveCriticalSection(CriticalSection)

        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 ptr = HeapAlloc(_System_hProcessHeap,dwFlags,size)
            add( ptr, size, flags )
'       LeaveCriticalSection(CriticalSection)

        Return ptr
    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_ex(lpMem As VoidPtr, isSweeping As Boolean)
        EnterCriticalSection(CriticalSection)
            Dim i As Long
            For i=0 To ELM(n)
                If ppPtr[i]=lpMem Then
                    If (pdwFlags[i] and _System_GC_FLAG_NEEDFREE)<>0 or isSweeping Then
                        iAllSize-=pSize[i]

                        HeapFree(_System_hProcessHeap,0,ppPtr[i])
                        ppPtr[i]=0
                        pSize[i]=0
                    Else
                        If isFinish = False Then
                            _System_DebugOnly_OutputDebugString( Ex"heap free missing!\r\n" )
                        End If
                    End If
                End If
            Next
        LeaveCriticalSection(CriticalSection)
    End Sub

    Sub __free(lpMem As VoidPtr)
        __free_ex( lpMem, False )
    End Sub

    Sub sweep()
        If isSweeping <> False or (iAllSize<limitMemorySize and n<limitMemoryObjectNum) Then
            'メモリ使用量が上限値を超えていないとき
            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)
        isSweeping = False
    End Sub

Private

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

    ' 生存検知
    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

    ' オブジェクトのスキャン
    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 IsNull( classTypeInfo ) Then
            Return False
        End If

        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

    ' 指定領域のスキャン
    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

                    If pdwFlags[index] and _System_GC_FLAG_OBJECT Then
                        ' オブジェクトの場合
                        If ScanObject( (ppPtr[index] + 4*SizeOf(LONG_PTR)) As *Object, pbMark) = False Then
                            Dim maxNum = (pSize[index]\SizeOf(LONG_PTR)) As Long
                            Scan(ppPtr[index] As *LONG_PTR, maxNum, pbMark)
                        End If

                    ElseIf (pdwFlags[index] and _System_GC_FLAG_ATOMIC)=0 Then
                        ' ヒープ領域がポインタ値を含む可能性があるとき
                        If ppPtr[index] = 0 Then
                            'エラー

                        End If

                        Dim maxNum = (pSize[index]\SizeOf(LONG_PTR)) As Long
                        Scan(ppPtr[index] As *LONG_PTR, maxNum, pbMark)
                    End If
                End If
            End If
        Next
    End Sub

    ' ローカル領域をルートに指定してスキャン
    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)
            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
                    _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->pStackBase[i] As LONG_PTR)-(NowSp As LONG_PTR)
                Dim maxNum = (size\SizeOf(LONG_PTR)) As Long

                If NowSp = 0 Then
                    debug
                    Exit Sub
                End If

                Scan( NowSp, maxNum, pbMark )
            End If
        Next
    End Sub

    Sub DeleteGarbageMemories( pbMark As *Byte )

        Dim isAllDelete = False
        If pbMark = NULL Then
            ' すべてを破棄するとき
            isAllDelete = True
            pbMark = _System_calloc( n )
        End If

        Dim i As Long
        For i=0 To ELM(n)
            If pbMark[i]=0 and ppPtr[i]<>0 and (pdwFlags[i] and _System_GC_FLAG_NEEDFREE)=0 Then
                If ppPtr[i] = 0 Then
                    If isAllDelete Then
                        Continue
                    Else
                        debug
                    End If
                End If

                Dim ptr = ppPtr[i]
                Dim size = pSize[i]

                ppPtr[i]=0
                pSize[i]=0

                If (pdwFlags[i] and _System_GC_FLAG_OBJECT) <> 0 Then
                    /*  ・オブジェクトの個数
                        ・オブジェクトのサイズ
                        ・デストラクタの関数ポインタ
                        ・リザーブ領域
                        を考慮 */
                    _System_SweepingDelete (ptr + SizeOf( LONG_PTR ) * 4 )
                Else
                    HeapFree(_System_hProcessHeap,0,ptr)
                End If

                iAllSize-=size
            End If
        Next

        If isAllDelete Then
            _System_free( pbMark )
        End If

    End Sub

    Sub DeleteAllGarbageMemories()
        DeleteGarbageMemories( NULL )
    End Sub

    Sub Compaction()
        Dim i As Long, i2 = 0 As Long
        For i=0 To ELM(n)
            ppPtr[i2] = ppPtr[i]
            pSize[i2] = pSize[i]
            pdwFlags[i2] = pdwFlags[i]

            If ppPtr[i] Then
                i2++
            End If
        Next
        n = i2
    End Sub

    ' スウィープ（新規スレッドで呼び出し）
    Function SweepOnOtherThread() As Long
        EnterCriticalSection(CriticalSection)


        Dim startTime = GetTickCount()

        _System_DebugOnly_OutputDebugString( Ex"garbage colletion sweep start!\r\n" )


        If isSweeping <> False or (iAllSize<limitMemorySize and n<limitMemoryObjectNum) Then
            ExitThread(0)
        End If
        isSweeping = True

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

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

        ' グローバル領域をルートに指定してスキャン
        Dim i As Long
        For i = 0 To ELM( globalRootNum )
            Scan( pGlobalRoots[i].ptr, pGlobalRoots[i].count, pbMark )
        Next

        ' ローカル領域をルートに指定してスキャン
        LocalScan( pbMark )

        ' スウィープ前のメモリサイズを退避
        Dim iBackAllSize = iAllSize

        ' スウィープ前のメモリオブジェクトの数
        Dim iBeforeN = n

        '使われていないメモリを解放する
        DeleteGarbageMemories(pbMark)

        'コンパクション
        Compaction()

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

        If iBackAllSize=iAllSize 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,n, 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

    ' 未解放のメモリオブジェクトをトレース
    Sub DumpMemoryLeaks()
        Dim isLeak = False
        Dim i As Long
        For i=0 To ELM(n)
            If ppPtr[i] Then
                If (pdwFlags[i] 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" )
                    wsprintf(temp,Ex"{%d} normal block at &H%08X, %d bytes long.\r\n", i, ppPtr[i], pSize[i])
                    _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->sweep()

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

Function GC_malloc_atomic(size As Long) As VoidPtr
    ' sweep
    _System_pGC->sweep()

    '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->sweep()

    '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->sweep()

    'allocate
    Return _System_pGC->__malloc(size,_System_GC_FLAG_OBJECT or _System_GC_FLAG_INITZERO or _System_GC_FLAG_NEEDFREE)
End Function

Function _System_GC_free_for_SweepingDelete( ptr As *Object )
    ' free
    _System_pGC->__free_ex( ptr, True )
End Function