/*
	このファイルでは、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

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

	isFinish As Boolean

Public

	' 特殊クラスのため、コンストラクタ・デストラクタは呼ばれません
	Sub _System_CGarbageCollection()
	End Sub
	Sub ~_System_CGarbageCollection()
	End Sub

	Sub Begin()
		If ppPtr Then Exit Sub

		isFinish = False

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

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

		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(VarPtr( 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()

		OutputDebugString( Ex"garbage colletion sweeping all memory objects!\r\n" )
		DeleteAllGarbageMemories()

		' 未解放のメモリオブジェクトをトレース
		DumpMemoryLeaks()

		' 自分以外のスレッドを再開
		'_System_pobj_AllThreads->ResumeAnotherThread()

		HeapFree(_System_hProcessHeap,0,ppPtr)
		ppPtr=0

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

		'クリティカルセッションを破棄
		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
							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()
		EnterCriticalSection(CriticalSection)
			If iAllSize<limitMemorySize Then
				'メモリ使用量が上限値を超えていないとき
				LeaveCriticalSection(CriticalSection)
				Exit Sub
			End If

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

			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

Private

	' 生存検知
	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, pbMark As *Byte)
		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 (pdwFlags[index] and _System_GC_FLAG_ATOMIC)=0 Then
						'ヒープ領域がポインタ値を含む可能性があるとき
						If ppPtr[index] = 0 Then
							'エラー

						End If
						Scan(ppPtr[index] As *LONG_PTR,pSize[index],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
					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)

				If NowSp = 0 Then
					debug
					Exit Sub
				End If

				Scan( NowSp, size, 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 ) * 3 )
				Else
					iAllSize-=size
					HeapFree(_System_hProcessHeap,0,ptr)
				End If
			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 Cdecl SweepOnOtherThread() As Long

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

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

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

		' ローカル領域をルートに指定してスキャン
		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

			OutputDebugString( Ex"memory size is extended for gc!\r\n" )
		End If

		Dim temp[100] As Char
		wsprintf(temp,Ex"object items         ... %d -> %d  ( %dMB -> %dMB )\r\n",iBeforeN,n, iBackAllSize\1024\1024, iAllSize\1024\1024)
		OutputDebugString( temp )
		wsprintf(temp,Ex"limit size of memory ... %d\r\n",limitMemorySize)
		OutputDebugString( temp )
		OutputDebugString( Ex"garbage colletion sweep finish!\r\n" )


		'-------------------------------------
		' すべてのスレッドを再開
		'-------------------------------------
		_System_pobj_AllThreads->ResumeAllThread()
	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
						OutputDebugString( Ex"Detected memory leaks!\r\n" )
						isLeak = True
					End If

					Dim temp[100] As Char
					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])
					OutputDebugString( temp )
				End If
			End If
		Next

		If isLeak Then
			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