palmos: fixed startup code to properly relocate the data segment when requested by the OS

git-svn-id: trunk@37893 -

rtl/palmos/palmos.inc

@@ -20,6 +20,10 @@ type
   Err = Word;
   DmOpenRef = Pointer;
 
+type
+  DmResType = UInt32;
+  DmResID = UInt16;
+
 type
   SysAppInfoTag = record
     cmd: Int16;            // command code for app
@@ -52,6 +56,15 @@ type
 const
   sysAppLaunchCmdNormalLaunch = 0;
 
+const
+  sysAppLaunchFlagNewThread = $01;  // create a new thread for application
+                                    //  - implies sysAppLaunchFlagNewStack
+  sysAppLaunchFlagNewStack = $02;   // create separate stack for application
+  sysAppLaunchFlagNewGlobals = $04; // create new globals world for application
+                                    //  - implies new owner ID for Memory chunks
+  sysAppLaunchFlagUIApp = $08;      // notifies launch routine that this is a UI app being
+                                    //  launched.
+
 const
   sysTrapSysAppStartup = $A08F;
   sysTrapSysAppExit = $A090;
@@ -68,8 +81,24 @@ procedure SndPlaySystemSound(beepID: Word); syscall sysTrapSndPlaySystemSound;
 const
   sysTrapMemChunkFree = $A012;
   sysTrapMemPtrNew = $A013;
+  sysTrapMemHandleLock = $A021;
+  sysTrapMemHandleUnlock = $A022;
 
 function MemPtrNew(size: UInt32): MemPtr; syscall sysTrapMemPtrNew;
 function MemPtrFree(chunkDataP: MemPtr): Err; syscall sysTrapMemChunkFree;
+function MemHandleLock(h: MemHandle): MemPtr; syscall sysTrapMemHandleLock;
+function MemHandleUnlock(h: MemHandle): Err; syscall sysTrapMemHandleUnlock;
+
+const
+  sysTrapDmGet1Resource = $A060;
+  sysTrapDmReleaseResource = $A061;
+
+function DmGet1Resource(type_: DmResType; resID: DmResID): MemHandle; syscall sysTrapDmGet1Resource;
+function DmReleaseResource(resourceH: MemHandle): Err; syscall sysTrapDmReleaseResource;
+
+const
+  sysTrapWinDrawChars = $A220;
+
+procedure WinDrawChars(const chars: PChar; len: SmallInt; x, y: SmallInt); syscall sysTrapWinDrawChars;
 
 {$PACKRECORDS DEFAULT}

rtl/palmos/si_prc.pp

@@ -12,7 +12,7 @@
     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 
  **********************************************************************}
-
+{$SMARTLINK OFF}
 unit si_prc;
 
 interface
@@ -27,27 +27,39 @@ var
   sysinit_jmpbuf: jmp_buf;
   ExitCode: LongInt;
 
+var
+  { this is declared by the PalmOS linker script }
+  data_start: pbyte; external name 'data_start';
+
 
 procedure PascalMain; external name 'PASCALMAIN';
+procedure FPCRelocateData; forward;
 
 
 { this function must be the first in this unit which contains code }
 function _FPC_proc_start: longint; cdecl; public name '_start';
 var
+  locAppInfo: SysAppInfoPtr;
   prevGlobals: Pointer;
   globalsPtr: Pointer;
 begin
-  if SysAppStartup(appInfo, prevGlobals, globalsPtr) <> 0 then
+  if SysAppStartup(locAppInfo, prevGlobals, globalsPtr) <> 0 then
     begin
       SndPlaySystemSound(sndError);
       exit(-1);
     end;
 
+  if (locAppInfo^.launchFlags and sysAppLaunchFlagNewGlobals) > 0 then
+    FPCRelocateData;
+
   if setjmp(sysinit_jmpbuf) = 0 then
-    PascalMain;
+    begin
+      appInfo:=locAppInfo;
+      PascalMain;
+    end;
 
-  SysAppExit(appInfo, prevGlobals, globalsPtr);
   _FPC_proc_start:=ExitCode;
+  SysAppExit(locAppInfo, prevGlobals, globalsPtr);
 end;
 
 procedure _FPC_proc_halt(_ExitCode: longint); cdecl; public name '_haltproc';
@@ -56,4 +68,49 @@ begin
   longjmp(sysinit_jmpbuf,1);
 end;
 
+{ data segment relocation magic, ported to Pascal from prc-tools C version }
+type
+  PReloc = ^TReloc;
+  TReloc = record
+    case boolean of
+      true: ( next: smallint; addend: word );
+      false: ( value: dword );
+  end;
+
+procedure RelocateChain(offset: smallint; base: pointer);
+var
+  data_res: pbyte;
+  site: PReloc;
+begin
+  data_res:=@data_start;
+
+  while offset >= 0 do
+    begin
+      site:=PReloc(data_res + offset);
+      offset:=site^.next;
+      site^.next:=0;
+      site^.value:=site^.value + PtrUInt(base);
+    end;
+end;
+
+procedure FPCRelocateData;
+var
+  relocH: MemHandle;
+  chain: psmallint;
+const
+  rloc_id = $726c6f63; // 'rloc'
+begin
+  relocH:=DmGet1Resource(rloc_id, 0);
+  if relocH <> nil then
+    begin
+      chain:=MemHandleLock(relocH);
+      RelocateChain(chain^, @data_start);
+      Inc(chain);
+      RelocateChain(chain^, @_FPC_proc_start);
+      Inc(chain);
+      MemHandleUnlock(relocH);
+      DmReleaseResource(relocH);
+    end;
+end;
+
 end.

rtl/palmos/system.pp

@@ -143,16 +143,16 @@ begin
 end;
 
 begin
+  StackLength := CheckInitialStkLen(InitialStkLen);
+{ Initialize ExitProc }
+  ExitProc:=Nil;
+
   { we don't support anything but normal startup now }
   { FIXME: lets figure it out how various startup modes }
   { can coexist with the system unit infrastructure (KB) }
   if not (palmAppInfo^.cmd = sysAppLaunchCmdNormalLaunch) then
     halt(0);
 
-  StackLength := CheckInitialStkLen(InitialStkLen);
-{ Initialize ExitProc }
-  ExitProc:=Nil;
-
   SysInitExceptions;
 {$ifdef FPC_HAS_FEATURE_UNICODESTRINGS}
   InitUnicodeStringManager;