RuntimeBuilder/Source/RuntimeBuilder.Fasm.pas

unit RuntimeBuilder.Fasm;

interface

//{$INLINE auto}

uses
  System.Classes,System.TypInfo,System.IOUtils,System.Rtti,System.Generics.Collections,Winapi.Windows,
    RuntimeBuilder,FasmOnDelphi;

type
  TRTBFasmCompiler=class(TRTBCompiler)
    protected type
      TRTBFasmSource=class(TRTBSource)
    	protected type
          TRTBFasmModule=class(TRTBModule)
            private type
              TRTBFasmFunc=class(TRTBFunc)
                private
                  p:Pointer;
                public
                  constructor Create(p:Pointer);
                  function Call(OutType:PTypeInfo;args:TArray<TValue>;CallType:TRTBCallType=CRTBCallTypeDefault):TValue;override;
              end;
              {TRTBFasmVar=class(TRTBVar)
                protected
                  function SetVal(Val:TValue);virtual;abstract;
                  function GetVal:TValue;virtual;abstract;
                public
                  property Val:TValue read GetVal write SetVal;
              end;}
            private
              p:Pointer;
              sb:NativeUInt;
              funcs:TDictionary<string,NativeUInt>;
              function GetFuntion(Name:string):TRTBFunc;override;
              {function GetVar(Name:string):TRTBVar;override;}
            public
              constructor Create(p:Pointer;sb:NativeUInt;funcs:TDictionary<string,NativeUInt>);
              destructor Destroy;override;
          end;
        protected
          libs:TStringList;
          funcs:TStringList;
          regvars:TList<TPair<string,PTypeInfo>>;
          FText:string;
          function GetIncLibs():string;
      	  function GetText:string;override;
          procedure SetText(S:string);override;
        public
          constructor Create(Compiler:TRTBFasmCompiler);

          {procedure LoadLib(Name:string);override;
          procedure UnLoadLib(Name:string);override;

          procedure AddNameSpace(Name:string);override;
          procedure DelNameSpace(Name:string);override;

          procedure AddType(NameSpace:string;Name:string;&Type:TRTBType);override;
          procedure ExportType(NameSpace:string;Name:string;&Type:TRTBType);override;
          procedure DelType(NameSpace:string;Name:string);override;

          procedure AddConst(NameSpace:string;Name:string;Val:TValue);override;
          procedure ExportConst(NameSpace:string;Name:string;Val:TValue);override;
          procedure DelConst(NameSpace:string;Name:string);override;

          procedure AddVariable(NameSpace:string;Name:string;var Data);override;
          procedure ExportVariable(NameSpace:string;Name:string;var Data);override;
          procedure DelVariable(NameSpace:string;Name:string);override;}

          procedure &Register(NameSpace:string;Name:string;&Type:TRTBType);override;
          //procedure UnRegister(NameSpace:string;Name:string;&Type:TRTBType);override;
          procedure RegisterFunction(NameSpace:string;Name:string);override;
          //procedure UnRegisterFunction(NameSpace:string;Name:string);override;

          function Compilate:TRTBModule;override;
          destructor Destroy;override;
      end;
    public
      CompilerMem:NativeUInt;
      MaxSteps:word;
      constructor Create(FasmPath:String=FasmPath;AsDll:boolean=false);
      function GenNewSrc():TRTBSource;override;
  end;

implementation

uses System.SysUtils;

constructor TRTBFasmCompiler.TRTBFasmSource.TRTBFasmModule.TRTBFasmFunc.Create(p:Pointer);
begin
inherited Create();
Self.p:=p;
end;

function TRTBFasmCompiler.TRTBFasmSource.TRTBFasmModule.TRTBFasmFunc.Call(OutType:PTypeInfo;args:TArray<TValue>;CallType:TRTBCallType=CRTBCallTypeDefault):TValue;
begin
{$IFDEF CPUX64}
Result:=Invoke(p,args,ccReg,OutType);
{$ELSE}
case CallType of
CRTBCallTypeRegister:Result:=Invoke(p,args,ccReg,OutType);
CRTBCallTypeStdCall:Result:=Invoke(p,args,ccStdCall,OutType);
CRTBCallTypeCdecl:Result:=Invoke(p,args,ccCdecl,OutType);
CRTBCallTypePascal:Result:=Invoke(p,args,ccPascal,OutType);
CRTBCallTypeSafeCall:Result:=Invoke(p,args,ccSafeCall,OutType);
end;
{$ENDIF}
end;

(*constructor TRTBFasmCompiler.TRTBFasmSource.TRTBFasmLib.TRTBFasmLibFunc.Create(p:Pointer);
begin
Self.p:=p;
end;

destructor TRTBFasmCompiler.TRTBFasmSource.TRTBFasmLib.TRTBFasmLibFunc.Destroy;
begin
p:=nil;
end;

function TRTBFasmCompiler.TRTBFasmSource.TRTBFasmLib.GetFuntion(Name:string):TRTBFunc;
begin
Result:=TRTBFasmLibFunc.Create(GetProcAddress(Lib,pwidechar(Name)));
end;*)

{$POINTERMATH ON}
function TRTBFasmCompiler.TRTBFasmSource.TRTBFasmModule.GetFuntion(Name:string):TRTBFunc;
begin
Result:=TRTBFasmFunc.Create(Pointer(PNativeUInt(NativeUInt(funcs.Items[Name])+NativeUInt(p))^+NativeUInt(p)));
end;

constructor TRTBFasmCompiler.TRTBFasmSource.TRTBFasmModule.Create(p:Pointer;sb:NativeUInt;funcs:TDictionary<string,NativeUInt>);
begin
Self.p:=VirtualAlloc(nil,sb,MEM_COMMIT,PAGE_EXECUTE_READWRITE);
CopyMemory(Self.p,p,sb);
Self.sb:=sb;
Self.funcs:=funcs;
FreeMem(p);
end;

destructor TRTBFasmCompiler.TRTBFasmSource.TRTBFasmModule.Destroy;
begin
VirtualFree(p,sb,MEM_RELEASE);
end;

function TRTBFasmCompiler.TRTBFasmSource.GetIncLibs():string;
var
  i:integer;
begin
Result:='';
for i:=0 to libs.count-1 do
  Result:=Result+sLineBreak+'include '+#39+libs.Strings[i]+#39;
end;

function TRTBFasmCompiler.TRTBFasmSource.GetText:string;
begin
Result:=FText;
end;

procedure TRTBFasmCompiler.TRTBFasmSource.SetText(S:string);
begin
FText:=S;
end;

constructor TRTBFasmCompiler.TRTBFasmSource.Create(Compiler:TRTBFasmCompiler);
begin
inherited Create(Compiler);
FText:='';
libs:=TStringList.Create;
funcs:=TStringList.Create;
end;

{function TRTBFasmCompiler.TRTBFasmSource.LoadLib(Name:string):TRTBLib;
begin
libs.Add(Name);
end;}

procedure TRTBFasmCompiler.TRTBFasmSource.&Register(NameSpace:string;Name:string;&Type:TRTBType);
begin
if NameSpace<>'' then
  &Register('',NameSpace+'.'+Name,&Type)
else
begin

  //
end;
end;

procedure TRTBFasmCompiler.TRTBFasmSource.RegisterFunction(NameSpace:string;Name:string);
begin
if NameSpace<>'' then
  funcs.Add(NameSpace+'.'+Name)
else
  funcs.Add(Name);
end;

function TRTBFasmCompiler.TRTBFasmSource.Compilate:TRTBModule;
var
  templib,pointerDecl,FuncDecl:string;
  Res:TFasmResult;
  i:NativeUInt;
  FuncDict:TDictionary<string,NativeUInt>;
begin
case SizeOf(pointer) of
2:pointerDecl:='dw ';
4:pointerDecl:='dd ';
8:pointerDecl:='dq ';
end;
FuncDecl:='';
FuncDict:=TDictionary<string,NativeUInt>.Create();
for i:=0 to funcs.Count-1 do
begin
  FuncDecl:=FuncDecl+pointerDecl+funcs.Strings[i]+sLineBreak;
  FuncDict.Add(funcs.Strings[i],i*SizeOf(pointer));
end;
Res:=FasmAssemble(FuncDecl+Text+GetIncLibs,(Compiler as TRTBFasmCompiler).CompilerMem,(Compiler as TRTBFasmCompiler).MaxSteps);
if Res.Error<>FASM_OK then
  raise Exception.Create(Res.OutStr);
Result:=TRTBFasmModule.Create(Res.OutData,Res.sb,FuncDict);
end;

destructor TRTBFasmCompiler.TRTBFasmSource.Destroy;
begin
FreeAndNil(libs);
FreeAndNil(funcs);
end;

constructor TRTBFasmCompiler.Create(FasmPath:String=FasmPath;AsDll:boolean=false);
begin
inherited Create();
CompilerMem:=1024*1024*16;
MaxSteps:=65535;
OpenFASM(FasmPath,AsDll);
end;

function TRTBFasmCompiler.GenNewSrc():TRTBSource;
begin
Result:=TRTBFasmSource.Create(Self);
end;

end.