+ add function callback support for the Register calling convention on i386

git-svn-id: trunk@42150 -

packages/rtl-objpas/src/i386/invoke.inc

@@ -440,11 +440,513 @@ begin
   end;
 end;
 
+const
+  PlaceholderContext = LongWord($12345678);
+  PlaceholderAddress = LongWord($87654321);
+  PlaceholderRetPop  = Word($1234);
+
+  RetNear = $C2;
+  RetFar = $CA;
+
+label
+  CallbackRegisterContext,
+  CallbackRegisterAddress,
+  CallbackRegisterCall,
+  CallbackRegisterRet,
+  CallbackRegisterEnd;
+
+const
+  CallbackRegisterContextPtr: Pointer = @CallbackRegisterContext;
+  CallbackRegisterAddressPtr: Pointer = @CallbackRegisterAddress;
+  CallbackRegisterCallPtr: Pointer = @CallbackRegisterCall;
+  CallbackRegisterRetPtr: Pointer = @CallbackRegisterRet;
+  CallbackRegisterEndPtr: Pointer = @CallbackRegisterEnd;
+
+procedure CallbackRegister; assembler; nostackframe;
+asm
+  { establish frame }
+  pushl %ebp
+  movl %esp, %ebp
+
+  { store registers }
+  pushl %ecx
+  pushl %edx
+  pushl %eax
+
+  { store pointer to stack area (including GP registers) }
+  lea (%esp), %edx
+
+  { also store ebx as we'll use that for the function address }
+  pushl %ebx
+
+  { call function with context }
+CallbackRegisterContext:
+  movl $0x12345678, %eax
+CallbackRegisterAddress:
+  movl $0x87654321, %ebx
+CallbackRegisterCall:
+
+  call *%ebx
+
+  { restore ebx }
+  popl %ebx
+
+  { restore stack }
+  movl %ebp, %esp
+  popl %ebp
+
+CallbackRegisterRet:
+  ret $0x1234
+CallbackRegisterEnd:
+end;
+
+type
+  TSystemFunctionCallback = class(TFunctionCallCallback)
+  private type
+    {$ScopedEnums On}
+    TArgType = (
+      GenReg,
+      Stack
+    );
+    {$ScopedEnums Off}
+
+    TArgInfo = record
+      ArgType: TArgType;
+      ArgIdx: SizeInt;
+      Slots: SizeInt;
+      Offset: SizeInt;
+      Deref: Boolean;
+    end;
+  private
+    fData: Pointer;
+    fSize: PtrUInt;
+    fFlags: TFunctionCallFlags;
+    fContext: Pointer;
+    fArgs: specialize TArray<TFunctionCallParameterInfo>;
+    fArgInfos: specialize TArray<TArgInfo>;
+    fRefArgs: specialize TArray<SizeInt>;
+    fResultType: PTypeInfo;
+    fResultIdx: SizeInt;
+    fResultInParam: Boolean;
+  private
+    function Handler(aStack: Pointer): Int64;
+  protected
+    procedure CreateCallback;
+    procedure CreateArgInfos;
+    function GetCodeAddress: CodePointer; override;
+    procedure CallHandler(constref aArgs: specialize TArray<Pointer>; aResult: Pointer; aContext: Pointer); virtual; abstract;
+  public
+    constructor Create(aContext: Pointer; aCallConv: TCallConv; constref aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags);
+    destructor Destroy; override;
+  end;
+
+  TSystemFunctionCallbackMethod = class(TSystemFunctionCallback)
+  private
+    fHandler: TFunctionCallMethod;
+  protected
+    procedure CallHandler(constref aArgs: specialize TArray<Pointer>; aResult: Pointer; aContext: Pointer); override;
+  public
+    constructor Create(aHandler: TFunctionCallMethod; aContext: Pointer; aCallConv: TCallConv; constref aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags);
+  end;
+
+  TSystemFunctionCallbackProc = class(TSystemFunctionCallback)
+  private
+    fHandler: TFunctionCallProc;
+  protected
+    procedure CallHandler(constref aArgs: specialize TArray<Pointer>; aResult: Pointer; aContext: Pointer); override;
+  public
+    constructor Create(aHandler: TFunctionCallProc; aContext: Pointer; aCallConv: TCallConv; constref aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags);
+  end;
+
+function TSystemFunctionCallback.Handler(aStack: Pointer): Int64;
+{
+  aStack has the following layout:
+    0:  EAX
+    4:  EDX
+    8:  ECX
+    12: EBP (not needed)
+    16: RET (not needed)
+    20: ARGS
+}
+var
+  args: specialize TArray<Pointer>;
+  i, len: SizeInt;
+  val: PPtrUInt;
+  resptr: Pointer;
+  genargs, stackargs: PPtrUInt;
+  floatres, floattmp: Extended;
+  td: PTypeData;
+begin
+  len := Length(fArgInfos);
+  if fResultInParam then
+    Dec(len);
+  SetLength(args, len);
+  genargs := PPtrUInt(aStack);
+  stackargs := @genargs[5];
+  for i := 0 to High(fArgInfos) do begin
+    if i = fResultIdx then
+      Continue;
+    case fArgInfos[i].ArgType of
+      TArgType.GenReg:
+        val := @genargs[fArgInfos[i].Offset];
+      TArgType.Stack:
+        val := @stackargs[fArgInfos[i].Offset];
+    end;
+    if fArgInfos[i].Deref then
+      args[fArgInfos[i].ArgIdx] := PPtrUInt(val^)
+    else
+      args[fArgInfos[i].ArgIdx] := val;
+  end;
+
+  if fResultInParam then begin
+    case fArgInfos[fResultIdx].ArgType of
+      TArgType.GenReg:
+        resptr := @genargs[fArgInfos[fResultIdx].Offset];
+      TArgType.Stack:
+        resptr := @stackargs[fArgInfos[fResultIdx].Offset];
+    end;
+    if fArgInfos[fResultIdx].Deref then
+      resptr := PPointer(resptr)^;
+  end else if Assigned(fResultType) then begin
+    if fResultType^.Kind = tkFloat then begin
+      resptr := @floatres;
+    end else
+      resptr := @Result;
+  end else
+    resptr := Nil;
+
+  CallHandler(args, resptr, fContext);
+
+  if Assigned(fResultType) and not fResultInParam and (fResultType^.Kind = tkFloat) then begin
+    td := GetTypeData(fResultType);
+    case td^.FloatType of
+      ftSingle:
+        asm
+          lea floatres, %eax
+          flds (%eax)
+          fwait
+        end ['eax'];
+      ftDouble:
+        asm
+          lea floatres, %eax
+          fldl (%eax)
+          fwait
+        end ['eax'];
+      ftExtended:
+        asm
+          lea floatres, %eax
+          fldt (%eax)
+          fwait
+        end ['eax'];
+      ftCurr,
+      ftComp:
+        asm
+          lea floatres, %eax
+          fildq (%eax)
+          fwait
+        end ['eax'];
+    end;
+  end;
+end;
+
+procedure TSystemFunctionCallback.CreateCallback;
+
+  procedure ReplacePlaceholder(aPlaceholder: PtrUInt; aValue: PtrUInt; aOfs, aSize: PtrUInt);
+  var
+    found: Boolean;
+    i: PtrUInt;
+  begin
+    found := False;
+    for i := aOfs to aOfs + aSize - 1 do begin
+      if PPtrUInt(@PByte(fData)[i])^ = PtrUInt(aPlaceholder) then begin
+        PPtrUInt(@(PByte(fData)[i]))^ := PtrUInt(aValue);
+        found := True;
+        Break;
+      end;
+    end;
+
+    if not found then
+      raise Exception.Create(SErrMethodImplCreateFailed);
+  end;
+
+var
+  src: Pointer;
+  ofs, size: PtrUInt;
+  method: TMethod;
+  i, stacksize: SizeInt;
+begin
+  fSize := PtrUInt(CallbackRegisterEndPtr) - PtrUInt(@CallbackRegister) + 1;
+  fData := AllocateMemory(fSize);
+  if not Assigned(fData) then
+    raise Exception.Create(SErrMethodImplCreateFailed);
+
+  src := @CallbackRegister;
+  Move(src^, fData^, fSize);
+
+  ofs := PtrUInt(CallbackRegisterContextPtr) - PtrUInt(@CallbackRegister);
+  size := PtrUInt(CallbackRegisterAddressPtr) - PtrUInt(CallbackRegisterContextPtr);
+
+  method := TMethod(@Handler);
+
+  ReplacePlaceholder(PlaceholderContext, PtrUInt(method.Data), ofs, size);
+
+  ofs := PtrUInt(CallbackRegisterAddressPtr) - PtrUInt(@CallbackRegister);
+  size := PtrUInt(CallbackRegisterCallPtr) - PtrUInt(CallbackRegisterAddressPtr);
+
+  ReplacePlaceholder(PlaceholderAddress, PtrUInt(method.Code), ofs, size);
+
+  ofs := PtrUInt(CallbackRegisterRetPtr) - PtrUInt(@CallbackRegister);
+  size := PtrUInt(CallbackRegisterEndPtr) - PtrUInt(CallbackRegisterRetPtr);
+
+  if not (PByte(fData)[ofs] = RetNear) and not (PByte(fData)[ofs] = RetFar) then
+    raise Exception.Create(SErrMethodImplCreateFailed);
+
+  stacksize := 0;
+  for i := 0 to High(fArgInfos) do
+    if fArgInfos[i].ArgType = TArgType.Stack then
+      Inc(stacksize, fArgInfos[i].Slots);
+
+  stacksize := stacksize * 4;
+
+  Inc(ofs);
+  if PWord(@PByte(fData)[ofs])^ = PlaceholderRetPop then
+    PWord(@PByte(fData)[ofs])^ := Word(stacksize);
+
+  if not ProtectMemory(fData, fSize, True) then
+    raise Exception.Create(SErrMethodImplCreateFailed);
+end;
+
+procedure TSystemFunctionCallback.CreateArgInfos;
+var
+  pass, genofs, stackofs: LongInt;
+  td: PTypeData;
+  i, c, argcount, stackcount, idx, argidx: SizeInt;
+  stackargs: array of SizeInt;
+begin
+  fResultInParam := ReturnResultInParam(fResultType);
+
+  genofs := 0;
+  stackofs := 0;
+  argidx := 0;
+  argcount := Length(fArgs);
+  if fResultInParam then begin
+    if fcfStatic in fFlags then
+      fResultIdx := 0
+    else
+      fResultIdx := 1;
+    Inc(argcount);
+  end else
+    fResultIdx := -1;
+  SetLength(fArgInfos, argcount);
+  SetLength(fRefArgs, argcount);
+  if fResultIdx >= 0 then begin
+    fArgInfos[fResultIdx].ArgType := TArgType.GenReg;
+    fArgInfos[fResultIdx].Offset := fResultIdx;
+  end;
+
+  SetLength(stackargs, argcount);
+  stackcount := 0;
+
+  for pass := 0 to 1 do begin
+    if pass = 0 then
+      c := High(fArgs)
+    else
+      c := stackcount - 1;
+    for i := 0 to c do begin
+      if argidx = fResultIdx then
+        Inc(argidx);
+      if pfResult in fArgs[i].ParamFlags then begin
+        fResultIdx := argidx;
+        fResultInParam := True;
+      end;
+      if (pass = 0) and (genofs >= 3) then begin
+        stackargs[stackcount] := i;
+        Inc(stackcount);
+        Continue;
+      end;
+      if pass = 0 then
+        idx := i
+      else
+        idx := stackargs[c - i];
+      if pass = 0 then
+        fArgInfos[argidx].ArgType := TArgType.GenReg
+      else
+        fArgInfos[argidx].ArgType := TArgType.Stack;
+      fArgInfos[argidx].Deref := False;
+      fArgInfos[argidx].Slots := 1;
+      if pfArray in fArgs[idx].ParamFlags then
+        fArgInfos[argidx].Deref := True
+      else if fArgs[idx].ParamFlags * [pfOut, pfVar, pfConstRef] <> [] then
+        fArgInfos[argidx].Deref := True
+      else if (pfConst in fArgs[idx].ParamFlags) and not Assigned(fArgs[idx].ParamType) then
+        fArgInfos[argidx].Deref := True
+      else begin
+        td := GetTypeData(fArgs[idx].ParamType);
+        case fArgs[idx].ParamType^.Kind of
+          tkSString,
+          tkMethod:
+            fArgInfos[argidx].Deref := True;
+          tkArray:
+            if td^.ArrayData.Size <= 4 then begin
+              fArgInfos[argidx].Deref := True;
+              fArgInfos[argidx].ArgType := TArgType.Stack;
+            end;
+          tkRecord:
+            if td^.RecSize <= 4 then begin
+              fArgInfos[argidx].Deref := True;
+              fArgInfos[argidx].ArgType := TArgType.Stack;
+            end;
+          tkObject,
+          tkWString,
+          tkUString,
+          tkAString,
+          tkDynArray,
+          tkClass,
+          tkClassRef,
+          tkInterface,
+          tkInterfaceRaw,
+          tkProcVar,
+          tkPointer:
+            ;
+          tkInt64,
+          tkQWord: begin
+            fArgInfos[argidx].ArgType := TArgType.Stack;
+            fArgInfos[argidx].Slots := 2;
+          end;
+          tkSet: begin
+            case td^.OrdType of
+              otUByte: begin
+                case td^.SetSize of
+                  0, 1, 2, 4:
+                    ;
+                  else
+                    fArgInfos[argidx].Deref := True;
+                end;
+              end;
+              otUWord,
+              otULong:
+                ;
+            end;
+          end;
+          tkEnumeration,
+          tkInteger:
+            ;
+          tkBool:
+            case td^.OrdType of
+              otUQWord,
+              otSQWord:
+                fArgInfos[argidx].ArgType := TArgType.Stack;
+            end;
+          tkFloat: begin
+            fArgInfos[argidx].ArgType := TArgType.Stack;
+            case td^.FloatType of
+              ftSingle:
+                ;
+              ftCurr,
+              ftComp,
+              ftDouble:
+                fArgInfos[argidx].Slots := 2;
+              ftExtended:
+                fArgInfos[argidx].Slots := 3;
+            end;
+          end;
+        else
+          raise EInvocationError.CreateFmt(SErrFailedToConvertArg, [idx, fArgs[idx].ParamType^.Name]);
+        end;
+      end;
+
+      { ignore stack arguments in first pass }
+      if (pass = 0) and (fArgInfos[argidx].ArgType = TArgType.Stack) then begin
+        stackargs[stackcount] := idx;
+        Inc(stackcount);
+        Continue;
+      end;
+
+      if fArgInfos[argidx].ArgType = TArgType.GenReg then begin
+        fArgInfos[argidx].ArgIdx := idx;
+        fArgInfos[argidx].Offset := genofs;
+        Inc(genofs);
+      end else if fArgInfos[argidx].ArgType = TArgType.Stack then begin
+        fArgInfos[argidx].ArgIdx := idx;
+        fArgInfos[argidx].Offset := stackofs;
+        Inc(stackofs, fArgInfos[argidx].Slots);
+      end;
+
+      Inc(argidx);
+    end;
+  end;
+end;
+
+function TSystemFunctionCallback.GetCodeAddress: CodePointer;
+begin
+  Result := fData;
+end;
+
+constructor TSystemFunctionCallback.Create(aContext: Pointer; aCallConv: TCallConv; constref aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags);
+
+  function CallConvName: String; inline;
+  begin
+    WriteStr(Result, aCallConv);
+  end;
+
+var
+  i: SizeInt;
+begin
+  if not (aCallConv in [ccReg]) then
+    raise ENotImplemented.CreateFmt(SErrCallConvNotSupported, [CallConvName]);
+  fContext := aContext;
+  SetLength(fArgs, Length(aArgs));
+  for i := 0 to High(aArgs) do
+    fArgs[i] := aArgs[i];
+  fResultType := aResultType;
+  fFlags := aFlags;
+  CreateArgInfos;
+  CreateCallback;
+end;
+
+destructor TSystemFunctionCallback.Destroy;
+begin
+  if Assigned(fData) then
+    FreeMemory(fData);
+end;
+
+constructor TSystemFunctionCallbackProc.Create(aHandler: TFunctionCallProc; aContext: Pointer; aCallConv: TCallConv; constref aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags);
+begin
+  inherited Create(aContext, aCallConv, aArgs, aResultType, aFlags);
+  fHandler := aHandler;
+end;
+
+procedure TSystemFunctionCallbackProc.CallHandler(constref aArgs: specialize TArray<Pointer>; aResult: Pointer; aContext: Pointer);
+begin
+  fHandler(aArgs, aResult, aContext);
+end;
+
+constructor TSystemFunctionCallbackMethod.Create(aHandler: TFunctionCallMethod; aContext: Pointer; aCallConv: TCallConv; constref aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags);
+begin
+  inherited Create(aContext, aCallConv, aArgs, aResultType, aFlags);
+  fHandler := aHandler;
+end;
+
+procedure TSystemFunctionCallbackMethod.CallHandler(constref aArgs: specialize TArray<Pointer>; aResult: Pointer; aContext: Pointer);
+begin
+  fHandler(aArgs, aResult, aContext);
+end;
+
+function SystemCreateCallbackProc(aHandler: TFunctionCallProc; aCallConv: TCallConv; aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
+begin
+  Result := TSystemFunctionCallbackProc.Create(aHandler, aContext, aCallConv, aArgs, aResultType, aFlags);
+end;
+
+function SystemCreateCallbackMethod(aHandler: TFunctionCallMethod; aCallConv: TCallConv; aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
+begin
+  Result := TSystemFunctionCallbackMethod.Create(aHandler, aContext, aCallConv, aArgs, aResultType, aFlags);
+end;
+
 const
   SystemFunctionCallManager: TFunctionCallManager = (
     Invoke: @SystemInvoke;
-    CreateCallbackProc: Nil;
-    CreateCallbackMethod: Nil;
+    CreateCallbackProc: @SystemCreateCallbackProc;
+    CreateCallbackMethod: @SystemCreateCallbackMethod;
   );
 
 procedure InitSystemFunctionCallManager;