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>>;
          consts:TList<TPair<string,TValue>>;
          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;
consts:=TList<TPair<string,TValue>>.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);
label
  funcscontinue,regvarscontinue,constscontinue;
var
  i,i0:NativeUInt;
begin
Name:=Name+'.';
i:=0;
while i<funcs.Count do
begin
  for i0:=1 to length(Name) do
    if funcs.Strings[i][i0]=Name[i0]then
      goto funcscontinue;
  funcs.Delete(i);
  inc(i);
  funcscontinue:
end;
i:=0;
while i<regvars.Count do
begin
  for i0:=1 to length(Name) do
    if regvars.Items[i].Key[i0]=Name[i0]then
      goto regvarscontinue;
  regvars.Delete(i);
  inc(i);
  regvarscontinue:
end;
i:=0;
while i<consts.Count do
begin
  for i0:=1 to length(Name) do
    if consts.Items[i].Key[i0]=Name[i0]then
      goto constscontinue;
  consts.Delete(i);
  inc(i);
  constscontinue:
end;
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.AddConst(NameSpace:string;Name:string;Val:TValue);
begin
if NameSpace<>'' then
  consts.Add(TPair<string,TValue>.Create(NameSpace+'.'+Name,Val))
else
  consts.Add(TPair<string,TValue>.Create(Name,Val));
end;

procedure TRTBFasmCompiler.TRTBFasmSource.DelConst(NameSpace:string;Name:string);
var
  i:NativeUInt;
begin
if NameSpace<>'' then
  Name:=NameSpace+'.'+Name;
if consts.Count<>0 then
  for i:=0 to consts.Count-1 do
    if consts.Items[i].Key=Name then
    begin
      consts.Delete(i);
      Break;
    end;
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;
  procedure ConstParse(key:string;value:TValue;var PreDecl:string;var base:NativeUInt);
  var
    i:NativeUInt;
    p0:PByte;
  begin
        if Value.IsType<AnsiString> or Value.IsType<RawByteString> or Value.IsType<UTF8String> then
        begin
          PreDecl:=PreDecl+Key+' db '+#39+Value.AsType<AnsiString>+#39+',0'+sLineBreak;
          inc(base,length(Value.AsType<AnsiString>));
        end
        else if Value.IsType<ShortString> then
        begin
          PreDecl:=PreDecl+Key+' db '+#39+Value.AsType<ShortString>+#39+',0'+sLineBreak;
          inc(base,length(Value.AsType<ShortString>));
        end
        else if Value.IsType<WideString> then
        begin
          PreDecl:=PreDecl+Key+' db ';
          p0:=Pointer(PWideChar(Value.AsType<WideString>));
          for i:={$IFDEF NEXTGEN}0{$ELSE}1{$ENDIF} to length(Value.AsType<WideString>){$IFDEF NEXTGEN}-1{$ENDIF} do
          begin
            PreDecl:=PreDecl+inttostr(p0^)+',';
            inc(p0);
            PreDecl:=PreDecl+inttostr(p0^)+',';
            inc(p0);
          end;
          PreDecl:=PreDecl+'0,0'+sLineBreak;
          inc(base,length(Value.AsType<WideString>)*2);
        end
        else if Value.IsType<UCS4String> then
        begin
          PreDecl:=PreDecl+Key+' db ';
          p0:=Pointer(PWideChar(Value.AsType<UCS4String>));
          for i:={$IFDEF NEXTGEN}0{$ELSE}1{$ENDIF} to length(Value.AsType<UCS4String>){$IFDEF NEXTGEN}-1{$ENDIF} do
          begin
            PreDecl:=PreDecl+inttostr(p0^)+',';
            inc(p0);
            PreDecl:=PreDecl+inttostr(p0^)+',';
            inc(p0);
            PreDecl:=PreDecl+inttostr(p0^)+',';
            inc(p0);
            PreDecl:=PreDecl+inttostr(p0^)+',';
            inc(p0);
          end;
          PreDecl:=PreDecl+'0,0,0,0'+sLineBreak;
          inc(base,length(Value.AsType<UCS4String>)*4);
        end
        else if Value.IsOrdinal then
          PreDecl:=PreDecl+Key+' equ '+Value.AsOrdinal.ToString+sLineBreak
        else if Value.Kind=tkFloat then
        begin
          if Value.IsType<Single> then
            PreDecl:=PreDecl+Key+' equ '+FloatToStrF(Value.AsType<Single>,ffFixed,1000,1000)+sLineBreak
          else if Value.IsType<Double> then
            PreDecl:=PreDecl+Key+' equ '+FloatToStrF(Value.AsType<Double>,ffFixed,1000,1000)+sLineBreak
          else if Value.IsType<Extended> then
            PreDecl:=PreDecl+Key+' equ '+FloatToStrF(Value.AsType<Extended>,ffFixed,1000,1000)+sLineBreak
          else if Value.IsType<Real> then
            PreDecl:=PreDecl+Key+' equ '+FloatToStrF(Value.AsType<Real>,ffFixed,1000,1000)+sLineBreak
          else if Value.IsType<Real48> then
            PreDecl:=PreDecl+Key+' equ '+FloatToStrF(Value.AsType<Real48>,ffFixed,1000,1000)+sLineBreak
          else if Value.IsType<Comp> then
            PreDecl:=PreDecl+Key+' equ '+FloatToStrF(Value.AsType<Comp>,ffFixed,1000,1000)+sLineBreak
          else if Value.IsType<Currency> then
            PreDecl:=PreDecl+Key+' equ '+FloatToStrF(Value.AsType<Currency>,ffFixed,1000,1000)+sLineBreak
          else
            PreDecl:=PreDecl+Key+' equ 0.0'+sLineBreak;
        end
        else if Value.Kind=tkPointer then
          PreDecl:=PreDecl+Key+' equ '+NativeUInt(Value.AsType<Pointer>).ToString+sLineBreak
        else if Value.IsArray then
        begin
          if Value.GetArrayLength=0 then
          begin
            PreDecl:=PreDecl+Key+' equ 0'+sLineBreak;
          end
          else
          begin
            PreDecl:=PreDecl+Key+':'+sLineBreak;
            for i:=0 to Value.GetArrayLength-1 do
              ConstParse(key+'.i'+i.ToString,Value.GetArrayElement(i),PreDecl,Base);
          end;
        end
        else if Value.Kind=tkRecord then

        else if Value.Kind=tkUnknown then
          PreDecl:=PreDecl+Key+' equ 0'+sLineBreak;
  end;
var
  templib,pointerDecl,PreDecl:string;
  Res:TFasmResult;
  i,base,sb:NativeUInt;
  FuncDict:TDictionary<string,NativeUInt>;
  RegVarDict:TDictionary<string,TPair<NativeUInt,PTypeInfo>>;
  p:pointer;
begin
sb:=(Compiler as TRTBFasmCompiler).CompilerMem;
p:=VirtualAlloc(nil,sb,MEM_COMMIT,PAGE_EXECUTE_READWRITE);
case SizeOf(pointer)of
2:pointerDecl:='dw ';
4:pointerDecl:='dd ';
8:pointerDecl:='dq ';
end;
PreDecl:='';
FuncDict:=TDictionary<string,NativeUInt>.Create();
base:=0;
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],base);
      inc(base,SizeOf(pointer));
    end;
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,Items[i].Value));
      inc(base,SizeOf(pointer));
    end;
with consts do
  if Count<>0 then
    for i:=0 to Count-1 do
      with Items[i] do
        ConstParse(Key,Value,PreDecl,base);
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);
FreeAndNil(consts);
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.