Arm support for PS by Henry Vermaak (henry.vermaak@gmail.com)

git-svn-id: http://code.remobjects.com/svn/pascalscript@94 5c9d2617-0215-0410-a2ee-e80e04d1c6d8

Source/arm.inc

@@ -0,0 +1,280 @@
+{ implementation of the arm procedure call standard for function calls in pascal script
+  Copyright (c) 2008 by Henry Vermaak (henry.vermaak@gmail.com) 
+  
+  todo: add eabi (define FPC_ABI_EABI) and wince support }
+
+const
+  rtINT = 0;
+  rtINT64 = 1;
+  rtFLOAT = 2;
+
+type
+  Trint = array[1..4] of dword;
+  Trfloat = array[1..4] of double;
+
+{$goto on}
+{ define labels }
+label
+  stack_loop,
+  load_regs,
+  asmcall_end,
+  int_result,
+  int64_result,
+  float_result;
+
+{ call a function from a pointer }
+{ resulttype: 0 = int, 1 = int64, 2 = float }
+function armasmcall(rint: Trint; rfloat: Trfloat; proc, stack: pointer; stacksize, resulttype: integer): pointer; assembler; nostackframe;
+asm
+	mov	r12, r13
+	stmfd	r13!, {r4, r5, r6, r7, r8, r9, r10, r11, r12, r14, r15}
+	sub	r11, r12, #4
+	mov	r4, #80			(* space for preserved registers and parameters *)
+	ldr	r5, [r11, #4]		(* stacksize we need for subroutine *)
+	add	r4, r4, r5
+	sub	r13, r13, r4		(* create stack space *)
+
+	(* store parameters on stack *)
+	str	r0, [r11, #-44]		(* rint *)
+	str	r1, [r11, #-48]		(* rfloat *)
+	str	r2, [r11, #-52]		(* proc *)
+	str	r3, [r11, #-56] 	(* stack *)
+	ldr	r0, [r11, #4]		
+	str	r0, [r11, #-60]		(* stacksize *)
+	ldr	r0, [r11, #8]		
+	str	r0, [r11, #-64]		(* resulttype *)
+
+	(* store params for sub-routine that don't fit into r0-r3 at start of stack *)
+	ldr	r0, [r11, #-60]		(* stacksize *)
+	cmp	r0, #0
+	beq	load_regs		(* skip if no stack *)
+	mov	r1, r13			(* this points to the bottom now *)
+	ldr	r2, [r11, #-56]		(* stack pointer *)
+stack_loop:
+	ldmia	r2!, {r4}		(* get stack + update pos *)
+	stmia	r1!, {r4}		(* store stack + update pos *)
+	subs	r0, r0, #4
+	bne	stack_loop
+
+load_regs:
+	(* load general regs *)
+	ldr	r4, [r11, #-44]	(* rint *)
+	ldr	r0, [r4]
+	ldr	r1, [r4, #4]
+	ldr	r2, [r4, #8]
+	ldr	r3, [r4, #12]
+
+{$ifdef FPUFPA}
+	(* load float regs *)
+	ldr	r4, [r11, #-48]	(* rfloat *)
+	ldfd	f0, [r4]
+	ldfd	f1, [r4, #8]
+	ldfd	f2, [r4, #16]
+	ldfd	f3, [r4, #24]
+{$endif}
+
+	(* branch to the proc pointer *)
+	ldr	r4, [r11, #-52]
+	mov	r14, r15
+	mov	r15, r4
+(*	blx	r4  *)
+
+	ldr	r4, [r11, #-64]		(* get resulttype *)
+	cmp	r4, #1
+	blt	int_result
+	beq	int64_result
+	bgt	float_result
+
+int_result:
+	str	r0, [r11, #-72]
+	b	asmcall_end
+
+int64_result:
+	str	r0, [r11, #-72]
+	str	r1, [r11, #-68]
+	b	asmcall_end
+
+float_result:
+{$ifdef FPUFPA}
+	stfd	f0, [r11, #-72]
+{$else}
+	b	int64_result
+{$endif}
+	b	asmcall_end
+
+asmcall_end:
+	sub	r0, r11, #72		(* return pointer to result on stack *)
+	
+	ldmea	r11,{r4,r5,r6,r7,r8,r9,r10,r11,r13,r15}
+end;
+
+function TPSExec.InnerfuseCall(_Self, Address: Pointer; CallingConv: TPSCallingConvention; Params: TPSList; res: PPSVariantIFC): Boolean;
+var
+  rint: Trint;			{ registers r0 to r3 }
+  rfloat: Trfloat;		{ registers f0 to f3 }
+  st: packed array of byte;	{ stack }
+  i, j, rindex, findex, stindex: integer;
+  fvar: PPSVariantIFC;
+
+  { add a dword to stack }
+  procedure addstackdword(value: dword);
+  begin
+    setlength(st, stindex+4);
+    pdword(@st[stindex])^ := value;
+    inc(stindex, 4);
+  end;
+
+  { add a float to stack }
+  procedure addstackfloat(value: pointer; size: integer);
+  begin
+    setlength(st, stindex + (size * 4));
+    if size = 1
+      then psingle(@st[stindex])^ := single(value^)
+      else pdouble(@st[stindex])^ := double(value^);
+    inc(stindex, size*4);
+  end;
+
+  { add to the general registers or overflow to stack }
+  procedure addgen(value: dword);
+  begin
+    if rindex <= 4
+      then begin
+        rint[rindex] := value;
+        inc(rindex);
+      end
+      else begin
+        addstackdword(value);
+      end;
+  end;
+  { add to the float registers or overflow to stack }
+  { size = 1 for single, 2 for double }
+  procedure addfloat(value: pointer; size: integer);
+  begin
+    if findex <= 4
+      then begin
+        if size = 1
+          then rfloat[findex] := single(value^)
+          else rfloat[findex] := double(value^);
+        inc(findex);
+      end
+      else begin
+        addstackfloat(value, size);
+      end;
+  end;
+
+begin
+  rindex := 1;
+  findex := 1;
+  stindex := 0;
+  setlength(st, stindex);
+  Result := False;
+
+  { the pointer of the result needs to be passed first in the case of some result types }
+  if assigned(res)
+    then begin
+      case res.atype.basetype of
+        btStaticArray, btRecord: addgen(dword(res.dta));
+      end;
+    end;
+
+  { process all parameters }
+  for i := 0 to Params.Count-1 do begin
+    if Params[i] = nil
+      then Exit;
+    fvar := Params[i];
+
+    { cook dynamic arrays - fpc stores size-1 at @array-4 }
+    if (fvar.aType.BaseType = btArray)
+      then dec(pdword(pointer(fvar.dta^)-4)^);
+
+    if fvar.varparam
+      then begin  { var param }
+        case fvar.aType.BaseType of
+          { add var params here }
+          btArray, btVariant, btSet, btStaticArray, btRecord, btInterface, btClass, {$IFNDEF PS_NOWIDESTRING} btWideString, btWideChar, {$ENDIF}
+          btU8, btS8, btU16, btS16, btU32, btS32, btSingle, btDouble, btExtended, btString, btPChar, btChar, btCurrency
+          {$IFNDEF PS_NOINT64}, bts64{$ENDIF}: addgen(dword(fvar.dta));
+          else begin
+            writeln(stderr, 'Parameter type not recognised!');
+            Exit;
+          end;
+        end;  { case }
+      end else begin  { not a var param }
+        case fvar.aType.BaseType of
+//          btArray, btVariant, btSet, btStaticArray, btRecord, btInterface, btClass, {$IFNDEF PS_NOWIDESTRING} btWideString, btWideChar, {$ENDIF}
+//          btU8, btS8, btU16, btS16, btU32, btS32, btSingle, btDouble, btExtended, btString, btPChar, btChar, btCurrency
+//          {$IFNDEF PS_NOINT64}, bts64{$ENDIF}: writeln('normal param');
+
+          { add normal params here }
+          btString:                            addgen(dword(pstring(fvar.dta)^));
+          btU8, btS8:                          addgen(dword(pbyte(fvar.dta)^));
+          btU16, BtS16:                        addgen(dword(pword(fvar.dta)^));
+          btU32, btS32:                        addgen(dword(pdword(fvar.dta)^));
+          btSingle:                            {$ifdef FPUFPA}
+	                                         addfloat(fvar.dta, 1);
+	                                       {$else}
+					         addgen(dword(psingle(fvar.dta)^));
+					       {$endif}
+          btDouble{, btExtended}:              {$ifdef FPUFPA}
+	                                         addfloat(fvar.dta, 2);
+	                                       {$else}
+					         begin
+					           addgen(lo(qword(pdouble(fvar.dta)^)));
+					           addgen(hi(qword(pdouble(fvar.dta)^)));
+						 end;
+					       {$endif}
+          btPChar:                             addgen(dword(ppchar(fvar.dta)^));
+          btChar:                              addgen(dword(pchar(fvar.dta)^));
+          {$IFNDEF PS_NOINT64}bts64:{$ENDIF}   begin
+                                                 addgen(dword(pint64(fvar.dta)^ and $ffffffff));
+                                                 addgen(dword(pint64(fvar.dta)^ shr 32));
+                                               end;
+          btStaticArray:                       addgen(dword(fvar.dta));
+          btRecord:                            for j := 0 to (fvar.atype.realsize div 4)-1 do
+                                                 addgen(pdword(fvar.dta + j*4)^);
+          btArray:                             addstackdword(dword(fvar.dta^));  { this is a bit weird }
+
+{          btVariant, btSet, btInterface, btClass  }
+
+          else begin
+            writeln(stderr, 'Parameter type not implemented!');
+            Exit;
+          end;
+        end;  { case }
+      end;  { else }
+  end;  { for }
+
+  if not assigned(res)
+    then begin
+      armasmcall(rint, rfloat, address, st, stindex, rtINT);  { ignore return }
+    end
+    else begin
+      case res.atype.basetype of
+        { add result types here }
+        btString:                pstring(res.dta)^ := pstring(armasmcall(rint, rfloat, address, st, stindex, rtINT))^;
+        btU8, btS8:              pbyte(res.dta)^ := byte(pdword(armasmcall(rint, rfloat, address, st, stindex, rtINT))^);
+        btU16, btS16:            pword(res.dta)^ := word(pdword(armasmcall(rint, rfloat, address, st, stindex, rtINT))^);
+        btU32, btS32:            pdword(res.dta)^ := pdword(armasmcall(rint, rfloat, address, st, stindex, rtINT))^;
+        btSingle:                psingle(res.dta)^ := pdouble(armasmcall(rint, rfloat, address, st, stindex, rtFLOAT))^;
+        btDouble{, btExtended}:  pdouble(res.dta)^ := pdouble(armasmcall(rint, rfloat, address, st, stindex, rtFLOAT))^;
+        btPChar:                 ppchar(res.dta)^ := pchar(pdword(armasmcall(rint, rfloat, address, st, stindex, rtINT))^);
+        btChar:                  pchar(res.dta)^ := char(pdword(armasmcall(rint, rfloat, address, st, stindex, rtINT))^);
+        btStaticArray, btRecord: armasmcall(rint, rfloat, address, st, stindex, rtINT);
+        btArray:                 res.dta := armasmcall(rint, rfloat, address, st, stindex, rtINT);
+
+        else begin
+          writeln(stderr, 'Result type not implemented!');
+          exit;
+        end;  { else }
+      end;  { case }
+    end;
+
+  { cook dynamic arrays - fpc stores size-1 at @array-4 }
+  for i := 0 to Params.Count-1 do begin
+    fvar := Params[i];
+    if (fvar.aType.BaseType = btArray)
+      then inc(pdword(pointer(fvar.dta^)-4)^);
+   end;
+
+  Result := True;
+end;

Source/uPSCompiler.pas

@@ -9740,7 +9740,11 @@ begin
       BlockWriteByte(BlockInfo, Cm_G);
       BlockWriteLong(BlockInfo, $12345678);
       EPos := Length(BlockInfo.Proc.Data);
+      {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+      unaligned(Longint((@BlockInfo.Proc.Data[SPos - 3])^)) := Length(BlockInfo.Proc.Data) - Longint(SPos);
+      {$else}
       Longint((@BlockInfo.Proc.Data[SPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(SPos);
+      {$endif}
       FParser.Next;
       Block := TPSBlockInfo.Create(BlockInfo);
       Block.SubType := tOneLiner;

Source/uPSRuntime.pas

@@ -2275,7 +2275,11 @@ var
                 Result := False;
                 exit;;
               end;
+	      {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+              PPSVariantU32(varp)^.Data := unaligned(Cardinal((@FData^[FCurrentPosition])^));
+	      {$else}
               PPSVariantU32(varp)^.Data := Cardinal((@FData^[FCurrentPosition])^);
+	      {$endif}
               Inc(FCurrentPosition, 4);
             end;
           btProcPtr:
@@ -2287,7 +2291,11 @@ var
                 Result := False;
                 exit;;
               end;
+	      {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+              PPSVariantU32(varp)^.Data := unaligned(Cardinal((@FData^[FCurrentPosition])^));
+	      {$else}
               PPSVariantU32(varp)^.Data := Cardinal((@FData^[FCurrentPosition])^);
+	      {$endif}
               if PPSVariantU32(varp)^.Data = 0 then
               begin
                 PPSVariantProcPtr(varp)^.Ptr := nil;
@@ -6066,7 +6074,11 @@ begin
   end;
   VarType := FData^[FCurrentPosition];
   Inc(FCurrentPosition);
+  {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+  Param := unaligned(Cardinal((@FData^[FCurrentPosition])^));
+  {$else}
   Param := Cardinal((@FData^[FCurrentPosition])^);
+  {$endif}
   Inc(FCurrentPosition, 4);
   case VarType of
     0:
@@ -6171,7 +6183,11 @@ begin
                 Result := False;
                 exit;
               end;
+	      {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+              tbtu16(dest.p^) := unaligned(tbtu16((@FData^[FCurrentPosition])^));
+	      {$else}
               tbtu16(dest.p^) := tbtu16((@FData^[FCurrentPosition])^);
+	      {$endif}
               Inc(FCurrentPosition, 2);
             end;
           bts32, btU32:
@@ -6183,7 +6199,11 @@ begin
                 Result := False;
                 exit;
               end;
+	      {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+              tbtu32(dest.p^) := unaligned(tbtu32((@FData^[FCurrentPosition])^));
+	      {$else}
               tbtu32(dest.p^) := tbtu32((@FData^[FCurrentPosition])^);
+	      {$endif}
               Inc(FCurrentPosition, 4);
             end;
           btProcPtr:
@@ -6195,7 +6215,11 @@ begin
                 Result := False;
                 exit;
               end;
+	      {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+              tbtu32(dest.p^) := unaligned(tbtu32((@FData^[FCurrentPosition])^));
+	      {$else}
               tbtu32(dest.p^) := tbtu32((@FData^[FCurrentPosition])^);
+	      {$endif}
               tbtu32(Pointer(IPointer(dest.p)+4)^) := 0;
               tbtu32(Pointer(IPointer(dest.p)+8)^) := 0;
               Inc(FCurrentPosition, 4);
@@ -6210,7 +6234,11 @@ begin
                 Result := False;
                 exit;
               end;
+	      {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+              tbts64(dest.p^) := unaligned(tbts64((@FData^[FCurrentPosition])^));
+	      {$else}
               tbts64(dest.p^) := tbts64((@FData^[FCurrentPosition])^);
+	      {$endif}
               Inc(FCurrentPosition, 8);
             end;
           {$ENDIF}
@@ -6223,7 +6251,11 @@ begin
                 Result := False;
                 exit;
               end;
+	      {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+              tbtsingle(dest.p^) := unaligned(tbtsingle((@FData^[FCurrentPosition])^));
+	      {$else}
               tbtsingle(dest.p^) := tbtsingle((@FData^[FCurrentPosition])^);
+	      {$endif}
               Inc(FCurrentPosition, Sizeof(Single));
             end;
           btDouble:
@@ -6235,7 +6267,11 @@ begin
                 Result := False;
                 exit;
               end;
+	      {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+              tbtdouble(dest.p^) := unaligned(tbtdouble((@FData^[FCurrentPosition])^));
+	      {$else}
               tbtdouble(dest.p^) := tbtdouble((@FData^[FCurrentPosition])^);
+	      {$endif}
               Inc(FCurrentPosition, Sizeof(double));
             end;
 
@@ -6248,7 +6284,11 @@ begin
                 Result := False;
                 exit;
               end;
+	      {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+              tbtextended(dest.p^) := unaligned(tbtextended((@FData^[FCurrentPosition])^));
+	      {$else}
               tbtextended(dest.p^) := tbtextended((@FData^[FCurrentPosition])^);
+	      {$endif}
               Inc(FCurrentPosition, sizeof(Extended));
             end;
           btPchar, btString:
@@ -6260,7 +6300,11 @@ begin
                 Result := False;
                 exit;
               end;
+	      {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+              Param := unaligned(Cardinal((@FData^[FCurrentPosition])^));
+	      {$else}
               Param := Cardinal((@FData^[FCurrentPosition])^);
+	      {$endif}
               Inc(FCurrentPosition, 4);
               Pointer(Dest.P^) := nil;
               SetLength(tbtstring(Dest.P^), Param);
@@ -6282,7 +6326,11 @@ begin
                 Result := False;
                 exit;
               end;
+	      {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+              Param := unaligned(Cardinal((@FData^[FCurrentPosition])^));
+	      {$else}
               Param := Cardinal((@FData^[FCurrentPosition])^);
+	      {$endif}
               Inc(FCurrentPosition, 4);
               Pointer(Dest.P^) := nil;
               SetLength(tbtwidestring(Dest.P^), Param);
@@ -6346,7 +6394,11 @@ begin
           Result := False;
           exit;
         end;
+	{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+        Param := unaligned(Cardinal((@FData^[FCurrentPosition])^));
+	{$else}
         Param := Cardinal((@FData^[FCurrentPosition])^);
+	{$endif}
         Inc(FCurrentPosition, 4);
         case Dest.aType.BaseType of
           btRecord:
@@ -6437,7 +6489,11 @@ begin
           Dest.aType := PPSVariantData(Tmp).vi.FType;
           Dest.P := @PPSVariantData(Tmp).Data;
         end;
+	{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+        Param := unaligned(Cardinal((@FData^[FCurrentPosition])^));
+	{$else}
         Param := Cardinal((@FData^[FCurrentPosition])^);
+	{$endif}
         Inc(FCurrentPosition, 4);
         if Param < PSAddrNegativeStackStart then
         begin
@@ -6640,7 +6696,11 @@ end;
 function TPSExec.ReadLong(var b: Cardinal): Boolean;
 begin
   if FCurrentPosition + 3 < FDataLength then begin
+    {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+    b := unaligned(Cardinal((@FData^[FCurrentPosition])^));
+    {$else}
     b := Cardinal((@FData^[FCurrentPosition])^);
+    {$endif}
     Inc(FCurrentPosition, 4);
     Result := True;
   end
@@ -7446,7 +7506,11 @@ begin
                 Cmd_Err(erOutOfRange);
                 Break;
               end;
+	      {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+              p := unaligned(Cardinal((@FData^[FCurrentPosition])^));
+	      {$else}
               p := Cardinal((@FData^[FCurrentPosition])^);
+	      {$endif}
               Inc(FCurrentPosition, 4);
               if p >= FProcs.Count then begin
                 CMD_Err(erOutOfProcRange);
@@ -7521,7 +7585,11 @@ begin
                 Cmd_Err(erOutOfRange);
                 Break;
               end;
+	      {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+              p := unaligned(Cardinal((@FData^[FCurrentPosition])^));
+	      {$else}
               p := Cardinal((@FData^[FCurrentPosition])^);
+	      {$endif}
               Inc(FCurrentPosition, 4);
               FCurrentPosition := FCurrentPosition + p;
             end;
@@ -7534,7 +7602,11 @@ begin
                 Cmd_Err(erOutOfRange);
                 Break;
               end;
+	      {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+              p := unaligned(Cardinal((@FData^[FCurrentPosition])^));
+	      {$else}
               p := Cardinal((@FData^[FCurrentPosition])^);
+	      {$endif}
               Inc(FCurrentPosition, 4);
               FCurrentPosition := FCurrentPosition + p;
             end;
@@ -7545,7 +7617,11 @@ begin
                 Cmd_Err(erOutOfRange);
                 Break;
               end;
+	      {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+              p := unaligned(Cardinal((@FData^[FCurrentPosition])^));
+	      {$else}
               p := Cardinal((@FData^[FCurrentPosition])^);
+	      {$endif}
               Inc(FCurrentPosition, 4);
               FCurrentPosition := FCurrentPosition + p;
             end;
@@ -7556,7 +7632,11 @@ begin
                 Cmd_Err(erOutOfRange);
                 Break;
               end;
+	      {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+              p := unaligned(Cardinal((@FData^[FCurrentPosition])^));
+	      {$else}
               p := Cardinal((@FData^[FCurrentPosition])^);
+	      {$endif}
               Inc(FCurrentPosition, 4);
               btemp := true;
               if not ReadVariable(vs, btemp) then
@@ -7587,7 +7667,11 @@ begin
                 Cmd_Err(erOutOfRange);
                 Break;
               end;
+	      {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+              p := unaligned(Cardinal((@FData^[FCurrentPosition])^));
+	      {$else}
               p := Cardinal((@FData^[FCurrentPosition])^);
+	      {$endif}
               Inc(FCurrentPosition, 4);
               btemp := true;
               if not ReadVariable(vs, BTemp) then
@@ -7680,7 +7764,11 @@ begin
                 Cmd_Err(erOutOfRange);
                 Break;
               end;
+	      {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+              p := unaligned(Cardinal((@FData^[FCurrentPosition])^));
+	      {$else}
               p := Cardinal((@FData^[FCurrentPosition])^);
+	      {$endif}
               Inc(FCurrentPosition, 4);
               if p > FTypes.Count then
               begin
@@ -7755,7 +7843,11 @@ begin
                 Cmd_Err(erOutOfRange);
                 Break;
               end;
+	      {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+              p := unaligned(Cardinal((@FData^[FCurrentPosition])^));
+	      {$else}
               p := Cardinal((@FData^[FCurrentPosition])^);
+	      {$endif}
               Inc(FCurrentPosition, 4);
               if FJumpFlag then
                 FCurrentPosition := FCurrentPosition + p;
@@ -9159,6 +9251,8 @@ end;
     {$include x86.inc}
   {$elseif defined(cpupowerpc)}
     {$include powerpc.inc}
+  {$elseif defined(cpuarm)}
+    {$include arm.inc}
   {$else}
     {$fatal Pascal Script is not supported for your architecture at the moment!}
   {$ifend}
@@ -10830,11 +10924,12 @@ begin
 end;
 
 {$ifdef fpc}
-  {$if defined(cpupowerpc)}
+  {$if defined(cpupowerpc) or defined(cpuarm)}
-    {$define ppc}
+    {$define empty_methods_handler}
   {$ifend}
 {$endif}
-{$ifdef ppc}
+
+{$ifdef empty_methods_handler}
 procedure MyAllMethodsHandler;
 begin
 end;