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


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