ShellUtils/FastShareMem.pas at master · SCAR-Divi/ShellUtils · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
unit FastShareMem;

// By Frederic Hannes (http://ibeblog.com)
// Based on FastShareMem by Emil M. Santos (http://www.codexterity.com)

interface

var
  GetAllocMemCount: function: Integer;
  GetAllocMemSize: function: Integer;

implementation

uses Windows;

const
  ClassName = '_com.codexterity.fastsharemem.dataclass';

type
  TFastShareMem = record
    MemoryManager: TMemoryManagerEx;
    _GetAllocMemSize: function: Integer;
    _GetAllocMemCount: function: Integer;
  end;

function _GetAllocMemCount: Integer;
var
  State: TMemoryManagerState;
  i: Integer;
begin
  GetMemoryManagerState(State);
  Result := 0;
  for i := 0 to High(State.SmallBlockTypeStates) do
    Inc(Result, State.SmallBlockTypeStates[i].AllocatedBlockCount);
  Inc(Result, State.AllocatedMediumBlockCount + State.AllocatedLargeBlockCount);
end;

function _GetAllocMemSize: Integer;
var
  State: TMemoryManagerState;
  i: Integer;
begin
  GetMemoryManagerState(State);
  Result := 0;
  for i := 0 to High(State.SmallBlockTypeStates) do
    Inc(Result, State.SmallBlockTypeStates[i].AllocatedBlockCount *
      State.SmallBlockTypeStates[i].UseableBlockSize);
  Inc(Result, State.TotalAllocatedMediumBlockSize +
    State.TotalAllocatedLargeBlockSize);
end;

var
  wc: TWndClassA;
  IsHost: Boolean;
  ShareMem: TFastShareMem;

initialization
  if not GetClassInfoA(HInstance, ClassName, wc) then
  begin
    GetMemoryManager(ShareMem.MemoryManager);
    ShareMem._GetAllocMemCount := @_GetAllocMemCount;
    ShareMem._GetAllocMemSize := @_GetAllocMemSize;
    GetAllocMemCount := @_GetAllocMemCount;
    GetAllocMemSize := @_GetAllocMemSize;

    FillChar(wc, SizeOf(wc), 0);
    wc.lpszClassName := ClassName;
    wc.style := CS_GLOBALCLASS;
    wc.hInstance := HInstance;
    wc.lpfnWndProc := @ShareMem;

    if RegisterClassA(wc) = 0 then
    begin
      MessageBox(0, 'Shared Memory Allocator setup failed: Cannot register class.',
        'FastShareMem', 0);
      Halt;
    end;

    IsHost := True;
  end else begin
    SetMemoryManager(TFastShareMem(wc.lpfnWndProc^).MemoryManager);
    GetAllocMemCount := TFastShareMem(wc.lpfnWndProc^)._GetAllocMemCount;
    GetAllocMemSize := TFastShareMem(wc.lpfnWndProc^)._GetAllocMemSize;
    IsHost := False;
  end;
finalization
  if IsHost then
    UnregisterClassA(ClassName, HInstance);
end.