For latest additions, seeEdit 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 excellentAccurateTimer library
• a class moduleClass1 with no code
• the following code in a standard .bas module

RunTestDeallocSpeed1 method.

Option ExplicitSub 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 ^ 20End SubPrivate 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 = resEnd Function

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

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 nativeCollection 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 addressObjPtr(instance) + PTR_SIZE wherePTR_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 toIConnectionPoint 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 addressObjPtr(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 wordTerminated refers to aPartial 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 andpVTableIClassModuleEvt there will be pointers to interfaces being implemented or interfaces created for varsWithEvents, if any
• YetToFindOut5 is a pointer to where theStatic 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        '0End TypePublic 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 LongPtrEnd Type

A quick test, runTestClassFootprint:

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 IfPublic Function MemLongPtr(ByVal addr As LongPtr) As LongPtr    CopyMemory MemLongPtr, ByVal addr, PTR_SIZEEnd FunctionSub 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    '    StopEnd Sub

Looks like this:

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 toNothing
  • 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 theIClassModuleEvt interface and soClass_Terminate is called, if present. However, if state was lost (e.g.End ran or Stop was pressed in the VBE) thenClass_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 inClass_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 thea_VTableOrPrevTerm to point to the previous terminated (but not deallocated) instance. If there are no previously terminated instances or if they were deallocated, thena_VTableOrPrevTerm will be set to zero / null ptr
• VB will update theb_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 theStop lines. Keep the VBE and Excel windows side by side. Add this code to a standard module and runTestDealloc (press F5 key to jump to the nextStop):

Option ExplicitSub 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)    StopEnd SubSub 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 WithEnd 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:

Pelase note that I did not share code used to test and prove some of the points mentioned here (e.g. howe_VBClassVTables is deallocated or howl_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 makeVBA-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 withthis and eventuallythis, the deallocation is now under a second.

The problem with VBA7 is that it has a massive API overhead - seethis 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 VariantByRef (seeVBA-MemoryTools for both approaches).

For now, this is the code needed to fix the problem for our exampleClass1 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 aClass1.cls text file and then import that file:

VERSION 1.0 CLASSBEGIN  MultiUse = -1  'TrueENDAttribute VB_Name = "Class1"Attribute VB_GlobalNameSpace = FalseAttribute VB_Creatable = FalseAttribute VB_PredeclaredId = TrueAttribute VB_Exposed = False'@PredeclaredIdOption 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 vTableEnd EnumPrivate Type SAFEARRAYBOUND    cElements As Long    lLbound As LongEnd TypePrivate Type SAFEARRAY_1D    cDims As Integer    fFeatures As Integer    cbElements As Long    cLocks As Long    pvData As LongPtr    rgsabound0 As SAFEARRAYBOUNDEnd Type             'Data shared across all class instancesPrivate 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 LongPtrEnd Type'These will link into the default (Predeclared) instance of this classPrivate Type MemoryAccessors    Common() As Globals    RPtr() As LongPtrEnd TypePrivate Type DeallocVars    ThisPtr As LongPtr    NextClassPtr As LongPtrEnd TypePrivate Type ClassVariables    DefInstance As Class1 'Avoids deallocation of default (Predeclared) instance    Dealloc As DeallocVarsEnd Type'Class membersPrivate Vars As ClassVariablesPrivate Mem As MemoryAccessorsPrivate 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 WithEnd 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.dPtrEnd Sub'Only initialize memory manipulation structsPrivate Sub Class_Initialize()    Vars.Dealloc.ThisPtr = ObjPtr(Me)    Class1.InitStructs Vars, MemEnd Sub'Postpones termination to a later stage where we have full control over how VBA'   traverses the linked list of all class instancesPrivate 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 = NothingEnd 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 WithEnd Sub

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

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 likeVBA-FastDictionary. You probably realized that theClass1 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 theClass_Terminate method is called, we simply store the instance as pending so that we get outside the scope ofClass_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 refactoredClass1 isolates the memory copy operations into theMemLongPtr properties:

VERSION 1.0 CLASSBEGIN  MultiUse = -1  'TrueENDAttribute VB_Name = "Class1"Attribute VB_GlobalNameSpace = FalseAttribute VB_Creatable = FalseAttribute VB_PredeclaredId = TrueAttribute VB_Exposed = False'@PredeclaredIdOption 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 vTableEnd EnumPrivate Type SAFEARRAYBOUND    cElements As Long    lLbound As LongEnd TypePrivate Type SAFEARRAY_1D    cDims As Integer    fFeatures As Integer    cbElements As Long    cLocks As Long    pvData As LongPtr    rgsabound0 As SAFEARRAYBOUNDEnd Type             'Data shared across all class instancesPrivate 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 LongPtrEnd Type'These will link into the default (Predeclared) instance of this classPrivate Type MemoryAccessors    Common() As Globals    RPtr() As LongPtrEnd TypePrivate Type DeallocVars    ThisPtr As LongPtr    NextClassPtr As LongPtrEnd TypePrivate Type ClassVariables    DefInstance As Class1 'Avoids deallocation of default (Predeclared) instance    Dealloc As DeallocVarsEnd Type'Class membersPrivate Vars As ClassVariablesPrivate Mem As MemoryAccessorsPrivate Property Get MemLongPtr(ByVal addr As LongPtr) As LongPtr    With Mem.Common(0)        .saP.pvData = addr        MemLongPtr = Mem.RPtr(0)        .saP.pvData = .dPtr    End WithEnd PropertyPrivate 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 WithEnd PropertyPrivate 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 WithEnd 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.ThisPtrEnd Sub'Only initialize memory manipulation structsPrivate Sub Class_Initialize()    Vars.Dealloc.ThisPtr = ObjPtr(Me)    Class1.InitStructs Vars, MemEnd Sub'Postpones termination to a later stage where we have full control over how VBA'   traverses the linked list of all class instancesPrivate 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 = NothingEnd 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 WithEnd 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 inthis 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.

• 3
  \$\begingroup\$Love this question, we have seem resident VB magicians, I hope you will get a great review.\$\endgroup\$

  konijn

  – konijn

  2024-12-12 13:12:45 +00:00

  CommentedDec 12, 2024 at 13:12
• 4
  \$\begingroup\$This is a ridiculous problem. Well done for solving it :D\$\endgroup\$

  Greedo

  – Greedo

  2024-12-12 14:06:17 +00:00

  CommentedDec 12, 2024 at 14:06
• 1
  \$\begingroup\$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?\$\endgroup\$

  Greedo

  – Greedo

  2025-01-03 17:50:30 +00:00

  CommentedJan 3 at 17:50
• 1
  \$\begingroup\$Thanks @Greedo it does make a lot of sense. I will update the code to isolate the copy memory stuff. Most likely will add aGet / Let pair for a privateMemLongPtr method.\$\endgroup\$

  Cristian Buse

  – Cristian Buse

  2025-01-05 12:40:29 +00:00

  CommentedJan 5 at 12:40
• 1
  \$\begingroup\$@Greedo I've updated theClass1 code and copy operations are now isolated. Thanks\$\endgroup\$

  Cristian Buse

  – Cristian Buse

  2025-01-06 09:56:42 +00:00

  CommentedJan 6 at 9:56

0

Start asking to get answers

Find the answer to your question by asking.

Explore related questions

See similar questions with these tags.