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