Faster VB6 / VBA class deallocation

Question

For latest additions, see Edit sections at the bottom of this question.

VB6 / VBA is slow to deallocate class instances

VB* class instance deallocation becomes exponentially slower the more instances of that particular class there are.

Quick test. You will need:

• Guido's excellent AccurateTimer library
• a class module Class1 with no code
• the following code in a standard .bas module

Run TestDeallocSpeed1 method.

Option Explicit
Sub TestDeallocSpeed1()
 Dim i As Long
 Dim n As Long
 Dim cInit As Currency
 Dim cDestroy As Currency
 Dim arr() As Class1
 Const alignR As Long = 14
 '
 Debug.Print AlignRight(alignR, "Instances", "Init (uS)", "Destroy (uS)")
 n = 3
 Do
 'Init
 ReDim arr(1 To n)
 cInit = AccurateTimerUs()
 For i = 1 To n
 Set arr(i) = New Class1
 Next i
 cInit = AccurateTimerUs() - cInit
 '
 'Destroy
 cDestroy = AccurateTimerUs()
 Erase arr
 cDestroy = AccurateTimerUs() - cDestroy
 '
 Debug.Print AlignRight(alignR, n, cInit, cDestroy)
 n = n * 1.2
 Loop Until n > 2 ^ 20
End Sub
Private Function AlignRight(ByVal size As Long, ParamArray args() As Variant) As String
 Dim v As Variant
 Dim res As String
 Dim arg As String
 Dim lBuf As String: lBuf = Space$(size)
 '
 For Each v In args
 If IsNumeric(v) Then arg = Format$(v, "#,##0") Else arg = v
 arg = Right$(lBuf & arg, size)
 res = res & arg
 Next v
 AlignRight = res
End Function

The results will be printed to your Immediate window. Here are the results on my x64 VBA7 Windows, shown on a chart:

chart1

Creating almost 950,000 instances takes around 0.6 seconds while destroying them takes 185 seconds. Ridiculous.

Please note that this only applies to custom class modules. Destroying instances created in DLL references is fast, e.g. the native Collection from VBE7.DLL

Why is deallocation slow

Olaf Schmidt has done some investigation on this issue in the past. The following posts were really helpful:

• Clearing-array-is-fast-in-VB5-but-very-slow-in-VB6
• destroying-classes

Many thanks to Olaf. His work has put me on the right path to figure out why this is happening.

Apparently, each class instance holds a pointer to the previous instance immediately after the virtual table pointer i.e. at address ObjPtr(instance) + PTR_SIZE where PTR_SIZE is 4 (x32) or 8 (x64) bytes. We will explore the VB* class footprint later below to gain more clarity.

There are some assumptions being made in those posts. Here are the most important ones:

• VB* must hold a pointer to the last created instance
• when VB* destroys a class instance, it traverses all instances starting from the last created instance all the way to the first
• the speed issue is probably caused by te registration / deregistration calls to IConnectionPoint interface while traversing the linked list of instance pointers
• it's a possibility that the list of instance pointers is double-linked

After extensive testing, it turns out that only the first two assumptions are correct. I've discovered the following:

• VB* does hold a pointer to the last instance
• traversal indeed always goes from last instance to first
• list of instance pointers is single-linked i.e. instances only "know" what the previous instance is but not the next
• event deregistration does not affect speed
• instances are often only partially destroyed, so that the class footprint memory space is reused
• there is a second list of pointers but only for the partially destroyed instances. The pointers for this can be found at address ObjPtr(instance) i.e. where the vTable pointer was before termination. More details on this later below
• each traversal can deallocate (free up memory) for none, one or more partially deallocated instances

In other words, the speed degradation cause is the following: while traversing, VB also deallocates instances that have nothing to do with the one currently being terminated. This is because instances can be partially destroyed. All the checks involved are presumably done for each instance being traversed thus exponentially taking longer. Demonstration further below.

Please note that throughout this explanation, the word Terminated refers to a Partial Deallocation.

VB* Class Footprint

We must first understand the layout of a class instance. Olaf's findings were really close:

Public Type VBClassHeader '64Bytes for a naked Class -> 16 32Bit Members
 pVTable As Long 
 pPreviousInstanceSameType As Long '<- here's the most interesting one 
 pUnkInstance As Long 'always denoting with 28Bytes Offs to our own ObjInstance-Ptr 
 pInstanceBaseClass As Long 'sidewards-allocation (extra memory) 
 pInstanceIConnectionPoint As Long 'sidewards-allocation (extra memory)
 YetToFindOut1 As Long 'usually at Zero 
 YetToFindOut2 As Long 'usually at Zero 
 pUnkVTable As Long 'the 7'th member after pVTable (= our 28Bytes Offs) 
 lRefCount As Long 
 lDataSourceBehaviourFlag As Long 
 YetToFindOut3 As Long 'usually at Zero 
 StateFlag As Long 'usually at &H100F, but at &H1C6E when terminating 
 YetToFindOut4 As Long 'usually at Zero 
'-> ...Class-private Vars will be inserted here, shifting the IClassModuleEvt-vTable down
 pVTableIClassModuleEvt As Long 
 YetToFindOut5 As Long 'usually at Zero 
 YetToFindOut6 As Long 'usually at Zero 
End Type

There are a few differences I found during testing:

• pInstanceIConnectionPoint is in fact a pointer to an array of virtual function tables
• pInstanceBaseClass is in fact pointing to the last virtual table in the array mentioned above
• in between the class private vars and pVTableIClassModuleEvt there will be pointers to interfaces being implemented or interfaces created for vars WithEvents, if any
• YetToFindOut5 is a pointer to where the Static class variables are stored i.e. the ones declared inside the class methods, if any

Let's update the names and make it x64 compatible. The members are prefixed with alphabet letters so that when viewed in the Locals window, while debugging, we can see them in the correct order.

Public Type VBClass
 a_VTableOrPrevTerm As LongPtr 'While Active, points to the class main virtual table (derived from IDispatch)
 'After termination, points to the previous terminated instance
 b_PreviousInstance As LongPtr 'Points to the previous created instance of the same class type. This can be a terminated instance
 c_IUnknownPtr As LongPtr 'Points to h_IUnknown virtual table i.e. offset 52 (x64) or 28 (x32) from instance pointer
 d_BaseClass As LongPtr 'Points to last vTable in array pointed by e_VBClassVTables i.e. e_VBClassVTables + PTR_SIZE * 6
 e_VBClassVTables As LongPtr 'Points to an array of virtual tables - see VBClassVTables struct below
 f_YetToFindOut1 As LongPtr '0
 g_YetToFindOut2 As LongPtr '0
 h_IUnknown As LongPtr 'Points to the class IUnknown virtual table
 i_RefCount As Long 'Instance reference count
 j_DataSourceBehaviourFlag As Long 'Seems to be 0 in VBA - don't have VB6 to test with
 k_YetToFindOut3 As Long '0
 l_StateFlag As Long 'Initializing = &H1007 (while within Class_Initialize)
 'Active = &H100F,
 'Releasing = &H1057 (while within IUnknown::Release),
 'ReleasingLost = &H1867 (while within Release but state lost),
 'Terminating = &H1807 (while within Class_Terminate),
 'Terminated = &H1C6E (not destroyed)
 m_YetToFindOut4 As LongPtr '0
 n_YetToFindOut5 As LongPtr '0
 '
 'Class-private Variables will be inserted here, shifting the IClassModuleEvt-vTable down, if any
 '
 'Class implemented interfaces (virtual tables pointers) will be inserted here, if any
 'Interfaces created by VB automatically, when there are WithEvents variables declared, will be inserted here, if any
 '
 o_IClassModuleEvt As LongPtr 'Points to the class IClassModuleEvt virtual table
 p_StaticVars As LongPtr 'If any, a call to Win API like GlobalSize or LocalSize will return the byte size being used
 q_YetToFindOut6 As LongPtr '0
End Type
Public Type VBClassVTables
 a_SomeVTable1 As LongPtr
 b_IConnectionPoint As LongPtr
 c_IConnectionPointCointainer As LongPtr
 d_SomeVTable2 As LongPtr
 e_SomeVTable3 As LongPtr
 f_IMarshall As LongPtr
 g_BaseClass As LongPtr
End Type

A quick test, run TestClassFootprint:

Option Explicit
#If Mac Then
 #If VBA7 Then
 Public Declare PtrSafe Function CopyMemory Lib "/usr/lib/libc.dylib" Alias "memmove" (Destination As Any, Source As Any, ByVal Length As LongPtr) As LongPtr
 #Else
 Public Declare Function CopyMemory Lib "/usr/lib/libc.dylib" Alias "memmove" (Destination As Any, Source As Any, ByVal Length As Long) As Long
 #End If
#Else
 #If VBA7 Then
 Public Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
 #Else
 Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
 #End If
#End If
#If Win64 Then
 Public Const PTR_SIZE As Long = 8
 Public Const NULL_PTR As LongLong = 0^
#Else
 Public Const PTR_SIZE As Long = 4
 Public Const NULL_PTR As Long = 0&
#End If
#If VBA7 = 0 Then
 Public Enum LongPtr
 [_]
 End Enum
#End If
Public Function MemLongPtr(ByVal addr As LongPtr) As LongPtr
 CopyMemory MemLongPtr, ByVal addr, PTR_SIZE
End Function
Sub TestClassFootprint()
 Dim vc As VBClass
 Dim vct As VBClassVTables
 Dim temp As Class1
 Dim c As Class1
 '
 Set temp = New Class1
 Set c = New Class1
 '
 CopyMemory vc, ByVal ObjPtr(c), LenB(vc)
 CopyMemory vct, ByVal vc.e_VBClassVTables, LenB(vct)
 '
 Debug.Assert MemLongPtr(vc.d_BaseClass) = vct.g_BaseClass
 Debug.Assert vc.b_PreviousInstance = ObjPtr(temp)
 Debug.Assert MemLongPtr(vc.c_IUnknownPtr) = vc.h_IUnknown
 '
 Stop
End Sub

Looks like this:

footprint

VB* can partially destroy instances

These are, roughly, the steps that VB* takes when terminating a class instance:

• IUnknown::Release is called as a result of:
  • user manually set the object variable to Nothing
  • object variable went out of scope
  • state was lost
• if the reference count is bigger than 1, then it gets decreased and nothing else happens
• if the reference count is 1 (i_RefCount), meaning it will be zero after decreasing, state is set to 'Terminated' (&H1C6E) at offset 76 (x64) / 44 (x32) bytes (l_StateFlag)
• _Terminate is called on the IClassModuleEvt interface and so Class_Terminate is called, if present. However, if state was lost (e.g. End ran or Stop was pressed in the VBE) then Class_Terminate is not called
• static variables are cleared - p_StaticVars points to where these are stored
• internal variables are cleared, if not already cleared by bespoke code in Class_Terminate
• pointers are cleared for (see class footprint in previous section):
  • a_VTableOrPrevTerm
  • d_BaseClass
  • e_VBClassVTables - the array pointed by this is also deallocated
• the class footprint is never deallocated for the instance being terminated
• VB traveses the list of instance pointers and might deallocate the class footprint for previously terminated instances, depending how many there are - again, these are held to be reused and presumably to avoid deallocate >> reallocate if unnecessary
• VB will update the a_VTableOrPrevTerm to point to the previous terminated (but not deallocated) instance. If there are no previously terminated instances or if they were deallocated, then a_VTableOrPrevTerm will be set to zero / null ptr
• VB will update the b_PreviousInstance pointers in case any previously terminated instances were deallocated

To test this, you must use Excel as it is important to see the results while code stops on the Stop lines. Keep the VBE and Excel windows side by side. Add this code to a standard module and run TestDealloc (press F5 key to jump to the next Stop):

Option Explicit
Sub TestDealloc()
 Dim i As Long
 Dim coll As New Collection
 Const n As Long = 30
 Dim c(1 To n) As Class1
 Dim ptrs(1 To n) As LongPtr
 '
 For i = 1 To n
 Set c(i) = New Class1
 ptrs(i) = ObjPtr(c(i))
 coll.Add i, CStr(ptrs(i))
 Next i
 coll.Add "vTblPtr", CStr(MemLongPtr(ObjPtr(c(1))))
 coll.Add "n/a", CStr(0)
 '
 WriteTraversal coll, ptrs(n) 'Start from last pointer
 Stop
 '
 For i = 1 To n
 If i Mod 7 = 0 Then
 Set c(i) = Nothing
 WriteTraversal coll, ptrs(n)
 Stop
 End If
 Next i
 For i = 1 To n
 If i Mod 7 <> 0 Then
 Set c(i) = Nothing
 WriteTraversal coll, ptrs(n)
 Stop
 End If
 Next i
 For i = 1 To 4
 Set c(i) = New Class1
 WriteTraversal coll, ptrs(n)
 Stop
 Next i
 Erase c
 WriteTraversal coll, ptrs(n)
 Stop
End Sub
Sub WriteTraversal(ByVal coll As Collection, ByVal lastPtr As LongPtr)
 Dim res As New Collection
 Dim ptr As LongPtr: ptr = lastPtr
 Dim v As Variant
 '
 Do 'Traverse the linked list of instance pointers
 res.Add coll(CStr(ptr))
 res.Add coll(CStr(MemLongPtr(ptr))) 'vTbl or previously terminated
 ptr = MemLongPtr(ptr + PTR_SIZE) 'Previous instance
 res.Add coll(CStr(ptr))
 Loop Until ptr = NULL_PTR
 '
 Dim i As Long
 Dim j As Long
 Const c As Long = 3
 Dim r As Long: r = res.Count / c
 Dim arr() As Variant: ReDim arr(1 To r, 1 To c)
 '
 i = r
 For Each v In res
 j = j + 1
 arr(i, j) = v
 If j = c Then
 j = 0
 i = i - 1
 End If
 Next v
 '
 With Range("A1")
 .Resize(1, 3).Value2 = Array("Instance #" _
 , "VTbl or prevTerminated" _
 , "Prev instance")
 With .Offset(1, 0)
 .Resize(.End(xlDown).Row - .Row + 1, c).Value2 = Empty
 .Resize(r, c).Value2 = arr
 End With
 End With
End Sub

Please note that I chose to use the index of the instance (in the creation order) instead of using pointers, to make it easier to follow what is going on.

The above code illustrates how previously terminated instances are reused and how deallocation works. Here's a gif:

gif

Pelase note that I did not share code used to test and prove some of the points mentioned here (e.g. how e_VBClassVTables is deallocated or how l_StateFlag is changed). This is because it would bloat this question and it's irrelevant to the following section.

The above code/gif only runs a simple demonstation but in reality, while instances are terminated and reused, the order of those pointers can point in both directions e.g. instance 17 points to instance 16 at PTR_SIZE offset while pointing to instance 50 at zero offset because both 17 and 50 are partially deallocated.

Overcome VB design - Faster Instance Deallocation

My goal was to make VBA-FastDictionary faster, which is a must for working with JSON. JSON that took 8 seconds to parse was taking hundreds of seconds to deallocate, but with this and eventually this, the deallocation is now under a second.

The problem with VBA7 is that it has a massive API overhead - see this Code Review question. If we want to keep all code inside the relevant class, then we must copy memory using something native. I am using fake arrays which I call memory accesors but we could also use fake Variant ByRef (see VBA-MemoryTools for both approaches).

For now, this is the code needed to fix the problem for our example Class1 but see the next section for other thoughts and ideas. Please note we need the global instance i.e. Attribute VB_PredeclaredId = True. So, place the below code in a Class1.cls text file and then import that file:

VERSION 1.0 CLASS
BEGIN
 MultiUse = -1 'True
END
Attribute VB_Name = "Class1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'@PredeclaredId
Option Explicit
#If Mac Then
 #If VBA7 Then
 Private Declare PtrSafe Function CopyMemory Lib "/usr/lib/libc.dylib" Alias "memmove" (Destination As Any, Source As Any, ByVal Length As LongPtr) As LongPtr
 #Else
 Private Declare Function CopyMemory Lib "/usr/lib/libc.dylib" Alias "memmove" (Destination As Any, Source As Any, ByVal Length As Long) As Long
 #End If
#Else 'Windows
 #If VBA7 Then
 Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
 #Else
 Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
 #End If
#End If
#If VBA7 = 0 Then
 Private Enum LongPtr
 [_]
 End Enum
#End If
#Const Windows = (Mac = 0)
#Const x64 = Win64
 
Private Enum InternalConstants 'Hides constants from Locals window
#If x64 Then
 ptrSize = 8
#Else
 ptrSize = 4
#End If
 prevOffset = ptrSize 'Previous instance pointer immediately after vTable
End Enum
Private Type SAFEARRAYBOUND
 cElements As Long
 lLbound As Long
End Type
Private Type SAFEARRAY_1D
 cDims As Integer
 fFeatures As Integer
 cbElements As Long
 cLocks As Long
 pvData As LongPtr
 rgsabound0 As SAFEARRAYBOUND
End Type
 
'Data shared across all class instances
Private Type Globals
 saP As SAFEARRAY_1D
 d As Double 'A safe pointer
 dPtr As LongPtr
 lastInstancePtr As LongPtr
 lastTerminatedPtr As LongPtr
 lastTerminatedNextPtr As LongPtr
 nextPtrOffset As LongPtr
 defPtrOffset As LongPtr
End Type
'These will link into the default (Predeclared) instance of this class
Private Type MemoryAccessors
 Common() As Globals
 RPtr() As LongPtr
End Type
Private Type DeallocVars
 ThisPtr As LongPtr
 NextClassPtr As LongPtr
End Type
Private Type ClassVariables
 DefInstance As Class1 'Avoids deallocation of default (Predeclared) instance
 Dealloc As DeallocVars
End Type
'Class members
Private Vars As ClassVariables
Private Mem As MemoryAccessors
Private Sub InitSafeArray(ByRef sa As SAFEARRAY_1D, ByVal elemSize As Long)
 Const FADF_AUTO As Long = &H1
 Const FADF_FIXEDSIZE As Long = &H10
 Const FADF_COMBINED As Long = FADF_AUTO Or FADF_FIXEDSIZE
 With sa
 .cDims = 1
 .fFeatures = FADF_COMBINED
 .cbElements = elemSize
 .cLocks = 1
 End With
End Sub
'To avoid API calls overhead memory accessors are cached in the default instance
' (Attribute VB_PredeclaredId = True)
Friend Sub InitStructs(ByRef v As ClassVariables _
 , ByRef m As MemoryAccessors)
 #If x64 Then
 Const nullPtr As LongLong = 0^
 #Else
 Const nullPtr As Long = 0&
 #End If
 Static h As Globals
 Static saH As SAFEARRAY_1D
 Static saPtrs(0 To 1) As LongPtr
 Dim temp As Object
 '
 If Not Vars.DefInstance Is Nothing Then
 Vars.DefInstance.InitStructs v, m
 Exit Sub
 End If
 '
 If saH.cDims = 0 Then
 h.nextPtrOffset = VarPtr(Vars.Dealloc.NextClassPtr) - Vars.Dealloc.ThisPtr
 h.defPtrOffset = VarPtr(Vars.DefInstance) - Vars.Dealloc.ThisPtr
 '
 saPtrs(0) = VarPtr(saH)
 saPtrs(1) = VarPtr(h.saP)
 '
 InitSafeArray saH, LenB(h)
 InitSafeArray h.saP, ptrSize
 '
 saH.pvData = VarPtr(h)
 h.dPtr = VarPtr(h.d)
 h.saP.pvData = h.dPtr
 '
 saH.rgsabound0.cElements = 1
 h.saP.rgsabound0.cElements = 1
 '
 'The only API call
 CopyMemory ByVal VarPtr(Mem) + ptrSize, saPtrs(1), ptrSize
 End If
 '
 'Avoid deallocation of Global Instance
 If v.Dealloc.ThisPtr <> Vars.Dealloc.ThisPtr Then Set v.DefInstance = Me
 '
 'Init memory accesors for each instance
 h.saP.pvData = VarPtr(m)
 Mem.RPtr(0) = saPtrs(0)
 h.saP.pvData = h.saP.pvData + ptrSize
 Mem.RPtr(0) = saPtrs(1)
 '
 'Read previous instance pointer
 h.saP.pvData = v.Dealloc.ThisPtr + prevOffset
 '
 Dim prevPtr As LongPtr: prevPtr = Mem.RPtr(0)
 Dim tempPtr As LongPtr
 '
 If prevPtr = nullPtr Then 'Can only be def instance
 h.lastInstancePtr = v.Dealloc.ThisPtr
 h.saP.pvData = h.dPtr
 Exit Sub
 End If
 '
 'In case user modified the global instance e.g. Set Class1 = Nothing
 If v.DefInstance Is Nothing Then
 Do
 h.saP.pvData = prevPtr + h.defPtrOffset
 tempPtr = Mem.RPtr(0)
 If tempPtr Then Exit Do
 '
 h.saP.pvData = prevPtr + prevOffset
 If Mem.RPtr(0) = nullPtr Then
 h.saP.pvData = prevPtr + h.nextPtrOffset
 If Mem.RPtr(0) Then tempPtr = prevPtr
 Exit Do
 End If
 prevPtr = Mem.RPtr(0)
 Loop
 If (tempPtr <> nullPtr) And (tempPtr <> Vars.Dealloc.ThisPtr) Then
 'Link to the 'real' def instance
 h.saP.pvData = VarPtr(temp)
 Mem.RPtr(0) = tempPtr 'Unmanaged - ref count not increased
 Set Vars.DefInstance = temp
 Mem.RPtr(0) = nullPtr 'Ref count not decreased
 '
 Vars.DefInstance.InitStructs Vars, Mem
 With Mem.Common(0)
 .saP.pvData = .lastTerminatedPtr + prevOffset
 If Mem.RPtr(0) = v.Dealloc.ThisPtr Then
 'Previous instance is currently initializing and it is
 ' definitely reusing previously terminated memory
 v.Dealloc.NextClassPtr = .lastTerminatedPtr
 .saP.pvData = .lastTerminatedPtr + .nextPtrOffset
 Mem.RPtr(0) = .lastTerminatedNextPtr
 .lastTerminatedNextPtr = v.Dealloc.ThisPtr
 .saP.pvData = v.Dealloc.ThisPtr + prevOffset
 .lastTerminatedPtr = Mem.RPtr(0)
 End If
 .saP.pvData = .dPtr
 End With
 Exit Sub
 End If
 End If
 '
 If v.Dealloc.ThisPtr = h.lastTerminatedPtr Then
 'Reusing previously terminated memory
 v.Dealloc.NextClassPtr = h.lastTerminatedNextPtr
 h.lastTerminatedPtr = prevPtr
 h.lastTerminatedNextPtr = v.Dealloc.ThisPtr
 Else
 If prevPtr = h.lastInstancePtr Then
 h.lastInstancePtr = v.Dealloc.ThisPtr
 Else 'The previous instance could be initializing
 h.saP.pvData = prevPtr + prevOffset
 If Mem.RPtr(0) = h.lastInstancePtr Then
 h.lastInstancePtr = v.Dealloc.ThisPtr
 End If
 End If
 End If
 h.saP.pvData = prevPtr + h.nextPtrOffset
 Mem.RPtr(0) = v.Dealloc.ThisPtr
 '
 h.saP.pvData = h.dPtr
End Sub
'Only initialize memory manipulation structs
Private Sub Class_Initialize()
 Vars.Dealloc.ThisPtr = ObjPtr(Me)
 Class1.InitStructs Vars, Mem
End Sub
'Postpones termination to a later stage where we have full control over how VBA
' traverses the linked list of all class instances
Private Sub Class_Terminate()
 'Deallocate internal variables here e.g. other Class1 instances
 '...
 '...
 '
 'Cache this instance inside the global instance and destroy later
 Vars.DefInstance.DelayTermination Me, Vars
 Set Vars.DefInstance = Nothing
End Sub
'When VB* terminates a class instance, it traverses all instances starting from
' the last created instance all the way to the first. On itself this would be
' fast but unfortunately VB also makes checks and can reclaim memory that is
' unrelated to the instance being terminated. So, this traversal becomes
' exponentially slower the more instances there are - O(n^2)
'This method 'tricks' VB into traversing only a handful of instances thus making
' the whole termination process linear - O(n)
Friend Sub DelayTermination(ByRef instanceToDelay As Class1 _
 , ByRef v As ClassVariables)
 #If x64 Then
 Const nullPtr As LongLong = 0^
 #Else
 Const nullPtr As Long = 0&
 #End If
 Static pendingClass As Class1
 Static pendingPtr As LongPtr
 Static lastClass As Class1
 Static lastClassPtr As LongPtr
 Dim prevPtr As LongPtr
 Dim followPtr As LongPtr
 Dim secondLastPtr As LongPtr
 Dim tempClass As Class1
 '
 If pendingClass Is Nothing Then
 Set pendingClass = instanceToDelay
 pendingPtr = v.Dealloc.ThisPtr
 Exit Sub
 End If
 With Mem.Common(0)
 If pendingPtr = .lastInstancePtr Then
 'We force keep the last instance active to avoid extra logic
 If lastClass Is Nothing Then
 Set lastClass = pendingClass
 lastClassPtr = pendingPtr
 Set pendingClass = instanceToDelay
 pendingPtr = v.Dealloc.ThisPtr
 Exit Sub
 End If
 '
 Set tempClass = lastClass
 Set lastClass = pendingClass
 Set pendingClass = tempClass
 Set tempClass = Nothing
 pendingPtr = lastClassPtr
 lastClassPtr = .lastInstancePtr
 End If
 '
 If .lastTerminatedPtr = nullPtr Then
 .lastTerminatedPtr = Vars.Dealloc.ThisPtr 'Use Def instance
 End If
 '
 .saP.pvData = pendingPtr + prevOffset
 prevPtr = Mem.RPtr(0)
 '
 If prevPtr = .lastTerminatedPtr Then
 .saP.pvData = pendingPtr + .nextPtrOffset
 followPtr = Mem.RPtr(0)
 Else 'Insert after last terminated
 Mem.RPtr(0) = .lastTerminatedPtr
 .saP.pvData = .lastTerminatedPtr + .nextPtrOffset
 '
 Dim tempPtr As LongPtr: tempPtr = Mem.RPtr(0)
 Mem.RPtr(0) = pendingPtr
 '
 .saP.pvData = tempPtr + prevOffset
 Mem.RPtr(0) = pendingPtr
 '
 .saP.pvData = pendingPtr + .nextPtrOffset
 followPtr = Mem.RPtr(0)
 Mem.RPtr(0) = tempPtr
 '
 If prevPtr <> nullPtr Then 'Not first ever instance
 .saP.pvData = prevPtr + .nextPtrOffset
 Mem.RPtr(0) = followPtr
 End If
 '
 .saP.pvData = followPtr + prevOffset
 Mem.RPtr(0) = prevPtr
 followPtr = tempPtr
 End If
 '
 'Make VB 'believe' that trailing instance is the last instance
 ' so that a shorter list is traversed when we terminate 'pending'
 .saP.pvData = .lastInstancePtr + prevOffset
 secondLastPtr = Mem.RPtr(0)
 Mem.RPtr(0) = pendingPtr
 '
 Set pendingClass = Nothing 'Traverse short list and deallocate as needed
 '
 Mem.RPtr(0) = secondLastPtr 'Restore to long list
 '
 .saP.pvData = pendingPtr + prevOffset
 If .lastTerminatedPtr <> Mem.RPtr(0) Then 'Memory was reclaimed
 .saP.pvData = Mem.RPtr(0) + .nextPtrOffset
 Mem.RPtr(0) = pendingPtr
 End If
 .lastTerminatedPtr = pendingPtr
 .lastTerminatedNextPtr = followPtr
 .saP.pvData = .dPtr
 '
 Set pendingClass = instanceToDelay
 pendingPtr = v.Dealloc.ThisPtr
 End With
End Sub

Now run again the TestDeallocSpeed1 method that we initially ran on Class1 when it had no code. This is the new result:

chart2

So, destroying 950,000 instances used to take 185 seconds but it is now done in 0.67 seconds. This is how things should be - destroy should be faster than create.

Other approaches and ideas

Needless to say, reaching the above result took literally months and I explored and implemented several approaches. I won't go into details on them but I will share some thoughts on the current approach and some ideas to expand the solution.

I chose to implement all code inside the relevant class as I wanted to have a self-contained solution, which was always the goal for a single-class library like VBA-FastDictionary. You probably realized that the Class1 solution above is just a stripped down version of the dictionary class.

However, all this could be done using a standard .bas module that could handle all the memory manipulation to overcome the API overhead and it could be written to support multiple classes. For example, all classes would pass themselves to a global method which would then keep track of the necessary pointers per each class type. The code would be quite complicated, but definitely doable. While this would be a great fit-all solution it would introduce a necessary dependency on that standard module.

Alternatively, we could have the memory manipulation inside a standard module while still keeping track of the pointers inside each class. Easier to implement but still with dependency.

Current approach

For those who don't have the time to understand what the code does. Here are the main ideas:

• we keep track of the next instance pointer in each instance while we let VB* keep track of the previous instance
• we keep track of the last instance ever created which VB also does. This is slightly tricky because the user can terminate the global instance and so we have to maintain a default instance that coordinates everything and stores such "global" pointers
• we never deallocate the last instance. This greatly simplifies the logic needed and is much faster. This implies that we always have at least 2 active instances: the default and the last. These will only be deallocated when state is lost / application quits
• when the Class_Terminate method is called, we simply store the instance as pending so that we get outside the scope of Class_Terminate. In other words, we delay termination. While this is going on, we can terminate the previously pending instance, if any
• when we terminate a pending instance, we make sure to trick VB* into traversing a shorter list of instances. To do that, we make sure we insert the pending instance immediately after the previously terminated (or the default one). This could require up to 6 pointer swaps to make sure we maintain our now double-linked list. Once inserted, we link the very last created instance directly to our pending instance, meaning VB* will skip traversing anything in between. At this step, VB* might deallocate one or more previously terminated instances (which we've maintained in order by doing the swaps) but will never deallocate the one pending
• once terminated, we restore the list to it's full length so that VB can properly deallocate in case of state loss

Question

Can this approach be improved?

Any other feedback or suggestions are welcome.

Edit 6-Jan-2025

Although somewhat slower, the following refactored Class1 isolates the memory copy operations into the MemLongPtr properties:

VERSION 1.0 CLASS
BEGIN
 MultiUse = -1 'True
END
Attribute VB_Name = "Class1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'@PredeclaredId
Option Explicit
#If Mac Then
 #If VBA7 Then
 Private Declare PtrSafe Function CopyMemory Lib "/usr/lib/libc.dylib" Alias "memmove" (Destination As Any, Source As Any, ByVal Length As LongPtr) As LongPtr
 #Else
 Private Declare Function CopyMemory Lib "/usr/lib/libc.dylib" Alias "memmove" (Destination As Any, Source As Any, ByVal Length As Long) As Long
 #End If
#Else 'Windows
 #If VBA7 Then
 Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
 #Else
 Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
 #End If
#End If
#If VBA7 = 0 Then
 Private Enum LongPtr
 [_]
 End Enum
#End If
#Const Windows = (Mac = 0)
#Const x64 = Win64
 
Private Enum InternalConstants 'Hides constants from Locals window
#If x64 Then
 ptrSize = 8
#Else
 ptrSize = 4
#End If
 prevOffset = ptrSize 'Previous instance pointer immediately after vTable
End Enum
Private Type SAFEARRAYBOUND
 cElements As Long
 lLbound As Long
End Type
Private Type SAFEARRAY_1D
 cDims As Integer
 fFeatures As Integer
 cbElements As Long
 cLocks As Long
 pvData As LongPtr
 rgsabound0 As SAFEARRAYBOUND
End Type
 
'Data shared across all class instances
Private Type Globals
 saP As SAFEARRAY_1D
 d As Double 'A safe pointer
 dPtr As LongPtr
 lastInstancePtr As LongPtr
 lastTerminatedPtr As LongPtr
 lastTerminatedNextPtr As LongPtr
 nextPtrOffset As LongPtr
 defPtrOffset As LongPtr
End Type
'These will link into the default (Predeclared) instance of this class
Private Type MemoryAccessors
 Common() As Globals
 RPtr() As LongPtr
End Type
Private Type DeallocVars
 ThisPtr As LongPtr
 NextClassPtr As LongPtr
End Type
Private Type ClassVariables
 DefInstance As Class1 'Avoids deallocation of default (Predeclared) instance
 Dealloc As DeallocVars
End Type
'Class members
Private Vars As ClassVariables
Private Mem As MemoryAccessors
Private Property Get MemLongPtr(ByVal addr As LongPtr) As LongPtr
 With Mem.Common(0)
 .saP.pvData = addr
 MemLongPtr = Mem.RPtr(0)
 .saP.pvData = .dPtr
 End With
End Property
Private Property Let MemLongPtr(ByVal addr As LongPtr, ByVal newValue As LongPtr)
 With Mem.Common(0)
 .saP.pvData = addr
 Mem.RPtr(0) = newValue
 .saP.pvData = .dPtr
 End With
End Property
Private Sub InitSafeArray(ByRef sa As SAFEARRAY_1D, ByVal elemSize As Long)
 Const FADF_AUTO As Long = &H1
 Const FADF_FIXEDSIZE As Long = &H10
 Const FADF_COMBINED As Long = FADF_AUTO Or FADF_FIXEDSIZE
 With sa
 .cDims = 1
 .fFeatures = FADF_COMBINED
 .cbElements = elemSize
 .cLocks = 1
 End With
End Sub
'To avoid API calls overhead memory accessors are cached in the default instance
' (Attribute VB_PredeclaredId = True)
Friend Sub InitStructs(ByRef v As ClassVariables _
 , ByRef m As MemoryAccessors)
 #If x64 Then
 Const nullPtr As LongLong = 0^
 #Else
 Const nullPtr As Long = 0&
 #End If
 Static h As Globals
 Static saH As SAFEARRAY_1D
 Static saPtrs(0 To 1) As LongPtr
 Dim temp As Object
 '
 If Not Vars.DefInstance Is Nothing Then
 Vars.DefInstance.InitStructs v, m
 Exit Sub
 End If
 '
 If saH.cDims = 0 Then
 h.nextPtrOffset = VarPtr(Vars.Dealloc.NextClassPtr) - Vars.Dealloc.ThisPtr
 h.defPtrOffset = VarPtr(Vars.DefInstance) - Vars.Dealloc.ThisPtr
 '
 saPtrs(0) = VarPtr(saH)
 saPtrs(1) = VarPtr(h.saP)
 '
 InitSafeArray saH, LenB(h)
 InitSafeArray h.saP, ptrSize
 '
 saH.pvData = VarPtr(h)
 h.dPtr = VarPtr(h.d)
 h.saP.pvData = h.dPtr
 '
 saH.rgsabound0.cElements = 1
 h.saP.rgsabound0.cElements = 1
 '
 'The only API call
 CopyMemory ByVal VarPtr(Mem) + ptrSize, saPtrs(1), ptrSize
 End If
 '
 'Avoid deallocation of Global Instance
 If v.Dealloc.ThisPtr <> Vars.Dealloc.ThisPtr Then Set v.DefInstance = Me
 '
 'Init memory accesors for each instance
 h.saP.pvData = VarPtr(m)
 Mem.RPtr(0) = saPtrs(0)
 h.saP.pvData = h.saP.pvData + ptrSize
 Mem.RPtr(0) = saPtrs(1)
 '
 'Read previous instance pointer
 '
 Dim prevPtr As LongPtr: prevPtr = MemLongPtr(v.Dealloc.ThisPtr + prevOffset)
 Dim tempPtr As LongPtr
 Dim defPtrAddr As LongPtr
 Dim nextPtrAddr As LongPtr
 '
 If prevPtr = nullPtr Then 'Can only be def instance
 h.lastInstancePtr = v.Dealloc.ThisPtr
 Exit Sub
 End If
 '
 'In case user modified the global instance e.g. Set Class1 = Nothing
 If v.DefInstance Is Nothing Then
 Do
 defPtrAddr = prevPtr + h.defPtrOffset
 tempPtr = MemLongPtr(defPtrAddr)
 If tempPtr Then Exit Do
 '
 If MemLongPtr(prevPtr + prevOffset) = nullPtr Then
 nextPtrAddr = prevPtr + h.nextPtrOffset
 If MemLongPtr(nextPtrAddr) Then tempPtr = prevPtr
 Exit Do
 End If
 prevPtr = MemLongPtr(nextPtrAddr)
 Loop
 If (tempPtr <> nullPtr) And (tempPtr <> Vars.Dealloc.ThisPtr) Then
 'Link to the 'real' def instance
 MemLongPtr(VarPtr(temp)) = tempPtr 'Unmanaged - ref count not increased
 Set Vars.DefInstance = temp
 MemLongPtr(VarPtr(temp)) = nullPtr 'Ref count not decreased
 '
 Vars.DefInstance.InitStructs Vars, Mem
 With Mem.Common(0)
 If MemLongPtr(.lastTerminatedPtr + prevOffset) = v.Dealloc.ThisPtr Then
 'Previous instance is currently initializing and it is
 ' definitely reusing previously terminated memory
 v.Dealloc.NextClassPtr = .lastTerminatedPtr
 MemLongPtr(.lastTerminatedPtr + .nextPtrOffset) = .lastTerminatedNextPtr
 .lastTerminatedNextPtr = v.Dealloc.ThisPtr
 .lastTerminatedPtr = MemLongPtr(v.Dealloc.ThisPtr + prevOffset)
 End If
 End With
 Exit Sub
 End If
 End If
 '
 If v.Dealloc.ThisPtr = h.lastTerminatedPtr Then
 'Reusing previously terminated memory
 v.Dealloc.NextClassPtr = h.lastTerminatedNextPtr
 h.lastTerminatedPtr = prevPtr
 h.lastTerminatedNextPtr = v.Dealloc.ThisPtr
 Else
 If prevPtr = h.lastInstancePtr Then
 h.lastInstancePtr = v.Dealloc.ThisPtr
 Else 'The previous instance could be initializing
 If MemLongPtr(prevPtr + prevOffset) = h.lastInstancePtr Then
 h.lastInstancePtr = v.Dealloc.ThisPtr
 End If
 End If
 End If
 MemLongPtr(prevPtr + h.nextPtrOffset) = v.Dealloc.ThisPtr
End Sub
'Only initialize memory manipulation structs
Private Sub Class_Initialize()
 Vars.Dealloc.ThisPtr = ObjPtr(Me)
 Class1.InitStructs Vars, Mem
End Sub
'Postpones termination to a later stage where we have full control over how VBA
' traverses the linked list of all class instances
Private Sub Class_Terminate()
 'Deallocate internal variables here e.g. other Class1 instances
 '...
 '...
 '
 'Cache this instance inside the global instance and destroy later
 Vars.DefInstance.DelayTermination Me, Vars
 Set Vars.DefInstance = Nothing
End Sub
'When VB* terminates a class instance, it traverses all instances starting from
' the last created instance all the way to the first. On itself this would be
' fast but unfortunately VB also makes checks and can reclaim memory that is
' unrelated to the instance being terminated. So, this traversal becomes
' exponentially slower the more instances there are - O(n^2)
'This method 'tricks' VB into traversing only a handful of instances thus making
' the whole termination process linear - O(n)
Friend Sub DelayTermination(ByRef instanceToDelay As Class1 _
 , ByRef v As ClassVariables)
 #If x64 Then
 Const nullPtr As LongLong = 0^
 #Else
 Const nullPtr As Long = 0&
 #End If
 Static pendingClass As Class1
 Static pendingPtr As LongPtr
 Static lastClass As Class1
 Static lastClassPtr As LongPtr
 Dim prevPtrAddr As LongPtr
 Dim prevPtr As LongPtr
 Dim nextPtrAddr As LongPtr
 Dim followPtr As LongPtr
 Dim secondLastPtr As LongPtr
 Dim tempPtr As LongPtr
 Dim tempClass As Class1
 '
 If pendingClass Is Nothing Then
 Set pendingClass = instanceToDelay
 pendingPtr = v.Dealloc.ThisPtr
 Exit Sub
 End If
 With Mem.Common(0)
 If pendingPtr = .lastInstancePtr Then
 'We force keep the last instance active to avoid extra logic
 If lastClass Is Nothing Then
 Set lastClass = pendingClass
 lastClassPtr = pendingPtr
 Set pendingClass = instanceToDelay
 pendingPtr = v.Dealloc.ThisPtr
 Exit Sub
 End If
 '
 Set tempClass = lastClass
 Set lastClass = pendingClass
 Set pendingClass = tempClass
 Set tempClass = Nothing
 pendingPtr = lastClassPtr
 lastClassPtr = .lastInstancePtr
 End If
 '
 If .lastTerminatedPtr = nullPtr Then
 .lastTerminatedPtr = Vars.Dealloc.ThisPtr 'Use Def instance
 End If
 '
 prevPtrAddr = pendingPtr + prevOffset
 prevPtr = MemLongPtr(prevPtrAddr)
 '
 If prevPtr = .lastTerminatedPtr Then
 followPtr = MemLongPtr(pendingPtr + .nextPtrOffset)
 Else 'Insert after last terminated
 MemLongPtr(prevPtrAddr) = .lastTerminatedPtr
 '
 nextPtrAddr = .lastTerminatedPtr + .nextPtrOffset
 tempPtr = MemLongPtr(nextPtrAddr)
 MemLongPtr(nextPtrAddr) = pendingPtr
 '
 MemLongPtr(tempPtr + prevOffset) = pendingPtr
 '
 nextPtrAddr = pendingPtr + .nextPtrOffset
 followPtr = MemLongPtr(nextPtrAddr)
 MemLongPtr(nextPtrAddr) = tempPtr
 '
 If prevPtr <> nullPtr Then 'Not first ever instance
 MemLongPtr(prevPtr + .nextPtrOffset) = followPtr
 End If
 '
 MemLongPtr(followPtr + prevOffset) = prevPtr
 followPtr = tempPtr
 End If
 '
 'Make VB 'believe' that trailing instance is the last instance
 ' so that a shorter list is traversed when we terminate 'pending'
 prevPtrAddr = .lastInstancePtr + prevOffset
 secondLastPtr = MemLongPtr(prevPtrAddr)
 MemLongPtr(prevPtrAddr) = pendingPtr
 '
 Set pendingClass = Nothing 'Traverse short list and deallocate as needed
 '
 MemLongPtr(prevPtrAddr) = secondLastPtr 'Restore to long list
 '
 tempPtr = MemLongPtr(pendingPtr + prevOffset)
 If .lastTerminatedPtr <> tempPtr Then 'Memory was reclaimed
 MemLongPtr(tempPtr + .nextPtrOffset) = pendingPtr
 End If
 .lastTerminatedPtr = pendingPtr
 .lastTerminatedNextPtr = followPtr
 '
 Set pendingClass = instanceToDelay
 pendingPtr = v.Dealloc.ThisPtr
 End With
End Sub

Edit 24-Mar-2025

The above approach does not account for the class being used in external projects. An example of how to achive cross-project fast deallocation can be seen in this commit on the above mentioned dictionary class. The idea is to track the reference count of the main hidden instance and then, if state loss is detected, to fix instance pointers.

• konijn: Love this question, we have seem resident VB magicians, I hope you will get a great review.
• Greedo: This is a ridiculous problem. Well done for solving it :D
• Greedo: Fwiw I have reproduced your results on my end so the approach is working :) I must say your first section on instance memory layout with the alphabetically named variables is great and very well explained. However the code implementing the fix is more cryptic and not great variable names. In particular I'm struggling to follow when you are using pointers for the linked list structs Vs just setting up the fast memory accessors. I think these could be named more distinctly, or could you extract out a function looking a bit more like copymemory, or link to some explanation of the array style mem?
• Cristian Buse: Thanks @Greedo it does make a lot of sense. I will update the code to isolate the copy memory stuff. Most likely will add a Get / Let pair for a private MemLongPtr method.
• Cristian Buse: @Greedo I've updated the Class1 code and copy operations are now isolated. Thanks