From f31aa972612f65f82b17aece8b83eb17ab9539f0 Mon Sep 17 00:00:00 2001 From: svenbarth Date: Sat, 29 Dec 2018 19:21:30 +0000 Subject: [PATCH] + add a callback implementation for the Win64 calling convention git-svn-id: trunk@40703 - --- packages/rtl-objpas/src/inc/rtti.pp | 1 + packages/rtl-objpas/src/x86_64/invoke.inc | 416 +++++++++++++++++++++- 2 files changed, 415 insertions(+), 2 deletions(-) diff --git a/packages/rtl-objpas/src/inc/rtti.pp b/packages/rtl-objpas/src/inc/rtti.pp index 844ab6972b..d1e42241fa 100644 --- a/packages/rtl-objpas/src/inc/rtti.pp +++ b/packages/rtl-objpas/src/inc/rtti.pp @@ -16,6 +16,7 @@ unit Rtti experimental; {$mode objfpc}{$H+} {$modeswitch advancedrecords} +{$goto on} {$Assertions on} { Note: since the Lazarus IDE is not yet capable of correctly handling generic diff --git a/packages/rtl-objpas/src/x86_64/invoke.inc b/packages/rtl-objpas/src/x86_64/invoke.inc index 7758f0b787..1e9e73cbc2 100644 --- a/packages/rtl-objpas/src/x86_64/invoke.inc +++ b/packages/rtl-objpas/src/x86_64/invoke.inc @@ -291,11 +291,423 @@ begin {$endif} end; +{$ifdef windows} +const + PlaceholderContext = QWord($1234567812345678); + PlaceholderAddress = QWord($8765432187654321); + +label + CallbackContext, + CallbackAddress, + CallbackCall, + CallbackEnd; + +const + CallbackContextPtr: Pointer = @CallbackContext; + CallbackAddressPtr: Pointer = @CallbackAddress; + CallbackCallPtr: Pointer = @CallbackCall; + CallbackEndPtr: Pointer = @CallbackEnd; + +procedure Callback; assembler; nostackframe; +asm + { store integer registers } + + movq %rcx, 8(%rsp) +.seh_savereg %rcx, 8 + movq %rdx, 16(%rsp) +.seh_savereg %rdx, 16 + movq %r8, 24(%rsp) +.seh_savereg %r8, 24 + movq %r9, 32(%rsp) +.seh_savereg %r9, 32 + + { establish frame } + pushq %rbp +.seh_pushreg %rbp + movq %rsp, %rbp +.seh_setframe %rbp, 0 +.seh_endprologue + + { store pointer to stack area (including GP registers) } + lea 16(%rsp), %rdx + + sub $32, %rsp + movq %xmm0, (%rsp) + movq %xmm1, 8(%rsp) + movq %xmm2, 16(%rsp) + movq %xmm3, 24(%rsp) + + { store pointer to FP registers } + movq %rsp, %r8 + + sub $32, %rsp + + { call function with context } +CallbackContext: + movq $0x1234567812345678, %rcx +CallbackAddress: + movq $0x8765432187654321, %rax +CallbackCall: + + call *%rax + + { duplicate result to SSE result register } + movq %rax, %xmm0 + + { restore stack } + movq %rbp, %rsp + popq %rbp + + ret +CallbackEnd: +end; +{$endif} + +type + TSystemFunctionCallback = class(TFunctionCallCallback) + {$ifdef windows} + private type + {$ScopedEnums On} + TArgType = ( + GenReg, + FPReg, + Stack + ); + {$ScopedEnums Off} + + TArgInfo = record + ArgType: TArgType; + Offset: SizeInt; + Deref: Boolean; + end; + private + fData: Pointer; + fSize: PtrUInt; + fFlags: TFunctionCallFlags; + fContext: Pointer; + fArgs: specialize TArray; + fArgInfos: specialize TArray; + fRefArgs: specialize TArray; + fResultType: PTypeInfo; + fResultIdx: SizeInt; + fResultInParam: Boolean; + private + function Handler(aStack, aFP: Pointer): PtrUInt; + protected + procedure CallHandler(constref aArgs: specialize TArray; aResult: Pointer; aContext: Pointer); virtual; abstract; + procedure CreateCallback; + procedure CreateArgInfos; + function GetCodeAddress: CodePointer; override; + {$endif} + 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; 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; aResult: Pointer; aContext: Pointer); override; + public + constructor Create(aHandler: TFunctionCallProc; aContext: Pointer; aCallConv: TCallConv; constref aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags); + end; + +{$ifdef windows} +function TSystemFunctionCallback.Handler(aStack, aFP: Pointer): PtrUInt; +var + args: specialize TArray; + i, len: SizeInt; + val: PPtrUInt; + resptr: Pointer; +begin + len := Length(fArgInfos); + if fResultInParam then + Dec(len); + SetLength(args, len); + for i := 0 to High(fArgInfos) do begin + if i = fResultIdx then + Continue; + case fArgInfos[i].ArgType of + TArgType.GenReg, + TArgType.Stack: + val := @PPtrUInt(aStack)[fArgInfos[i].Offset]; + TArgType.FPReg: + val := @PPtrUInt(aFP)[fArgInfos[i].Offset]; + end; + if fArgInfos[i].Deref then + args[i] := PPtrUInt(val^) + else + args[i] := val; + end; + + if fResultInParam then begin + case fArgInfos[fResultIdx].ArgType of + TArgType.GenReg, + TArgType.Stack: + resptr := @PPtrUInt(aStack)[fArgInfos[fResultIdx].Offset]; + TArgType.FPReg: + resptr := @PPtrUInt(aFP)[fArgInfos[fResultIdx].Offset]; + end; + if fArgInfos[fResultIdx].Deref then + resptr := PPointer(resptr)^; + end else + resptr := @Result; + + CallHandler(args, resptr, fContext); +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; +begin + fSize := PtrUInt(CallbackEndPtr) - PtrUInt(@Callback) + 1; + fData := AllocateMemory(fSize); + if not Assigned(fData) then + raise Exception.Create(SErrMethodImplCreateFailed); + + src := @Callback; + Move(src^, fData^, fSize); + + ofs := PtrUInt(CallbackContextPtr) - PtrUInt(@Callback); + size := PtrUInt(CallbackAddressPtr) - PtrUInt(CallbackContextPtr); + + method := TMethod(@Handler); + + ReplacePlaceholder(PlaceholderContext, PtrUInt(method.Data), ofs, size); + + ofs := PtrUInt(CallbackAddressPtr) - PtrUInt(@Callback); + size := PtrUInt(CallbackCallPtr) - PtrUInt(CallbackAddressPtr); + + ReplacePlaceholder(PlaceholderAddress, PtrUInt(method.Code), ofs, size); + + if not ProtectMemory(fData, fSize, True) then + raise Exception.Create(SErrMethodImplCreateFailed); +end; + +procedure TSystemFunctionCallback.CreateArgInfos; +type + PBoolean16 = ^Boolean16; + PBoolean32 = ^Boolean32; + PBoolean64 = ^Boolean64; + PByteBool = ^ByteBool; + PQWordBool = ^QWordBool; +var + stackarea: array of PtrUInt; + stackptr: Pointer; + regs: array[0..3] of PtrUInt; + i, argidx, ofs: LongInt; + val: PtrUInt; + td: PTypeData; + argcount, resreg, refargs: SizeInt; +begin + fResultInParam := ReturnResultInParam(fResultType); + + ofs := 0; + argidx := 0; + refargs := 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; + for i := 0 to High(fArgs) do begin + if argidx = fResultIdx then + Inc(argidx); + if pfResult in fArgs[i].ParamFlags then begin + fResultIdx := argidx; + fResultInParam := True; + end; + fArgInfos[argidx].ArgType := TArgType.GenReg; + fArgInfos[argidx].Deref := False; + if pfArray in fArgs[i].ParamFlags then + fArgInfos[argidx].Deref := True + else if fArgs[i].ParamFlags * [pfOut, pfVar, pfConstRef] <> [] then + fArgInfos[argidx].Deref := True + else begin + td := GetTypeData(fArgs[i].ParamType); + case fArgs[i].ParamType^.Kind of + tkSString, + tkMethod: + fArgInfos[argidx].Deref := True; + tkArray: + if not (td^.ArrayData.Size in [1, 2, 4, 8]) then + fArgInfos[argidx].Deref := True; + tkRecord: + if not (td^.RecSize in [1, 2, 4, 8]) then + fArgInfos[argidx].Deref := True; + { ToDo: handle object like record? } + tkObject, + tkWString, + tkUString, + tkAString, + tkDynArray, + tkClass, + tkClassRef, + tkInterface, + tkInterfaceRaw, + tkProcVar, + tkPointer: + ; + tkInt64, + tkQWord: + ; + tkSet: begin + case td^.OrdType of + otUByte: begin + case td^.SetSize of + 0, 1, 2, 4, 8: + ; + else + fArgInfos[argidx].Deref := True; + end; + end; + otUWord, + otULong: + ; + end; + end; + tkEnumeration, + tkInteger, + tkBool: + ; + tkFloat: begin + case td^.FloatType of + ftCurr, + ftComp: + ; + ftSingle, + ftDouble : fArgInfos[argidx].ArgType := TArgType.FPReg; + ftExtended: {val := PInt64(PExtended(aArgs[i].ValueRef))^}; + end; + end; + else + raise EInvocationError.CreateFmt(SErrFailedToConvertArg, [i, fArgs[i].ParamType^.Name]); + end; + end; + + if (fArgInfos[argidx].ArgType = TArgType.FPReg) and (ofs >= 4) then + fArgInfos[argidx].ArgType := TArgType.Stack; + if (fArgInfos[argidx].ArgType = TArgType.GenReg) and (ofs >= 4) then + fArgInfos[argidx].ArgType := TArgType.Stack; + + fArgInfos[argidx].Offset := ofs; + Inc(ofs); + Inc(argidx); + end; +end; + +function TSystemFunctionCallback.GetCodeAddress: CodePointer; +begin + Result := fData; +end; +{$endif} + +constructor TSystemFunctionCallback.Create(aContext: Pointer; aCallConv: TCallConv; constref aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags); +{$ifdef windows} +var + i: SizeInt; +{$endif} +begin +{$ifdef windows} + fContext := aContext; + SetLength(fArgs, Length(aArgs)); + for i := 0 to High(aArgs) do + fArgs[i] := aArgs[i]; + fResultType := aResultType; + fFlags := aFlags; + CreateCallback; + CreateArgInfos; +{$else} + raise EInvocationError.Create(SErrPlatformNotSupported); +{$endif} +end; + +destructor TSystemFunctionCallback.Destroy; +begin +{$ifdef windows} + if Assigned(fData) then + FreeMemory(fData); +{$endif} +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; 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; 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;