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;
                  destructor Destroy;override;
              end;
              TRTBFasmVar=class(TRTBVar)
                protected
                  p:pointer;
                  &Type:TRTBType;
                  procedure SetVal(Val:TValue);override;
                  function GetVal:TValue;override;
                public
                  constructor Create(p:pointer;&Type:TRTBType);
                  destructor Destroy;override;
              end;
            private
              p:Pointer;
              sb:NativeUInt;
              funcs:TDictionary<string,NativeUInt>;
              regvars:TDictionary<string,TPair<NativeUInt,PTypeInfo>>;
              function GetFuntion(Name:string):TRTBFunc;override;
              function GetVar(Name:string):TRTBVar;override;
            public
              constructor Create(p:Pointer;sb:NativeUInt;funcs:TDictionary<string,NativeUInt>;regvars:TDictionary<string,TPair<NativeUInt,PTypeInfo>>);
              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 DelType(NameSpace:string;Name:string);override;

          {procedure AddConst(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);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;

destructor TRTBFasmCompiler.TRTBFasmSource.TRTBFasmModule.TRTBFasmFunc.Destroy;
begin
p:=nil;
end;

procedure TRTBFasmCompiler.TRTBFasmSource.TRTBFasmModule.TRTBFasmVar.SetVal(Val:TValue);
begin
if Val.TypeInfo=&Type then
  Val.ExtractRawData(p);
end;

function TRTBFasmCompiler.TRTBFasmSource.TRTBFasmModule.TRTBFasmVar.GetVal:TValue;
begin
TValue.Make(p,&Type,Result);
end;

constructor TRTBFasmCompiler.TRTBFasmSource.TRTBFasmModule.TRTBFasmVar.Create(p:pointer;&Type:TRTBType);
begin
Self.p:=p;
Self.&Type:=&Type;
end;

destructor TRTBFasmCompiler.TRTBFasmSource.TRTBFasmModule.TRTBFasmVar.Destroy;
begin
p:=nil;
&Type:=nil;
end;

function TRTBFasmCompiler.TRTBFasmSource.TRTBFasmModule.GetFuntion(Name:string):TRTBFunc;
begin
Result:=TRTBFasmFunc.Create(PPointer(NativeUInt(funcs.Items[Name])+NativeUInt(p))^);
end;

function TRTBFasmCompiler.TRTBFasmSource.TRTBFasmModule.GetVar(Name:string):TRTBVar;
begin
Result:=TRTBFasmVar.Create(PPointer(NativeUInt(regvars.Items[Name].Key)+NativeUInt(p))^,regvars.Items[Name].Value)
end;

constructor TRTBFasmCompiler.TRTBFasmSource.TRTBFasmModule.Create(p:Pointer;sb:NativeUInt;funcs:TDictionary<string,NativeUInt>;regvars:TDictionary<string,TPair<NativeUInt,PTypeInfo>>);
begin
Self.p:=p;
Self.sb:=sb;
Self.funcs:=funcs;
Self.regvars:=regvars;
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;
regvars:=TList<TPair<string,PTypeInfo>>.Create;
end;

procedure TRTBFasmCompiler.TRTBFasmSource.LoadLib(Name:string);
begin
libs.Add(Name);
end;

procedure TRTBFasmCompiler.TRTBFasmSource.UnLoadLib(Name:string);
begin
with libs do
  Delete(IndexOf(Name));
end;

procedure TRTBFasmCompiler.TRTBFasmSource.AddNameSpace(Name:string);
begin
end;

procedure TRTBFasmCompiler.TRTBFasmSource.DelNameSpace(Name:string);
begin
end;

procedure TRTBFasmCompiler.TRTBFasmSource.AddType(NameSpace:string;Name:string;&Type:TRTBType);
begin
end;

procedure TRTBFasmCompiler.TRTBFasmSource.DelType(NameSpace:string;Name:string);
begin
end;

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

procedure TRTBFasmCompiler.TRTBFasmSource.UnRegister(NameSpace:string;Name:string);
var
  i:NativeUInt;
begin
if NameSpace<>'' then
  Name:=NameSpace+'.'+Name;
if regvars.Count<>0 then
  for i:=0 to regvars.Count-1 do
    if regvars.Items[i].Key=Name then
    begin
      regvars.Delete(i);
      Break;
    end;
end;

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

procedure TRTBFasmCompiler.TRTBFasmSource.UnRegisterFunction(NameSpace:string;Name:string);
var
  i:NativeUInt;
begin
if NameSpace<>'' then
  Name:=NameSpace+'.'+Name;
with funcs do
  Delete(IndexOf(Name));
end;

function TRTBFasmCompiler.TRTBFasmSource.Compilate:TRTBModule;
var
  templib,pointerDecl,PreDecl:string;
  Res:TFasmResult;
  i,base,sb:NativeUInt;
  FuncDict:TDictionary<string,NativeUInt>;
  RegVarDict:TDictionary<string,TPair<NativeUInt,PTypeInfo>>;
  p:pointer;
begin
case SizeOf(pointer)of
2:pointerDecl:='dw ';
4:pointerDecl:='dd ';
8:pointerDecl:='dq ';
end;
PreDecl:='';
FuncDict:=TDictionary<string,NativeUInt>.Create();
with funcs do
  if Count<>0 then
    for i:=0 to Count-1 do
    begin
      PreDecl:=PreDecl+pointerDecl+Strings[i]+sLineBreak;
      FuncDict.Add(Strings[i],i*SizeOf(pointer));
    end;
base:=SizeOf(pointer)*funcs.Count;
RegVarDict:=TDictionary<string,TPair<NativeUInt,PTypeInfo>>.Create();
with regvars do
  if Count<>0 then
    for i:=0 to Count-1 do
    begin
      PreDecl:=PreDecl+pointerDecl+Items[i].Key+sLineBreak;
      RegVarDict.Add(Items[i].Key,TPair<NativeUInt,PTypeInfo>.Create(base+i*SizeOf(pointer),Items[i].Value));
    end;
sb:=(Compiler as TRTBFasmCompiler).CompilerMem;
p:=VirtualAlloc(nil,sb,MEM_COMMIT,PAGE_EXECUTE_READWRITE);
Res:=FasmAssemble('org '+NativeUint(p).ToString+sLineBreak+PreDecl+Text+GetIncLibs,sb,(Compiler as TRTBFasmCompiler).MaxSteps);
if Res.Error<>FASM_OK then
begin
  VirtualFree(p,sb,MEM_RELEASE);
  raise Exception.Create(Res.OutStr);
end;
VirtualAlloc(p,Res.sb,MEM_COMMIT,PAGE_EXECUTE_READWRITE);
CopyMemory(p,Res.OutData,Res.sb);
FreeMem(Res.OutData);
Result:=TRTBFasmModule.Create(p,Res.sb,FuncDict,RegVarDict);
p:=nil;
end;

destructor TRTBFasmCompiler.TRTBFasmSource.Destroy;
begin
FreeAndNil(libs);
FreeAndNil(funcs);
FreeAndNil(regvars);
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.