Guest User

Methods für PascalScript on x64 Laz/FPC, take 2

a guest
Sep 5th, 2012
206
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. Index: x64.inc
  2. ===================================================================
  3. --- x64.inc (revision 38441)
  4. +++ x64.inc (working copy)
  5. @@ -14,7 +14,7 @@
  6.    _RCX, _RDX, _R8, _R9: IPointer;
  7.    var _XMM0: Double;
  8.    _XMM1, _XMM2, _XMM3: Double;
  9. -  aStack: Pointer; aItems: IntPtr); assembler; {$IFDEF FPC}nostackframe;{$ENDIF}
  10. +  aStack: Pointer; aItems: PtrUInt); assembler; {$IFDEF FPC}nostackframe;{$ENDIF}
  11.  asm
  12.  (* Registers:
  13.      RCX: Address
  14. @@ -37,7 +37,7 @@
  15.    mov rdx, aStack
  16.    jmp @compareitems
  17.  @work:
  18. -  push [rdx]
  19. +  push qword ptr [rdx]
  20.    dec rcx
  21.    sub rdx,8
  22.  @compareitems:
  23. @@ -280,6 +280,9 @@
  24.    CallData: TPSList;
  25.    I: Integer;
  26.    pp: ^Byte;
  27. +{$IFDEF FPC}
  28. +  IsVirtualCons: Boolean;
  29. +{$ENDIF}
  30.  
  31.    function rp(p: PPSVariantIFC): PPSVariantIFC;
  32.    begin
  33. @@ -535,8 +538,10 @@
  34.            begin
  35.              GetMem(p, PointerSize2);
  36.              TMethod(p^) := MKMethod(Self, Longint(FVar.Dta^));
  37. -            StoreStack(p^, Pointersize2);
  38. -            FreeMem(p);
  39. +            //StoreStack(p^, Pointersize2);
  40. +            StoreReg(IPointer(p));
  41. +            //_RAX:=IPointer(TMethod(p^).Code);
  42. +            //FreeMem(p);
  43.            end;
  44.  
  45.          bts64:
  46. @@ -579,8 +584,21 @@
  47.  {$ENDIF}
  48.      _RAX := 0;
  49.      RegUsage := 0;
  50. +    {$IFDEF FPC}
  51. +    // FIX FOR FPC constructor calls
  52. +    if (Integer(CallingConv) and 128) <> 0 then begin
  53. +      IsVirtualCons := true;
  54. +    end else
  55. +      IsVirtualCons:= false;
  56. +    if IsVirtualCons then begin
  57. +      if not GetPtr(rp(Params[0])) then exit; // this goes first
  58. +      StoreReg(IPointer(_Self));
  59. +      Params.Delete(0);
  60. +    end else
  61. +    {$ENDIF}
  62.      if assigned(_Self) then begin
  63.        StoreReg(IPointer(_Self));
  64. +      //_RAX := IPointer(_Self);
  65.      end;
  66.  {$IFNDEF WINDOWS}
  67.      if assigned(res) and (res^.atype.basetype = btSingle) then begin
  68. Index: uPSRuntime.pas
  69. ===================================================================
  70. --- uPSRuntime.pas  (revision 38441)
  71. +++ uPSRuntime.pas  (working copy)
  72. @@ -11462,8 +11462,10 @@
  73.  {$ENDIF}
  74.  
  75.  {$ifdef fpc}
  76. -  {$if defined(cpupowerpc) or defined(cpuarm) or defined(cpu64)}
  77. +  {$if defined(cpupowerpc) or defined(cpuarm)}
  78.      {$define empty_methods_handler}
  79. +  {$elseif defined(cpu64)}
  80. +    {$define fpc_64_methods_handler}
  81.    {$ifend}
  82.  {$endif}
  83.  
  84. @@ -11473,9 +11475,352 @@
  85.  end;
  86.  {$else}
  87.  
  88. +{$ifdef fpc_64_methods_handler}
  89. +function SupportsRegister(b: TPSTypeRec): Boolean;
  90. +begin
  91. +  case b.BaseType of
  92. +    btU8,
  93. +    bts8,
  94. +    bts16,
  95. +    btu16,
  96. +    bts32,
  97. +    btu32,
  98. +    btstring,
  99. +    btclass,
  100. +{$IFNDEF PS_NOINTERFACES}
  101. +    btinterface,
  102. +{$ENDIF}
  103. +    btPChar,
  104. +{$IFNDEF PS_NOWIDESTRING}
  105. +    btwidestring,
  106. +    btUnicodeString,
  107. +    btWideChar,
  108. +{$ENDIF}
  109. +    btChar,
  110. +    btArray,
  111. +    btSingle,
  112. +    btDouble,
  113. +    btEnum: Result := true;
  114. +    btSet: Result := b.RealSize <= PointerSize;
  115. +    btStaticArray: Result := b.RealSize <= PointerSize;
  116. +  else
  117. +    Result := false;
  118. +  end;
  119. +end;
  120.  
  121. +function ResultAsRegister(b: TPSTypeRec): Boolean;
  122. +begin
  123. +  case b.BaseType of
  124. +    btSingle,
  125. +    btDouble,
  126. + //   btExtended,            <-- What about that??
  127. +    btU8,
  128. +    bts8,
  129. +    bts16,
  130. +    btu16,
  131. +    bts32,
  132. +    btu32,
  133. +{$IFDEF PS_FPCSTRINGWORKAROUND}
  134. +    btString,
  135. +{$ENDIF}
  136. +{$IFNDEF PS_NOINT64}
  137. +    bts64,
  138. +{$ENDIF}
  139. +    btPChar,
  140. +{$IFNDEF PS_NOWIDESTRING}
  141. +    btWideChar,
  142. +{$ENDIF}
  143. +    btChar,
  144. +    btclass,
  145. +    btEnum: Result := true;
  146. +    btSet: Result := b.RealSize <= PointerSize;
  147. +    btStaticArray: Result := b.RealSize <= PointerSize;
  148. +  else
  149. +    Result := false;
  150. +  end;
  151. +end;
  152. +
  153. +function AlwaysAsVariable(aType: TPSTypeRec): Boolean;
  154. +begin
  155. +  case atype.BaseType of
  156. +    btVariant: Result := true;
  157. +    btSet: Result := atype.RealSize > PointerSize;
  158. +    btRecord: Result := atype.RealSize > PointerSize;
  159. +    btStaticArray: Result := atype.RealSize > PointerSize;
  160. +  else
  161. +    Result := false;
  162. +  end;
  163. +end;
  164. +
  165. +function MyAllMethodsHandler2_64(Self: PScriptMethodInfo; const StackAndParams: Pointer): Integer;
  166. +type
  167. +  __PARAM_RECORD = packed record
  168. +    _xmm3_a, _xmm3_b: Pointer;
  169. +    _xmm2_a, _xmm2_b: Pointer;
  170. +    _xmm1_a, _xmm1_b: Pointer;
  171. +    _xmm0_a, _xmm0_b: Pointer;
  172. +    R9, R8, RDX, RCX, RAX: Pointer;
  173. +    Rest: array [0..0] of Pointer;
  174. +  end;
  175. +  PPARAM_RECORD = ^__PARAM_RECORD;
  176. +
  177. +var
  178. +  Decl: tbtString;
  179. +  I, C, regno: Integer;
  180. +  Params: TPSList;
  181. +  Res, Tmp: PIFVariant;
  182. +  cpt: PIFTypeRec;
  183. +  fmod: tbtchar;
  184. +  s,e: tbtString;
  185. +  FStack: pointer;
  186. +  ex: TPSExceptionHandler;
  187. +  paramRecord:PPARAM_RECORD;
  188. +begin
  189. +  //Get Declaration, i.e. Types & Number of Parameters
  190. +  Decl := TPSInternalProcRec(Self^.Se.FProcs[Self^.ProcNo]).ExportDecl;
  191. +
  192. +  paramRecord:=StackAndParams;
  193. +  FStack := @paramRecord^.Rest;
  194. +  Params := TPSList.Create;
  195. +  s := decl;
  196. +  grfw(s);
  197. +  //Add spare parameters
  198. +  while s <> '' do
  199. +  begin
  200. +    Params.Add(nil);
  201. +    grfw(s);
  202. +  end;
  203. +  c := Params.Count;
  204. +  regno := 0;
  205. +  Result := 0;
  206. +  s := decl;
  207. +  grfw(s);
  208. +
  209. +  //Fill parameters
  210. +  for i := c-1 downto 0 do
  211. +  begin
  212. +    //Get parameter Type and Param-Object
  213. +    e := grfw(s);
  214. +    fmod := e[1];
  215. +    delete(e, 1, 1);
  216. +    //Type of Parameter
  217. +    cpt := Self.Se.GetTypeNo(StrToInt(e));
  218. +    //--Pointers etc.
  219. +    if ((fmod = '%') or (fmod = '!') or (AlwaysAsVariable(cpt))) and (RegNo < 4) then
  220. +    begin
  221. +      tmp := CreateHeapVariant(self.Se.FindType2(btPointer));
  222. +      PPSVariantPointer(tmp).DestType := cpt;
  223. +      Params[i] := tmp;
  224. +      case regno of
  225. +        0: begin
  226. +            PPSVariantPointer(tmp).DataDest := paramRecord^.RCX;
  227. +            inc(regno);
  228. +          end;
  229. +        1: begin
  230. +            PPSVariantPointer(tmp).DataDest := paramRecord^.RDX;
  231. +            inc(regno);
  232. +          end;
  233. +        2: begin
  234. +            PPSVariantPointer(tmp).DataDest := paramRecord^.R8;
  235. +            inc(regno);
  236. +          end;
  237. +        3: begin
  238. +            PPSVariantPointer(tmp).DataDest := paramRecord^.R9;
  239. +            inc(regno);
  240. +          end;
  241. +      end;
  242. +    end
  243. +    //--all types of parameters that can be stored in registers
  244. +    else if SupportsRegister(cpt) and (RegNo < 4) then
  245. +    begin
  246. +      tmp := CreateHeapVariant(cpt);
  247. +      Params[i] := tmp;
  248. +      case regno of
  249. +        0: begin
  250. +            if (cpt.BaseType=btSingle) or (cpt.BaseType=btDouble) then
  251. +              CopyArrayContents(@PPSVariantData(tmp)^.Data, @paramRecord^._xmm0_a, 1, cpt)
  252. +            else
  253. +              CopyArrayContents(@PPSVariantData(tmp)^.Data, @paramRecord^.RCX, 1, cpt);
  254. +            inc(regno);
  255. +          end;
  256. +        1: begin
  257. +            if (cpt.BaseType=btSingle) or (cpt.BaseType=btDouble) then
  258. +              CopyArrayContents(@PPSVariantData(tmp)^.Data, @paramRecord^._xmm1_a, 1, cpt)
  259. +            else
  260. +              CopyArrayContents(@PPSVariantData(tmp)^.Data, @paramRecord^.RDX, 1, cpt);
  261. +            inc(regno);
  262. +          end;
  263. +        2: begin
  264. +            if (cpt.BaseType=btSingle) or (cpt.BaseType=btDouble) then
  265. +              CopyArrayContents(@PPSVariantData(tmp)^.Data, @paramRecord^._xmm2_a, 1, cpt)
  266. +            else
  267. +              CopyArrayContents(@PPSVariantData(tmp)^.Data, @paramRecord^.R8, 1, cpt);
  268. +            inc(regno);
  269. +          end;
  270. +        3: begin
  271. +            if (cpt.BaseType=btSingle) or (cpt.BaseType=btDouble) then
  272. +              CopyArrayContents(@PPSVariantData(tmp)^.Data, @paramRecord^._xmm3_a, 1, cpt)
  273. +            else
  274. +              CopyArrayContents(@PPSVariantData(tmp)^.Data, @paramRecord^.R9, 1, cpt) ;
  275. +            inc(regno);
  276. +          end;
  277. +      end;
  278. +    end;
  279. +  end;
  280. +  //Start over for Returnvalue
  281. +  s := decl;
  282. +  e := grfw(s);
  283. +  if e <> '-1' then
  284. +  begin
  285. +    cpt := Self.Se.GetTypeNo(StrToInt(e));
  286. +    if not ResultAsRegister(cpt) then
  287. +    begin
  288. +      Res := CreateHeapVariant(Self.Se.FindType2(btPointer));
  289. +      PPSVariantPointer(Res).DestType := cpt;
  290. +      Params.Add(Res);
  291. +      PPSVariantPointer(Res).DataDest := @paramRecord^.RAX;
  292. +    end{ else      //Are there return values on the Stack in x64 - probably yes, but how?
  293. +    begin
  294. +      Res := CreateHeapVariant(cpt);
  295. +      Params.Add(Res);
  296. +    end};
  297. +  end else Res := nil;
  298. +
  299. +  //Now push remaining parameters on the Stack
  300. +  s := decl;
  301. +  grfw(s);
  302. +  for i := 0 to c -1 do
  303. +  begin
  304. +    //Get type
  305. +    e := grlw(s);
  306. +    fmod := e[1];
  307. +    delete(e, 1, 1);
  308. +    //Already in a register?
  309. +    if Params[i] <> nil then Continue;
  310. +    cpt := Self.Se.GetTypeNo(StrToInt(e));
  311. +    //Pointer?
  312. +    if (fmod = '%') or (fmod = '!') or (AlwaysAsVariable(cpt)) then
  313. +    begin
  314. +      tmp := CreateHeapVariant(self.Se.FindType2(btPointer));
  315. +      PPSVariantPointer(tmp).DestType := cpt;
  316. +      Params[i] := tmp;
  317. +      PPSVariantPointer(tmp).DataDest := Pointer(FStack^);
  318. +      FStack := Pointer(IPointer(FStack) + PointerSize);
  319. +      Inc(Result, PointerSize);
  320. +    end
  321. +(*    else if SupportsRegister(cpt) then
  322. +    begin
  323. +      tmp := CreateHeapVariant(cpt);
  324. +      Params[i] := tmp;
  325. +      CopyArrayContents(@PPSVariantData(tmp)^.Data, Pointer(FStack), 1, cpt);
  326. +      FStack := Pointer(IPointer(FStack) + 4);
  327. +      end;
  328. +    end *)else
  329. +    begin
  330. +      tmp := CreateHeapVariant(cpt);
  331. +      Params[i] := tmp;
  332. +      CopyArrayContents(@PPSVariantData(tmp)^.Data, Pointer(FStack), 1, cpt);
  333. +      FStack := Pointer((IPointer(FStack) + cpt.RealSize + 3) and not 3);
  334. +      Inc(Result, (cpt.RealSize + 3) and not 3);
  335. +    end;
  336. +  end;
  337. +
  338. +  //Create exception handler and call the beast!
  339. +  ex := TPSExceptionHandler.Create;
  340. +  ex.FinallyOffset := InvalidVal;
  341. +  ex.ExceptOffset := InvalidVal;
  342. +  ex.Finally2Offset := InvalidVal;
  343. +  ex.EndOfBlock := InvalidVal;
  344. +  ex.CurrProc := nil;
  345. +  ex.BasePtr := Self.Se.FCurrStackBase;
  346. +  Ex.StackSize := Self.Se.FStack.Count;
  347. +  i :=  Self.Se.FExceptionStack.Add(ex);
  348. +  Self.Se.RunProc(Params, Self.ProcNo);
  349. +  if Self.Se.FExceptionStack[i] = ex then
  350. +  begin
  351. +    Self.Se.FExceptionStack.Remove(ex);
  352. +    ex.Free;
  353. +  end;
  354. +
  355. +  //Anything to return?
  356. +  if (Res <> nil) then
  357. +  begin
  358. +    Params.DeleteLast;
  359. +    if (ResultAsRegister(Res.FType)) then
  360. +    begin
  361. +      CopyArrayContents(@paramRecord^.RAX, @PPSVariantData(res)^.Data, 1, Res^.FType);
  362. +    end;
  363. +    DestroyHeapVariant(res);
  364. +  end;
  365. +
  366. +  //Free allocated data
  367. +  for i := 0 to Params.Count -1 do
  368. +    DestroyHeapVariant(Params[i]);
  369. +  Params.Free;
  370. +
  371. +  //Any exceptions?
  372. +  if Self.Se.ExEx <> erNoError then
  373. +  begin
  374. +    if Self.Se.ExObject <> nil then
  375. +    begin
  376. +      FStack := Self.Se.ExObject;
  377. +      Self.Se.ExObject := nil;
  378. +      raise TObject(FStack);
  379. +    end else
  380. +      raise EPSException.Create(PSErrorToString(Self.SE.ExceptionCode, Self.Se.ExceptionString), Self.Se, Self.Se.ExProc, Self.Se.ExPos);
  381. +  end;
  382. +end;
  383. +
  384. +procedure MyAllMethodsHandler;
  385. +asm
  386. +  push rbp
  387. +  mov rbp,rsp
  388. +  push rax  // for eventual result values...
  389. +  push rcx  // SELF
  390. +  push rdx  // PARAM 1  (bossibly)
  391. +  push r8   // PARAM 2
  392. +  push r9   // PARAM 3
  393. +  sub rsp, 16
  394. +  movdqu [rsp], xmm0
  395. +  sub rsp, 16
  396. +  movdqu [rsp], xmm1
  397. +  sub rsp, 16
  398. +  movdqu [rsp], xmm2
  399. +  sub rsp, 16
  400. +  movdqu [rsp], xmm3
  401. +
  402. +  mov rdx, rsp
  403. +
  404. +  sub RSP, 32    //Create Savehouse for storing registers...
  405. +
  406. +  call MyAllMethodsHandler2_64
  407. +
  408. +  add RSP, 32
  409. +
  410. +  movdqu xmm3, [rsp]
  411. +  add rsp, 16
  412. +  movdqu xmm2, [rsp]
  413. +  add rsp, 16
  414. +  movdqu xmm1, [rsp]
  415. +  add rsp, 16
  416. +  movdqu xmm0, [rsp]
  417. +  add rsp, 16
  418. +  pop r9
  419. +  pop r8
  420. +  pop rdx
  421. +  pop rcx
  422. +  pop rax
  423. +
  424. +  leave
  425. +
  426. +  add rsp, 8 //cleanup stackframe generated by FPC
  427. +  ret
  428. +end;
  429. +{$else}
  430. +
  431.  function MyAllMethodsHandler2(Self: PScriptMethodInfo; const Stack: PPointer; _EDX, _ECX: Pointer): Integer; forward;
  432.  
  433. +
  434.  procedure MyAllMethodsHandler;
  435.  //  On entry:
  436.  //     EAX = Self pointer
  437. @@ -11781,7 +12126,9 @@
  438.        raise EPSException.Create(PSErrorToString(Self.SE.ExceptionCode, Self.Se.ExceptionString), Self.Se, Self.Se.ExProc, Self.Se.ExPos);
  439.    end;
  440.  end;
  441. -{$endif}
  442. +{$endif} //fpc_64_method_handler
  443. +{$endif} //empty_method_handler
  444. +
  445.  function TPSRuntimeClassImporter.FindClass(const Name: tbtString): TPSRuntimeClass;
  446.  var
  447.    h, i: Longint;
RAW Paste Data