ItaniumABIExporter

ItaniumABIExporter.pas

{===============================================================================
 ItaniumABIExporter

 Copyright © 2024-present tinyBigGAMES™ LLC
 All Rights Reserved.

 Website: https://tinybiggames.com
 Email  : [email protected]
 License: BSD 3-Clause

 Redistribution and use in source and binary forms, with or without
 modification, are permitted provided that the following conditions are met:

 1. Redistributions of source code must retain the above copyright notice, this
    list of conditions and the following disclaimer.

 2. Redistributions in binary form must reproduce the above copyright notice,
    this list of conditions and the following disclaimer in the documentation
    and/or other materials provided with the distribution.

 3. Neither the name of the copyright holder nor the names of its
    contributors may be used to endorse or promote products derived from
    this software without specific prior written permission.

 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
 AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
 DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
 FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
 DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
 SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
 CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
 OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
--------------------------------------------------------------------------------

INTRODUCTION
------------
When compiling Delphi code using the Win64 modern C++ toolchain, routine names
are mangled according to the Itanium ABI specification. This class parses the
.o file to extract the mangled names, then parses the .pas file to match the
mangled exports to the corresponding public routines, and builds a list of
routine import signatures.

Subsequently, it updates the specified module definition file (.def) with the
mangled exports and the specified import source file with the routine import
signatures, inserting the information only between the designated marker tags.

HOW TO USE
----------
procedure Test01_InfoCallback(const ANamespace, AMethodName, AMethedSignature,
  AImport: string; const AUserData: Pointer);
begin
  //WriteLn(AMethedSignature);
  WriteLn(AImport);
end;

procedure Test01();
const
  COBJFilename = 'Unit1.o';
  CSRCFilename = 'Unit1.pas';
  CModuleDefFilename = 'Exports.def';
  CImportSrcFilename = 'test.pas';
var
  ie: TItaniumABIExporter;
begin
  ie := TItaniumABIExporter.Create();
  try
    ie.SetInfoCallback(Test01_InfoCallback, nil);
    ie.ObjFilename := COBJFilename;
    ie.ObjSrcFilename := CSRCFilename;
    ie.ModuleDefFilename := CModuleDefFilename;
    ie.InportSrcFilename := CImportSrcFilename;
    ie.MarkerTag := 'MANGLED_EXPORTS';
    ie.DelayLoad := False;
    ie.ImportDllName := 'MAMBA_DLL';
    ie.Process();
  finally
    ie.Free();
  end;
end;
===============================================================================}

unit ItaniumABIExporter;

interface

uses
  System.SysUtils,
  System.IOUtils,
  System.StrUtils,
  System.Classes,
  System.Generics.Collections,
  System.RegularExpressions;

type
  { TItaniumABIExporter }
  TItaniumABIExporter = class
  public type
    InfoCallback = procedure(const ANamespace, AMethodName, AMethedSignature, AImport: string; const AUserData: Pointer);
  private type
    TCallback<T> = record
      UserData: Pointer;
      Handler: T;
    end;
  private
    FObjFilename: string;
    FObjSrcFilename: string;
    FImportSrcFilename: string;
    FImportDllName: string;
    FDelayLoad: Boolean;
    FModuleDefFilename: string;
    FMarkerTag: string;
    FInfoCallback: TCallback<InfoCallback>;
    procedure SetObjFilename(const AValue: string);
    procedure SetObjSrcFilename(const AValue: string);
    procedure SetModuleDefFilename(const AValue: string);
    procedure SetImportSrcFilename(const AValue: string);
    function  ReplaceTextBetweenMarkers(const AFilename, AMarkerTag: string; const AReplacementText: TStringList): Boolean;
    function  IsItaniumABIExport(const ABuffer: TBytes; var ASymbolName: string): Boolean;
    function  ContainsNamespace(const ANamespace, AExport: string): Boolean;
    function  GetExports(const AObjFilename: string): TStringList;
  public
    property ObjFilename: string read FObjFilename write SetObjFilename;
    property ObjSrcFilename: string read FObjSrcFilename write SetObjSrcFilename;
    property ImportDllName: string read FImportDllName write FImportDllName;
    property DelayLoad: Boolean read FDelayLoad write FDelayLoad;
    property ModuleDefFilename: string read FModuleDefFilename write SetModuleDefFilename;
    property MarkerTag: string read FMarkerTag write FMarkerTag;
    property InportSrcFilename: string read FImportSrcFilename write SetImportSrcFilename;
    function  GetInfoCalback(): TItaniumABIExporter.InfoCallback;
    procedure SetInfoCallback(const AHandler: TItaniumABIExporter.InfoCallback; const AUserData: Pointer);
    function  Process(): Boolean;
  end;

implementation

{ TItaniumABIExporter }
procedure TItaniumABIExporter.SetObjFilename(const AValue: string);
begin
  FObjFilename := TPath.ChangeExtension(AValue, 'o');
end;

procedure TItaniumABIExporter.SetObjSrcFilename(const AValue: string);
begin
  FObjSrcFilename := TPath.ChangeExtension(AValue, 'pas');
end;

procedure TItaniumABIExporter.SetModuleDefFilename(const AValue: string);
begin
  FModuleDefFilename := TPath.ChangeExtension(AValue, 'def');
end;

procedure TItaniumABIExporter.SetImportSrcFilename(const AValue: string);
begin
  FImportSrcFilename := TPath.ChangeExtension(AValue, 'pas');
end;

function  TItaniumABIExporter.ReplaceTextBetweenMarkers(const AFilename, AMarkerTag: string; const AReplacementText: TStringList): Boolean;
var
  FileContent: TStringList;
  StartTag, EndTag: string;
  StartIndex, EndIndex: Integer;
  i: Integer;
begin
  Result := False;

  if not TFile.Exists(AFilename) then Exit;

  FileContent := TStringList.Create;
  try
    FileContent.LoadFromFile(AFilename);

    StartTag := '<' + AMarkerTag + '>';
    EndTag := '</' + AMarkerTag + '>';

    StartIndex := -1;
    EndIndex := -1;

    // Find the start and end tags
    for i := 0 to FileContent.Count - 1 do
    begin
      if (StartIndex = -1) and (Pos(StartTag, FileContent[i]) > 0) then
        StartIndex := i;
      if (EndIndex = -1) and (Pos(EndTag, FileContent[i]) > 0) then
      begin
        EndIndex := i;
        Break;
      end;
    end;

    // If both tags are found, replace the content between them
    if (StartIndex <> -1) and (EndIndex <> -1) and (EndIndex > StartIndex) then
    begin
      // Delete lines between start and end tags
      for i := EndIndex - 1 downto StartIndex + 1 do
        FileContent.Delete(i);

      // Insert new content
      for i := 0 to AReplacementText.Count - 1 do
        FileContent.Insert(StartIndex + 1 + i, AReplacementText[i]);

      // Save the modified content back to the file
      FileContent.SaveToFile(AFilename);

      Result := True;
    end;

  finally
    FileContent.Free;
  end;
end;

function TItaniumABIExporter.IsItaniumABIExport(const ABuffer: TBytes; var ASymbolName: string): Boolean;
var
  i, j: Integer;
begin
  Result := False;
  ASymbolName := '';

  // Check if the buffer has at least 2 bytes
  if Length(ABuffer) < 2 then
    Exit;

  // For demonstration, let's assume that Itanium ABI symbols start with "_Z"
  for i := 0 to Length(ABuffer) - 2 do
  begin
    if (ABuffer[i] = Ord('_')) and (ABuffer[i + 1] = Ord('Z')) then
    begin
      // Extract the symbol name
      SetLength(ASymbolName, Length(ABuffer) - i);
      j := 0;
      while (i + j < Length(ABuffer)) and (ABuffer[i + j] <> 0) do
      begin
        ASymbolName[j + 1] := Chr(ABuffer[i + j]);
        Inc(j);
      end;
      SetLength(ASymbolName, j);

      Result := True;
      Exit;
    end;
  end;
end;

function TItaniumABIExporter.ContainsNamespace(const ANamespace, AExport: string): Boolean;
var
  LParts: TArray<string>;
  LPart: string;
begin
  Result := True;
  LParts := ANamespace.Split(['.']);
  for LPart in LParts do
  begin
    //if not AExport.Contains(Part) then
    if not ContainsText(AExport, LPart) then
    begin
      Result := False;
      Exit;
    end;
  end;
end;

function TItaniumABIExporter.GetExports(const AObjFilename: string): TStringList;
const
  BUFFER_SIZE = 64 * 1024; // 64 KB buffer
var
  LFileStream: TFileStream;
  LBuffer: TBytes;
  LBytesRead, LTotalBytesRead: Integer;
  LSymbolName: string;
  LNamespace: string;
  LLastPartialSymbol: TBytes;
begin
  Result := nil;
  if not TFile.Exists(AObjFilename) then
    Exit;

  LNamespace := TPath.GetFileNameWithoutExtension(AObjFilename);
  Result := TStringList.Create;
  try
    LFileStream := TFileStream.Create(AObjFilename, fmOpenRead or fmShareDenyWrite);
    try
      SetLength(LBuffer, BUFFER_SIZE);
      SetLength(LLastPartialSymbol, 0);
      LTotalBytesRead := 0;

      while LTotalBytesRead < LFileStream.Size do
      begin
        LBytesRead := LFileStream.Read(LBuffer[0], BUFFER_SIZE);
        if LBytesRead = 0 then
          Break;

        // Combine last partial symbol with current buffer
        if Length(LLastPartialSymbol) > 0 then
        begin
          SetLength(LBuffer, Length(LLastPartialSymbol) + LBytesRead);
          Move(LLastPartialSymbol[0], LBuffer[0], Length(LLastPartialSymbol));
          Move(LBuffer[Length(LLastPartialSymbol)], LBuffer[0], LBytesRead);
          SetLength(LLastPartialSymbol, 0);
        end
        else
          SetLength(LBuffer, LBytesRead);

        // Process buffer
        var LStartPos := 0;
        while LStartPos < Length(LBuffer) do
        begin
          if IsItaniumABIExport(Copy(LBuffer, LStartPos, Length(LBuffer) - LStartPos), LSymbolName) then
          begin
            if ContainsNamespace(LNamespace, LSymbolName) then
              Result.Add(LSymbolName);
            LStartPos := LStartPos + Length(LSymbolName);
          end
          else
            Inc(LStartPos);
        end;

        // Save last partial symbol for next iteration
        if LStartPos < Length(LBuffer) then
        begin
          SetLength(LLastPartialSymbol, Length(LBuffer) - LStartPos);
          Move(LBuffer[LStartPos], LLastPartialSymbol[0], Length(LLastPartialSymbol));
        end;

        Inc(LTotalBytesRead, LBytesRead);
      end;
    finally
      LFileStream.Free;
    end;
  except
    FreeAndNil(Result);
    raise;
  end;
end;

function  TItaniumABIExporter.GetInfoCalback(): TItaniumABIExporter.InfoCallback;
begin
  Result := FInfoCallback.Handler;
end;

procedure TItaniumABIExporter.SetInfoCallback(const AHandler: TItaniumABIExporter.InfoCallback; const AUserData: Pointer);
begin
  FInfoCallback.Handler := AHandler;
  FInfoCallback.UserData := AUserData;
end;

function TItaniumABIExporter.Process(): Boolean;
var
  LLines: TStringList;
  I, J: Integer;
  LLine: string;
  LInMethod: Boolean;
  LMethodLines: TStringList;
  LMethodSignature: string;
  //LClassName: string;
  LMethodName: string;
  LParams: TArray<string>;
  LMangledName: string;
  LRegex: TRegEx;
  LMatch: TMatch;
  LParenCount: Integer;
  LIsProcedure: Boolean;
  LReturnType: string;
  LImport: string;
  LDelayLoad: string;
  LMangledNames: TStringList;
  LSymbols: TStringList;
  LInportList: TStringList;
  LNamespace: string;


  function CharCount(const S: string; C: Char): Integer;
  var
    I: Integer;
  begin
    Result := 0;
    for I := 1 to Length(S) do
      if S[I] = C then
        Inc(Result);
  end;

  function GetMangledName(const AMethodName: string): string;
  var
    LSymbol: string;
  begin
    for LSymbol in LSymbols do
    begin
      if ContainsText(LSymbol, AMethodName) then
      begin
        Result := LSymbol;
        Exit;
      end;
    end;
  end;

begin
  Result := False;

  if not TFile.Exists(FObjSrcFilename) then Exit;
  if not TFile.Exists(FObjFilename) then Exit;
  if not TFile.Exists(FImportSrcFilename) then Exit;
  if not TFile.Exists(FModuleDefFilename) then Exit;
  if FImportDllName.IsEmpty then Exit;
  if FMarkerTag.IsEmpty then Exit;

  LSymbols := GetExports(FObjFilename);

  if FDelayLoad then
    LDelayLoad := 'delayed'
  else
    LDelayLoad := '';
  LIsProcedure := False;
  LLines := TStringList.Create();
  LMethodLines := TStringList.Create();
  LMangledNames := TStringList.Create();
  LInportList := TStringList.Create();
  try
    LLines.LoadFromFile(FObjSrcFilename);
    LInMethod := False;
    LParenCount := 0;
    //LClassName := 'Utest01';  // Hardcoded for this example
    LNamespace := TPath.GetFilenameWithoutExtension(FObjFilename);
    for I := 0 to LLines.Count - 1 do
    begin
      LLine := Trim(LLines[I]);
      // Stop processing if implementation section is encountered
      if LLine.StartsWith('implementation') then
        Break;
      // Check for the start of a method definition
      if (not LInMethod) and (LLine.StartsWith('procedure') or LLine.StartsWith('function')) then
      begin
        LInMethod := True;
        LMethodLines.Clear;
        LParenCount := 0;
        LIsProcedure := LLine.StartsWith('procedure');
      end;
      if LInMethod then
      begin
        LMethodLines.Add(LLine);
        // Count parentheses to handle multi-line definitions
        LParenCount := LParenCount + CharCount(LLine, '(') - CharCount(LLine, ')');
        // Check for the end of the method definition
        if (LParenCount = 0) and LLine.EndsWith(';') then
        begin
          LInMethod := False;
          LMethodSignature := LMethodLines.Text.Replace(#13#10, ' ').Trim();
          // Extract method name, parameters, and return type using regular expressions
          if LIsProcedure then
            LRegex := TRegEx.Create('procedure\s+(\w+)[\s\S]*?\(([\s\S]*?)\)')
          else
            LRegex := TRegEx.Create('function\s+(\w+)[\s\S]*?\(([\s\S]*?)\):\s*([\s\S]+?);');

          LMatch := LRegex.Match(LMethodSignature);
          if LMatch.Success then
          begin
            LMethodName := LMatch.Groups[1].Value.Trim();
            LParams := LMatch.Groups[2].Value.Split([';']);

            if not LIsProcedure then
              LReturnType := Trim(LMatch.Groups[3].Value).Trim()
            else
              LReturnType := '';
            // Trim and clean up parameter definitions
            for J := 0 to Length(LParams) - 1 do
              LParams[J] := Trim(LParams[J]);
            LMangledName := GetMangledName(LMethodName);
            LImport := Format('%s external %s %s name ''%s'';', [LMethodSignature, FImportDllName, LDelayLoad, LMangledName]);
            LMangledNames.Add(LMangledName);
            LInportList.Add(LImport);
            if Assigned(FInfoCallback.Handler) then
              FInfoCallback.Handler(LNamespace, LMethodName, LMethodSignature, LImport, FInfoCallback.UserData)
          end;
        end;
      end;
    end;

    Result := ReplaceTextBetweenMarkers(FModuleDefFilename, FMarkerTag, LMangledNames);
    if Result then
      Result := ReplaceTextBetweenMarkers(FImportSrcFilename, FMarkerTag, LInportList);

  finally
    LLines.Free;
    LMethodLines.Free;
    LMangledNames.Free();
    LSymbols.Free();
    LInportList.Free();
  end;
end;

end.