From c8a3171dc9833e1a410d63f6c5c1c03bd83328c9 Mon Sep 17 00:00:00 2001 From: florian Date: Sat, 31 Aug 2002 21:29:57 +0000 Subject: [PATCH] * several PC related fixes --- rtl/linux/powerpc/prt0.as | 149 +-- rtl/powerpc/powerpc.inc | 2033 +++++++++++++++++++------------------ rtl/unix/sysunix.inc | 1761 ++++++++++++++++---------------- 3 files changed, 1976 insertions(+), 1967 deletions(-) diff --git a/rtl/linux/powerpc/prt0.as b/rtl/linux/powerpc/prt0.as index b50ca590f4..b1d48b2568 100644 --- a/rtl/linux/powerpc/prt0.as +++ b/rtl/linux/powerpc/prt0.as @@ -1,74 +1,77 @@ -/* Startup code for programs linked with GNU libc. - Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc. - This file is part of the GNU C Library. - - The GNU C Library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License as published by the Free Software Foundation; either - version 2.1 of the License, or (at your option) any later version. - - The GNU C Library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with the GNU C Library; if not, write to the Free - Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA - 02111-1307 USA. */ - - .section ".text" - .globl _start -_start: - /* Save the stack pointer, in case we're statically linked under Linux. */ - mr 9,1 - /* Set up an initial stack frame, and clear the LR. */ - clrrwi 1,1,4 - li 0,0 - stwu 1,-16(1) - mtlr 0 - stw 0,0(1) - bl PASCALMAIN - - .globl _haltproc - .type _haltproc,@function -_haltproc: - li 0,1 /* exit call */ - lis 3,U_SYSTEM_EXITCODE@h - stw 3,U_SYSTEM_EXITCODE@l(3) - sc - b _haltproc - - /* Define a symbol for the first piece of initialized data. */ - .section ".data" - .globl __data_start -__data_start: -data_start: - .globl ___fpc_brk_addr /* heap management */ - .type ___fpc_brk_addr,@object - .size ___fpc_brk_addr,4 -___fpc_brk_addr: - .long 0 -/* +/* Startup code for programs linked with GNU libc. + Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc. + This file is part of the GNU C Library. + + The GNU C Library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + The GNU C Library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with the GNU C Library; if not, write to the Free + Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA + 02111-1307 USA. */ + + .section ".text" + .globl _start +_start: + /* Save the stack pointer, in case we're statically linked under Linux. */ + mr 9,1 + /* Set up an initial stack frame, and clear the LR. */ + clrrwi 1,1,4 + li 0,0 + stwu 1,-16(1) + mtlr 0 + stw 0,0(1) + bl PASCALMAIN + + .globl _haltproc + .type _haltproc,@function +_haltproc: + li 0,1 /* exit call */ + lis 3,U_SYSTEM_EXITCODE@h + stw 3,U_SYSTEM_EXITCODE@l(3) + sc + b _haltproc + + /* Define a symbol for the first piece of initialized data. */ + .section ".data" + .globl __data_start +__data_start: +data_start: + .globl ___fpc_brk_addr /* heap management */ + .type ___fpc_brk_addr,@object + .size ___fpc_brk_addr,4 +___fpc_brk_addr: + .long 0 +/* $Log$ - Revision 1.7 2002-08-31 16:13:12 florian - * made _start global - - Revision 1.6 2002/08/31 14:02:23 florian - * r3 renamed to 3 - - Revision 1.5 2002/08/31 14:01:28 florian - * _haltproc to prt0.as added (Linux/PPC) - - Revision 1.4 2002/08/31 13:11:11 florian - * several fixes for Linux/PPC compilation - - Revision 1.3 2002/08/19 21:19:15 florian - * small fixes - - Revision 1.2 2002/07/26 17:09:44 florian - * log fixed - - Revision 1.1 2002/07/26 16:57:40 florian - + initial version, plain copy from glibc/sysdeps/powerpc/elf/start.S -*/ + Revision 1.8 2002-08-31 21:29:57 florian + * several PC related fixes + + Revision 1.7 2002/08/31 16:13:12 florian + * made _start global + + Revision 1.6 2002/08/31 14:02:23 florian + * r3 renamed to 3 + + Revision 1.5 2002/08/31 14:01:28 florian + * _haltproc to prt0.as added (Linux/PPC) + + Revision 1.4 2002/08/31 13:11:11 florian + * several fixes for Linux/PPC compilation + + Revision 1.3 2002/08/19 21:19:15 florian + * small fixes + + Revision 1.2 2002/07/26 17:09:44 florian + * log fixed + + Revision 1.1 2002/07/26 16:57:40 florian + + initial version, plain copy from glibc/sysdeps/powerpc/elf/start.S +*/ diff --git a/rtl/powerpc/powerpc.inc b/rtl/powerpc/powerpc.inc index f4f249ca35..2490647e23 100644 --- a/rtl/powerpc/powerpc.inc +++ b/rtl/powerpc/powerpc.inc @@ -1,1016 +1,1019 @@ -{ - $Id$ - This file is part of the Free Pascal run time library. - Copyright (c) 2000-2001 by the Free Pascal development team. - - Portions Copyright (c) 2000 by Casey Duncan (casey.duncan@state.co.us) - - Processor dependent implementation for the system unit for - PowerPC - - See the file COPYING.FPC, included in this distribution, - for details about the copyright. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - **********************************************************************} - - -{**************************************************************************** - PowerPC specific stuff -****************************************************************************} - -{ This function is never called directly, it's a dummy to hold the register save/ - load subroutines -} -procedure saverestorereg;assembler; -asm -{ exit } -.global _restfpr_14_x -_restfpr_14_x: lfd f14, -144(r11) -.global _restfpr_15_x -_restfpr_15_x: lfd f15, -136(r11) -.global _restfpr_16_x -_restfpr_16_x: lfd f16, -128(r11) -.global _restfpr_17_x -_restfpr_17_x: lfd f17, -120(r11) -.global _restfpr_18_x -_restfpr_18_x: lfd f18, -112(r11) -.global _restfpr_19_x -_restfpr_19_x: lfd f19, -104(r11) -.global _restfpr_20_x -_restfpr_20_x: lfd f20, -96(r11) -.global _restfpr_21_x -_restfpr_21_x: lfd f21, -88(r11) -.global _restfpr_22_x -_restfpr_22_x: lfd f22, -80(r11) -.global _restfpr_23_x -_restfpr_23_x: lfd f23, -72(r11) -.global _restfpr_24_x -_restfpr_24_x: lfd f24, -64(r11) -.global _restfpr_25_x -_restfpr_25_x: lfd f25, -56(r11) -.global _restfpr_26_x -_restfpr_26_x: lfd f26, -48(r11) -.global _restfpr_27_x -_restfpr_27_x: lfd f27, -40(r11) -.global _restfpr_28_x -_restfpr_28_x: lfd f28, -32(r11) -.global _restfpr_29_x -_restfpr_29_x: lfd f29, -24(r11) -.global _restfpr_30_x -_restfpr_30_x: lfd f30, -16(r11) -.global _restfpr_31_x -_restfpr_31_x: lwz r0, 4(r11) - lfd f31, -8(r11) - mtlr r0 - ori r1, r11, 0 - blr - -{ exit with restoring lr } -.global _restfpr_14_l -_restfpr_14_l: lfd f14, -144(r11) -.global _restfpr_15_l -_restfpr_15_l: lfd f15, -136(r11) -.global _restfpr_16_l -_restfpr_16_l: lfd f16, -128(r11) -.global _restfpr_17_l -_restfpr_17_l: lfd f17, -120(r11) -.global _restfpr_18_l -_restfpr_18_l: lfd f18, -112(r11) -.global _restfpr_19_l -_restfpr_19_l: lfd f19, -104(r11) -.global _restfpr_20_l -_restfpr_20_l: lfd f20, -96(r11) -.global _restfpr_21_l -_restfpr_21_l: lfd f21, -88(r11) -.global _restfpr_22_l -_restfpr_22_l: lfd f22, -80(r11) -.global _restfpr_23_l -_restfpr_23_l: lfd f23, -72(r11) -.global _restfpr_24_l -_restfpr_24_l: lfd f24, -64(r11) -.global _restfpr_25_l -_restfpr_25_l: lfd f25, -56(r11) -.global _restfpr_26_l -_restfpr_26_l: lfd f26, -48(r11) -.global _restfpr_27_l -_restfpr_27_l: lfd f27, -40(r11) -.global _restfpr_28_l -_restfpr_28_l: lfd f28, -32(r11) -.global _restfpr_29_l -_restfpr_29_l: lfd f29, -24(r11) -.global _restfpr_30_l -_restfpr_30_l: lfd f30, -16(r11) -.global _restfpr_31_l -_restfpr_31_l: lwz r0, 4(r11) - lfd f31, -8(r11) - mtlr r0 - ori r1, r11, 0 - blr -end; - - -{**************************************************************************** - Move / Fill -****************************************************************************} - -{$define FPC_SYSTEM_HAS_MOVE} - -procedure Move(const source;var dest;count:longint);assembler; -asm - { count <= 0 ? } - cmpwi cr0,r5,0 - { check if we have to do the move backwards because of overlap } - sub r10,r4,r3 - { carry := boolean(dest-source < count) = boolean(overlap) } - subc r10,r10,r5 - - { count < 15 ? (to decide whether we will move dwords or bytes } - cmpwi cr1,r5,15 - - { if overlap, then r10 := -1 else r10 := 0 } - subfe r10,r10,r10 - - { count < 39 ? (32 + max. alignment (7) } - cmpwi cr7,r5,39 - - { if count <= 0, stop } - ble cr0,LMoveDone - - { load the begin of the source in the data cache } - dcbt 0,r3 - { and the dest as well } - dcbst 0,r4 - - { if overlap, then r0 := count else r0 := 0 } - and r0,r5,r10 - { if overlap, then point source and dest to the end } - add r3,r3,r0 - add r4,r4,r0 - { if overlap, then r0 := 0, else r0 := -1 } - not r0,r10 - { if overlap, then r10 := -2, else r10 := 0 } - slwi r10,r10,1 - { if overlap, then r10 := -1, else r10 := 1 } - addi r10,r10,1 - { if overlap, then source/dest += -1, otherwise they stay } - { After the next instruction, r3/r4 + r10 = next position } - { to load/store from/to } - add r3,r3,r0 - add r4,r4,r0 - - { if count < 15, copy everything byte by byte } - blt cr1,LMoveBytes - - { otherwise, guarantee 4 byte alignment for dest for starters } -LMove4ByteAlignLoop: - lbzux r0,r3,r10 - stbux r0,r4,r10 - { is dest now 4 aligned? } - andi. r0,r4,3 - subi r5,r5,1 - { while not aligned, continue } - bne cr0,LMove4ByteAlignLoop - - { check for 8 byte alignment } - andi. r0,r4,7 - { we are going to copy one byte again (the one at the newly } - { aligned address), so increase count byte 1 } - addi r5,r5,1 - { count div 4 for number of dwords to copy } - srwi r0,r5,2 - { if 11 <= count < 39, copy using dwords } - blt cr7,LMoveDWords - - { multiply the update count with 4 } - slwi r10,r10,2 - - beq cr0,L8BytesAligned - - { count >= 39 -> align to 8 byte boundary and then use the FPU } - { since we're already at 4 byte alignment, use dword store } - lwzux r0,r3,r10 - stwux r0,r4,r10 - subi r5,r5,4 -L8BytesAligned: - { count div 32 ( >= 1, since count was >=39 } - srwi r0,r5,5 - { remainder } - andi. r5,r5,31 - { to decide if we will do some dword stores (instead of only } - { byte stores) afterwards or not } - cmpwi cr1,r5,11 - mtctr r0 - - { r0 := count div 4, will be moved to ctr when copying dwords } - srwi r0,r5,2 - - { adjust the update count: it will now be 8 or -8 depending on overlap } - slwi r10,r10,1 - - { adjust source and dest pointers: because of the above loop, dest is now } - { aligned to 8 bytes. So if we substract r10 we will still have an 8 bytes } - { aligned address) } - sub r3,r3,r10 - sub r4,r4,r10 - -LMove32ByteLoop: - lfdux f0,r3,r10 - lfdux f1,r3,r10 - lfdux f2,r3,r10 - lfdux f3,r3,r10 - stfdux f0,r4,r10 - stfdux f1,r4,r10 - stfdux f2,r4,r10 - stfdux f3,r4,r10 - bdnz LMove32ByteLoop - - { cr0*4+eq is true if "count and 31" = 0 } - beq cr0,LMoveDone - - { make r10 again -1 or 1, but first adjust source/dest pointers } - add r3,r3,r10 - add r4,r4,r10 - srawi r10,r10,3 - sub r3,r3,r10 - sub r4,r4,r10 - - { cr1 contains whether count <= 11 } - ble cr1,LMoveBytes - add r3,r3,r10 - add r4,r4,r10 - -LMoveDWords: - mtctr r0 - andi. r5,r5,3 - { r10 * 4 } - slwi r10,r10,2 - sub r3,r3,r10 - sub r4,r4,r10 - -LMoveDWordsLoop: - lwzux r0,r3,r10 - stwux r0,r4,r10 - bdnz LMoveDWordsLoop - - beq cr0,LMoveDone - { make r10 again -1 or 1 } - add r3,r3,r10 - add r4,r4,r10 - srawi r10,r10,2 - sub r3,r3,r10 - sub r4,r4,r10 -LMoveBytes: - mtctr r5 -LMoveBytesLoop: - lbzux r0,r3,r10 - stbux r0,r4,r10 - bdnz LMoveBytesLoop -LMoveDone: -end ['R0','R3','R4','R5','R10','F0','F11','F12','F13','CTR','CR0','CR1','CR7']; - - -{$define FPC_SYSTEM_HAS_FILLCHAR} - -Procedure FillChar(var x;count:longint;value:byte);assembler; -{ input: x in r3, count in r4, value in r5 } - -{$ifndef ABI_AIX} -{ in the AIX ABI, we can use te red zone for temp storage, otherwise we have } -{ to explicitely allocate room } -var - temp : packed record - case byte of - 0: (l1,l2: longint); - 1: (d: double); - end; -{$endif ABI_AIX} -asm - { no bytes? } - cmpwi cr6,r4,0 - { less than 15 bytes? } - cmpwi cr7,r4,15 - { less than 63 bytes? } - cmpwi cr1,r4,63 - { fill r5 with ValueValueValueValue } - rlwimi r5,r5,8,16,23 - { setup for aligning x to multiple of 4} - rlwinm r10,r3,0,31-2+1,31 - rlwimi r5,r5,16,0,15 - beq cr6,LFillCharDone - { get the start of the data in the cache (and mark it as "will be } - { modified") } - dcbst 0,r3 - subfic r10,r10,4 - blt cr7,LFillCharVerySmall - { just store 4 bytes instead of using a loop to align (there are } - { plenty of other instructions now to keep the processor busy } - { while it handles the (possibly unaligned) store) } - stw r5,0(r3) - { r3 := align(r3,4) } - add r3,r3,r10 - { decrease count with number of bytes already stored } - sub r4,r4,r10 - blt cr1,LFillCharSmall - { if we have to fill with 0 (which happens a lot), we can simply use } - { dcbz for the most part, which is very fast, so make a special case } - { for that } - cmplwi cr1,r5,0 - { align to a multiple of 32 (and immediately check whether we aren't } - { already 32 byte aligned) } - rlwinm. r10,r3,0,31-5+1,31 - { setup r3 for using update forms of store instructions } - subi r3,r3,4 - { get number of bytes to store } - subfic r10,r10,32 - { if already 32byte aligned, skip align loop } - beq L32ByteAlignLoopDone - { substract from the total count } - sub r4,r4,r10 -L32ByteAlignLoop: - { we were already aligned to 4 byres, so this will count down to } - { exactly 0 } - subic. r10,r10,4 - stwu r5,4(r3) - bne L32ByteAlignLoop -L32ByteAlignLoopDone: - { get the amount of 32 byte blocks } - srwi r10,r4,5 - { and keep the rest in r4 (recording whether there is any rest) } - rlwinm. r4,r4,0,31-5+2,31 - { move to ctr } - mtctr r10 - { check how many rest there is (to decide whether we'll use } - { FillCharSmall or FillCharVerySmall) } - cmpl cr7,r4,11 - { if filling with zero, only use dcbz } - bne cr1, LFillCharNoZero - { make r3 point again to the actual store position } - addi r3,r3,4 -LFillCharDCBZLoop: - dcbz 0,r3 - addi r3,r3,32 - bdnz LFillCharDCBZLoop - { if there was no rest, we're finished } - beq LFillCharDone - b LFillCharSmall -LFillCharNoZero: -{$ifdef ABI_AIX} - stw r5,0(sp) - stw r5,4(sp) - lfd f0,0(sp) -{$else ABI_AIX} - stw r5,temp - stw r5,4+temp - lfd f0,temp -{$endif ABI_AIX} - { make r3 point to address-8, so we're able to use fp double stores } - { with update (it's already -4 now) } - subi r3,r3,4 - { load r10 with 8, so that dcbz uses the correct address } -LFillChar32ByteLoop: - dcbz r3,r10 - stfdu f0,8(r3) - stfdu f0,8(r3) - stfdu f0,8(r3) - stfdu f0,8(r3) - bdnz LFillChar32ByteLoop - { if there was no rest, we're finished } - beq LFillCharDone -LFillCharSmall: - { when we arrive here, we're already 4 byte aligned } - { get count div 4 to store dwords } - srwi r10,r4,2 - { get ready for use of update stores } - subi r3,r3,4 - mtctr r10 - rlwinm. r4,r4,0,31-2+1,31 -LFillCharSmallLoop: - stwu r5,4(r3) - bdnz LFillCharSmallLoop - { if nothing left, stop } - beq LFillCharDone - { get ready to store bytes } - addi r3,r3,4 -LFillCharVerySmall: - mtctr r4 - subi r3,r3,1 -LFillCharVerySmallLoop: - stbu r5,1(r3) - bdnz LFillCharVerySmallLoop -LFillCharDone: -end; - - -{$define FPC_SYSTEM_HAS_FILLDWORD} -procedure filldword(var x;count : longint;value : dword); -assembler; -asm -{ registers: - r3 x - r4 count - r5 value - r13 value.value - r14 ptr to dest word - r15 increment 1 - r16 increment 2 - r17 scratch - r18 scratch - f1 value.value.value.value -} - cmpwi cr0,r3,0 - mtctr r4 - subi r3,r3,4 - ble .FillWordEnd //if count<=0 Then Exit -.FillWordLoop: - stwu r5,4(r3) - bdnz .FillWordLoop -.FillWordEnd: -end ['R3','R4','R5','CTR']; - - -{$define FPC_SYSTEM_HAS_INDEXBYTE} -function IndexByte(const buf;len:longint;b:byte):longint; assembler; -{ input: r3 = buf, r4 = len, r5 = b } -{ output: r3 = position of b in buf (-1 if not found) } -asm - { load the begin of the buffer in the data cache } - dcbt 0,r3 - cmplwi r4,0 - mtctr r4 - subi r10,r3,1 - mr r0,r3 - { assume not found } - li r3,-1 - beq LIndexByteDone -LIndexByteLoop: - lbzu r9,1(r10) - cmplw r9,r5 - bdnzf cr0*4+eq,LIndexByteLoop - { r3 still contains -1 here } - bne LIndexByteDone - sub r3,r10,r0 -LIndexByteDone: -end ['R0','R3','R9','R10','CR0','CTR']; - - -{$define FPC_SYSTEM_HAS_INDEXWORD} -function IndexWord(const buf;len:longint;b:word):longint; assembler; -{ input: r3 = buf, r4 = len, r5 = b } -{ output: r3 = position of b in buf (-1 if not found) } -asm - { load the begin of the buffer in the data cache } - dcbt 0,r3 - cmplwi r4,0 - mtctr r4 - subi r10,r3,2 - mr r0,r3 - { assume not found } - li r3,-1 - beq LIndexWordDone -LIndexWordLoop: - lhzu r9,2(r10) - cmplw r9,r5 - bdnzf cr0*4+eq,LIndexWordLoop - { r3 still contains -1 here } - bne LIndexWordDone - sub r3,r10,r0 -LIndexWordDone: -end ['R0','R3','R9','R10','CR0','CTR']; - - -{$define FPC_SYSTEM_HAS_INDEXDWORD} -function IndexDWord(const buf;len:longint;b:DWord):longint; assembler; -{ input: r3 = buf, r4 = len, r5 = b } -{ output: r3 = position of b in buf (-1 if not found) } -asm - { load the begin of the buffer in the data cache } - dcbt 0,r3 - cmplwi r4,0 - mtctr r4 - subi r10,r3,4 - mr r0,r3 - { assume not found } - li r3,-1 - beq LIndexDWordDone -LIndexDWordLoop: - lwzu r9,4(r30) - cmplw r9,r5 - bdnzf cr0*4+eq, LIndexDWordLoop - { r3 still contains -1 here } - bne LIndexDWordDone - sub r3,r10,r0 -LIndexDWordDone: -end ['R0','R3','R9','R10','CR0','CTR']; - -{$define FPC_SYSTEM_HAS_COMPAREBYTE} -function CompareByte(const buf1,buf2;len:longint):longint; assembler; -{ input: r3 = buf1, r4 = buf2, r5 = len } -{ output: r3 = 0 if equal, < 0 if buf1 < str2, > 0 if buf1 > str2 } -{ note: almost direct copy of strlcomp() from strings.inc } -asm - { load the begin of the first buffer in the data cache } - dcbt 0,r3 - { use r0 instead of r3 for buf1 since r3 contains result } - cmplwi r5,0 - mtctr r5 - subi r11,r3,1 - subi r4,r4,1 - li r3,0 - beq LCompByteDone -LCompByteLoop: - { load next chars } - lbzu r9,1(r11) - lbzu r10,1(r4) - { calculate difference } - sub. r3,r9,r10 - { if chars not equal or at the end, we're ready } - bdnzt cr0*4+eq, LCompByteLoop -LCompByteDone: -end ['R0','R3','R4','R9','R10','R11','CR0','CTR']; - -{$define FPC_SYSTEM_HAS_COMPAREWORD} -function CompareWord(const buf1,buf2;len:longint):longint; assembler; -{ input: r3 = buf1, r4 = buf2, r5 = len } -{ output: r3 = 0 if equal, < 0 if buf1 < str2, > 0 if buf1 > str2 } -{ note: almost direct copy of strlcomp() from strings.inc } -asm - { load the begin of the first buffer in the data cache } - dcbt 0,r3 - { use r0 instead of r3 for buf1 since r3 contains result } - cmplwi r5,0 - mtctr r5 - subi r11,r3,2 - subi r4,r4,2 - li r3,0 - beq LCompWordDone -LCompWordLoop: - { load next chars } - lhzu r9,2(r11) - lhzu r10,2(r4) - { calculate difference } - sub. r3,r9,r10 - { if chars not equal or at the end, we're ready } - bdnzt cr0*4+eq, LCompWordLoop -LCompWordDone: -end ['R0','R3','R4','R9','R10','R11','CR0','CTR']; - - -{$define FPC_SYSTEM_HAS_COMPAREDWORD} -function CompareDWord(const buf1,buf2;len:longint):longint; assembler; -{ input: r3 = buf1, r4 = buf2, r5 = len } -{ output: r3 = 0 if equal, < 0 if buf1 < str2, > 0 if buf1 > str2 } -{ note: almost direct copy of strlcomp() from strings.inc } -asm - { load the begin of the first buffer in the data cache } - dcbt 0,r3 - { use r0 instead of r3 for buf1 since r3 contains result } - cmplwi r5,0 - mtctr r5 - subi r11,r3,4 - subi r4,r4,4 - li r3,0 - beq LCompDWordDone -LCompDWordLoop: - { load next chars } - lwzu r9,4(r11) - lwzu r10,4(r4) - { calculate difference } - sub. r3,r9,r10 - { if chars not equal or at the end, we're ready } - bdnzt cr0*4+eq, LCompDWordLoop -LCompDWordDone: -end ['R0','R3','R4','R9','R10','R11','CR0','CTR']; - -{$define FPC_SYSTEM_HAS_INDEXCHAR0} -function IndexChar0(const buf;len:longint;b:Char):longint; assembler; -{ input: r3 = buf, r4 = len, r5 = b } -{ output: r3 = position of found position (-1 if not found) } -asm - { load the begin of the buffer in the data cache } - dcbt 0,r3 - { length = 0? } - cmplwi r4,0 - mtctr r4 - subi r9,r3,1 - mr r0,r9 - { assume not found } - li r3,-1 - { if yes, do nothing } - beq LIndexChar0Done - subi r3,r3,1 -LIndexChar0Loop: - lbzu r10,1(r9) - cmplwi cr1,r10,0 - cmplw r10,r5 - beq cr1,LIndexChar0Done - bdnzf cr0*4+eq, LIndexChar0Loop - bne LIndexChar0Done - sub r3,r9,r0 -LIndexChar0Done: -end ['R0','R3','R4','R9','R10','CR0','CTR']; - - -{**************************************************************************** - Object Helpers -****************************************************************************} - -{ use generic implementation for now } -{ that's a problem currently, the generic has a another prototyp than this defined in compproc.inc (FK) } - -{$define FPC_SYSTEM_HAS_FPC_HELP_CONSTRUCTOR} -procedure fpc_help_constructor; assembler;compilerproc; -asm -end; - -{$define FPC_SYSTEM_HAS_FPC_HELP_FAIL} -procedure fpc_help_fail;assembler;[public,alias:'FPC_HELP_FAIL']; compilerproc; -assembler; -asm -{$warning FIX ME!} -// !!!!!!!!!!! -end; - - -{$define FPC_SYSTEM_HAS_FPC_HELP_DESTRUCTOR} -{ use generic implementation for now } -{ that's a problem currently, the generic has a another prototyp than this defined in compproc.inc (FK) } - -procedure fpc_help_destructor;assembler; compilerproc; -asm -end; - -{$define FPC_SYSTEM_HAS_FPC_NEW_CLASS} -procedure fpc_new_class;assembler;[public,alias:'FPC_NEW_CLASS']; compilerproc; -assembler; -asm -{$warning FIX ME!} -// !!!!!!!!!!! -end; - - -{$define FPC_SYSTEM_HAS_FPC_DISPOSE_CLASS} -procedure fpc_dispose_class;assembler;[public,alias:'FPC_DISPOSE_CLASS']; compilerproc; -assembler; -asm -{$warning FIX ME!} -// !!!!!!!!!!! -end; - -{$define FPC_SYSTEM_HAS_FPC_HELP_FAIL_CLASS} -procedure fpc_help_fail_class;assembler;[public,alias:'FPC_HELP_FAIL_CLASS']; {$ifdef hascompilerproc} compilerproc; {$endif} -{ a non zero class must allways be disposed - VMT is allways at pos 0 } -assembler; -asm -{$warning FIX ME!} -// !!!!!!!!!!! -end; - - - -{$define FPC_SYSTEM_HAS_FPC_CHECK_OBJECT} -{ use generic implementation for now } -{ that's a problem currently, the generic has a another prototy than this defined in compproc.inc (FK) } -procedure fpc_check_object(obj : pointer);assembler; compilerproc; -asm -{$warning FIX ME!} -// !!!!!!!!!!! -end; - -{ use generic implementation for now } -{ that's a problem currently, the generic has a another prototy than this defined in compproc.inc (FK) } -{$define FPC_SYSTEM_HAS_FPC_CHECK_OBJECT_EXT} -procedure fpc_check_object_ext; compilerproc;assembler; -asm -{$warning FIX ME!} -// !!!!!!!!!!! -end; - -{**************************************************************************** - String -****************************************************************************} - -{$define FPC_SYSTEM_HAS_FPC_SHORTSTR_COPY} -function fpc_shortstr_to_shortstr(len:longint; const sstr: shortstring): shortstring; [public,alias: 'FPC_SHORTSTR_TO_SHORTSTR']; compilerproc; -assembler; -{ input: r3: pointer to result, r4: len, r5: sstr } -asm - { load length source } - lbz r10,0(r5) - { load the begin of the dest buffer in the data cache } - dcbtst r0,r3 - - { put min(length(sstr),len) in r3 } - subc r0,r4,r10 { r0 := r3 - r10 } - subfme r4,r4 { if r3 >= r4 then r3' := 0 else r3' := -1 } - and r4,r0,r4 { if r3 >= r4 then r3' := 0 else r3' := r3-r10 } - add r4,r4,r10 { if r3 >= r4 then r3' := r10 else r3' := r3 } - - cmplwi r4,0 - { put length in ctr } - mtctr r4 - stb r4,0(r3) - beq LShortStrCopyDone -LShortStrCopyLoop: - lbzu r0,1(r5) - stbu r0,1(r3) - bdnz LShortStrCopyLoop -LShortStrCopyDone: -end ['R0','R3','R4','R5','R10','CR0','CTR']; - - -{$define FPC_SYSTEM_HAS_FPC_SHORTSTR_COPY} -procedure fpc_shortstr_copy(len:longint;sstr,dstr:pointer);[public,alias:'FPC_SHORTSTR_COPY']; -assembler; -{ input: r3: len, r4: sstr, r5: dstr } -asm - { load length source } - lbz r10,0(r4) - { load the begin of the dest buffer in the data cache } - dcbtst r0,r5 - - { put min(length(sstr),len) in r3 } - subc r0,r3,r10 { r0 := r3 - r10 } - subfme r3,r3 { if r3 >= r4 then r3' := 0 else r3' := -1 } - and r3,r0,r3 { if r3 >= r4 then r3' := 0 else r3' := r3-r10 } - add r3,r3,r10 { if r3 >= r4 then r3' := r10 else r3' := r3 } - - cmplwi r3,0 - { put length in ctr } - mtctr r3 - stb r3,0(r5) - beq LShortStrCopyDone2 -LShortStrCopyLoop2: - lbzu r0,1(r4) - stbu r0,1(r5) - bdnz LShortStrCopyLoop2 -LShortStrCopyDone2: -end ['R0','R3','R4','R5','R10','CR0','CTR']; - -{$define FPC_SYSTEM_HAS_FPC_SHORTSTR_CONCAT} -function fpc_shortstr_concat(const s1,s2: shortstring): shortstring; compilerproc; -{ expects that results (r3) contains a pointer to the current string and s1 } -{ (r4) a pointer to the one that has to be concatenated } -assembler; -asm - { load length s1 } - lbz r9, 0(r4) - { load length result } - lbz r10, 0(r3) - { go to last current character of result } - add r4,r9,r4 - - { calculate min(length(s1),255-length(result)) } - subfic r9,r9,255 - subc r8,r9,r10 { r8 := r9 - r10 } - subfme r9,r9 { if r9 >= r10 then r9' := 0 else r9' := -1 } - and r9,r8,r9 { if r9 >= r10 then r9' := 0 else r9' := r9-r8 } - add r9,r9,r10 { if r9 >= r10 then r9' := r10 else r9' := r9 } - - { and concatenate } - mtctr r9 -LShortStrConcatLoop: - lbzu r10,1(r4) - stbu r10,1(r3) - bdnz LShortStrConcatLoop -end ['R3','R4','R8','R9','R10','CTR']; - - -{$define FPC_SYSTEM_HAS_FPC_SHORTSTR_COMPARE} -function fpc_shortstr_compare(const dstr,sstr:shortstring): longint; [public,alias:'FPC_SHORTSTR_COMPARE']; compilerproc; -assembler; -asm - { load length sstr } - lbz r9,0(r4) - { load length dstr } - lbz r10,0(r3) - { save their difference for later and } - { calculate min(length(sstr),length(dstr)) } - subc r0,r9,r10 { r0 := r9 - r10 } - subfme r9,r9 { if r9 >= r10 then r9' := 0 else r9' := -1 } - and r9,r0,r9 { if r9 >= r10 then r9' := 0 else r9' := r9-r8 } - add r9,r9,r10 { if r9 >= r10 then r9' := r10 else r9' := r9 } - - { first compare dwords (length/4) } - srwi. r8,r9,2 - { keep length mod 4 for the ends } - rlwinm r9,r9,0,30,31 - { already check whether length mod 4 = 0 } - cmplwi cr1,r9,0 - { length div 4 in ctr for loop } - mtctr r8 - { if length < 3, goto byte comparing } - beq LShortStrCompare1 - { setup for use of update forms of load/store with dwords } - subi r4,r4,3 - subi r8,r3,3 -LShortStrCompare4Loop: - lwzu r3,4(r4) - lwzu r10,4(r8) - sub. r3,r3,r10 - bdnzt cr0+eq,LShortStrCompare4Loop - { r3 contains result if we stopped because of "ne" flag } - bne LShortStrCompareDone - { setup for use of update forms of load/store with bytes } - addi r4,r4,3 - addi r8,r8,3 -LShortStrCompare1: - { if comparelen mod 4 = 0, skip this and return the difference in } - { lengths } - beq cr1,LShortStrCompareLen -LShortStrCompare1Loop: - lbzu r3,1(r4) - lbzu r10,1(r8) - sub. r3,r3,r10 - bdnzt cr0+eq,LShortStrCompare4Loop - bne LShortStrCompareDone -LShortStrCompareLen: - { also return result in flags, maybe we can use this in the CG } - mr. r3,r0 -LShortStrCompareDone: -end ['R0','R3','R4','R8','R9','R10','CR0','CR1','CTR']; - - -{$define FPC_SYSTEM_HAS_FPC_PCHAR_TO_SHORTSTR} -function fpc_pchar_to_shortstr(p:pchar):shortstring;[public,alias:'FPC_PCHAR_TO_SHORTSTR']; compilerproc; -assembler; -{$include strpas.inc} - - -{$define FPC_SYSTEM_HAS_STRLEN} -function strlen(p:pchar):longint;assembler; -{$include strlen.inc} - - -{$define FPC_SYSTEM_HAS_GET_FRAME} -function get_frame:longint;assembler; -asm - {$warning FIX ME!} - // !!!!!!! depends on ABI !!!!!!!! -end ['R3']; - - -{$define FPC_SYSTEM_HAS_GET_CALLER_ADDR} -function get_caller_addr(framebp:longint):longint;assembler; -asm - {$warning FIX ME!} - // !!!!!!! depends on ABI !!!!!!!! -end ['R3']; - - -{$define FPC_SYSTEM_HAS_GET_CALLER_FRAME} -function get_caller_frame(framebp:longint):longint;assembler; -asm - {$warning FIX ME!} - // !!!!!!! depends on ABI !!!!!!!! -end ['R3']; - -{$define FPC_SYSTEM_HAS_ABS_LONGINT} -function abs(l:longint):longint; assembler;[internconst:in_const_abs]; -asm - srawi r0,r3,31 - add r3,r0,r3 - xor r3,r3,r0 -end ['R0','R3']; - - -{**************************************************************************** - Math -****************************************************************************} - -{$define FPC_SYSTEM_HAS_ODD_LONGINT} -function odd(l:longint):boolean;assembler;[internconst:in_const_odd]; -asm - rlwinm r3,r3,0,31,31 -end ['R3']; - - -{$define FPC_SYSTEM_HAS_SQR_LONGINT} -function sqr(l:longint):longint;assembler;[internconst:in_const_sqr]; -asm - mullw r3,r3,r3 -end ['R3']; - - -{$define FPC_SYSTEM_HAS_SPTR} -Function Sptr : Longint;assembler; -asm - mr r3,r1 -end ['R3']; - - -{**************************************************************************** - Str() -****************************************************************************} - -{ int_str: generic implementation is used for now } - - -{**************************************************************************** - Multithreading -****************************************************************************} - -{ do a thread save inc/dec } - -function declocked(var l : longint) : boolean;assembler; -{ input: address of l in r3 } -{ output: boolean indicating whether l is zero after decrementing } -asm -LDecLockedLoop: -{$ifdef MT} - lwarx r10,0,r3 - subi r10,r10,1 - stwcx. r10,0,r3 - bne- LDecLockedLoop -{$else MT} - lwzx r10,0,r3 - subi r10,r10,1 - stw r10,0(r3) -{$endif MT} - mr. r3,r10 -end ['R3','R10']; - -procedure inclocked(var l : longint);assembler; -asm -LIncLockedLoop: -{$ifdef MT} - lwarx r10,0,r3 - addi r10,r10,1 - stwcx. r10,0,r3 - bne- LDecLockedLoop -{$else MT} - lwzx r10,0,r3 - addi r10,r10,1 - stw r10,0(r3) -{$endif MT} -end ['R3','R10']; - - -{ +{ + $Id$ + This file is part of the Free Pascal run time library. + Copyright (c) 2000-2001 by the Free Pascal development team. + + Portions Copyright (c) 2000 by Casey Duncan (casey.duncan@state.co.us) + + Processor dependent implementation for the system unit for + PowerPC + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + **********************************************************************} + + +{**************************************************************************** + PowerPC specific stuff +****************************************************************************} + +{ This function is never called directly, it's a dummy to hold the register save/ + load subroutines +} +procedure saverestorereg;assembler; +asm +{ exit } +.global _restfpr_14_x +_restfpr_14_x: lfd f14, -144(r11) +.global _restfpr_15_x +_restfpr_15_x: lfd f15, -136(r11) +.global _restfpr_16_x +_restfpr_16_x: lfd f16, -128(r11) +.global _restfpr_17_x +_restfpr_17_x: lfd f17, -120(r11) +.global _restfpr_18_x +_restfpr_18_x: lfd f18, -112(r11) +.global _restfpr_19_x +_restfpr_19_x: lfd f19, -104(r11) +.global _restfpr_20_x +_restfpr_20_x: lfd f20, -96(r11) +.global _restfpr_21_x +_restfpr_21_x: lfd f21, -88(r11) +.global _restfpr_22_x +_restfpr_22_x: lfd f22, -80(r11) +.global _restfpr_23_x +_restfpr_23_x: lfd f23, -72(r11) +.global _restfpr_24_x +_restfpr_24_x: lfd f24, -64(r11) +.global _restfpr_25_x +_restfpr_25_x: lfd f25, -56(r11) +.global _restfpr_26_x +_restfpr_26_x: lfd f26, -48(r11) +.global _restfpr_27_x +_restfpr_27_x: lfd f27, -40(r11) +.global _restfpr_28_x +_restfpr_28_x: lfd f28, -32(r11) +.global _restfpr_29_x +_restfpr_29_x: lfd f29, -24(r11) +.global _restfpr_30_x +_restfpr_30_x: lfd f30, -16(r11) +.global _restfpr_31_x +_restfpr_31_x: lwz r0, 4(r11) + lfd f31, -8(r11) + mtlr r0 + ori r1, r11, 0 + blr + +{ exit with restoring lr } +.global _restfpr_14_l +_restfpr_14_l: lfd f14, -144(r11) +.global _restfpr_15_l +_restfpr_15_l: lfd f15, -136(r11) +.global _restfpr_16_l +_restfpr_16_l: lfd f16, -128(r11) +.global _restfpr_17_l +_restfpr_17_l: lfd f17, -120(r11) +.global _restfpr_18_l +_restfpr_18_l: lfd f18, -112(r11) +.global _restfpr_19_l +_restfpr_19_l: lfd f19, -104(r11) +.global _restfpr_20_l +_restfpr_20_l: lfd f20, -96(r11) +.global _restfpr_21_l +_restfpr_21_l: lfd f21, -88(r11) +.global _restfpr_22_l +_restfpr_22_l: lfd f22, -80(r11) +.global _restfpr_23_l +_restfpr_23_l: lfd f23, -72(r11) +.global _restfpr_24_l +_restfpr_24_l: lfd f24, -64(r11) +.global _restfpr_25_l +_restfpr_25_l: lfd f25, -56(r11) +.global _restfpr_26_l +_restfpr_26_l: lfd f26, -48(r11) +.global _restfpr_27_l +_restfpr_27_l: lfd f27, -40(r11) +.global _restfpr_28_l +_restfpr_28_l: lfd f28, -32(r11) +.global _restfpr_29_l +_restfpr_29_l: lfd f29, -24(r11) +.global _restfpr_30_l +_restfpr_30_l: lfd f30, -16(r11) +.global _restfpr_31_l +_restfpr_31_l: lwz r0, 4(r11) + lfd f31, -8(r11) + mtlr r0 + ori r1, r11, 0 + blr +end; + + +{**************************************************************************** + Move / Fill +****************************************************************************} + +{$define FPC_SYSTEM_HAS_MOVE} + +procedure Move(const source;var dest;count:longint);assembler; +asm + { count <= 0 ? } + cmpwi cr0,r5,0 + { check if we have to do the move backwards because of overlap } + sub r10,r4,r3 + { carry := boolean(dest-source < count) = boolean(overlap) } + subc r10,r10,r5 + + { count < 15 ? (to decide whether we will move dwords or bytes } + cmpwi cr1,r5,15 + + { if overlap, then r10 := -1 else r10 := 0 } + subfe r10,r10,r10 + + { count < 39 ? (32 + max. alignment (7) } + cmpwi cr7,r5,39 + + { if count <= 0, stop } + ble cr0,LMoveDone + + { load the begin of the source in the data cache } + dcbt 0,r3 + { and the dest as well } + dcbst 0,r4 + + { if overlap, then r0 := count else r0 := 0 } + and r0,r5,r10 + { if overlap, then point source and dest to the end } + add r3,r3,r0 + add r4,r4,r0 + { if overlap, then r0 := 0, else r0 := -1 } + not r0,r10 + { if overlap, then r10 := -2, else r10 := 0 } + slwi r10,r10,1 + { if overlap, then r10 := -1, else r10 := 1 } + addi r10,r10,1 + { if overlap, then source/dest += -1, otherwise they stay } + { After the next instruction, r3/r4 + r10 = next position } + { to load/store from/to } + add r3,r3,r0 + add r4,r4,r0 + + { if count < 15, copy everything byte by byte } + blt cr1,LMoveBytes + + { otherwise, guarantee 4 byte alignment for dest for starters } +LMove4ByteAlignLoop: + lbzux r0,r3,r10 + stbux r0,r4,r10 + { is dest now 4 aligned? } + andi. r0,r4,3 + subi r5,r5,1 + { while not aligned, continue } + bne cr0,LMove4ByteAlignLoop + + { check for 8 byte alignment } + andi. r0,r4,7 + { we are going to copy one byte again (the one at the newly } + { aligned address), so increase count byte 1 } + addi r5,r5,1 + { count div 4 for number of dwords to copy } + srwi r0,r5,2 + { if 11 <= count < 39, copy using dwords } + blt cr7,LMoveDWords + + { multiply the update count with 4 } + slwi r10,r10,2 + + beq cr0,L8BytesAligned + + { count >= 39 -> align to 8 byte boundary and then use the FPU } + { since we're already at 4 byte alignment, use dword store } + lwzux r0,r3,r10 + stwux r0,r4,r10 + subi r5,r5,4 +L8BytesAligned: + { count div 32 ( >= 1, since count was >=39 } + srwi r0,r5,5 + { remainder } + andi. r5,r5,31 + { to decide if we will do some dword stores (instead of only } + { byte stores) afterwards or not } + cmpwi cr1,r5,11 + mtctr r0 + + { r0 := count div 4, will be moved to ctr when copying dwords } + srwi r0,r5,2 + + { adjust the update count: it will now be 8 or -8 depending on overlap } + slwi r10,r10,1 + + { adjust source and dest pointers: because of the above loop, dest is now } + { aligned to 8 bytes. So if we substract r10 we will still have an 8 bytes } + { aligned address) } + sub r3,r3,r10 + sub r4,r4,r10 + +LMove32ByteLoop: + lfdux f0,r3,r10 + lfdux f1,r3,r10 + lfdux f2,r3,r10 + lfdux f3,r3,r10 + stfdux f0,r4,r10 + stfdux f1,r4,r10 + stfdux f2,r4,r10 + stfdux f3,r4,r10 + bdnz LMove32ByteLoop + + { cr0*4+eq is true if "count and 31" = 0 } + beq cr0,LMoveDone + + { make r10 again -1 or 1, but first adjust source/dest pointers } + add r3,r3,r10 + add r4,r4,r10 + srawi r10,r10,3 + sub r3,r3,r10 + sub r4,r4,r10 + + { cr1 contains whether count <= 11 } + ble cr1,LMoveBytes + add r3,r3,r10 + add r4,r4,r10 + +LMoveDWords: + mtctr r0 + andi. r5,r5,3 + { r10 * 4 } + slwi r10,r10,2 + sub r3,r3,r10 + sub r4,r4,r10 + +LMoveDWordsLoop: + lwzux r0,r3,r10 + stwux r0,r4,r10 + bdnz LMoveDWordsLoop + + beq cr0,LMoveDone + { make r10 again -1 or 1 } + add r3,r3,r10 + add r4,r4,r10 + srawi r10,r10,2 + sub r3,r3,r10 + sub r4,r4,r10 +LMoveBytes: + mtctr r5 +LMoveBytesLoop: + lbzux r0,r3,r10 + stbux r0,r4,r10 + bdnz LMoveBytesLoop +LMoveDone: +end ['R0','R3','R4','R5','R10','F0','F11','F12','F13','CTR','CR0','CR1','CR7']; + + +{$define FPC_SYSTEM_HAS_FILLCHAR} + +Procedure FillChar(var x;count:longint;value:byte);assembler; +{ input: x in r3, count in r4, value in r5 } + +{$ifndef ABI_AIX} +{ in the AIX ABI, we can use te red zone for temp storage, otherwise we have } +{ to explicitely allocate room } +var + temp : packed record + case byte of + 0: (l1,l2: longint); + 1: (d: double); + end; +{$endif ABI_AIX} +asm + { no bytes? } + cmpwi cr6,r4,0 + { less than 15 bytes? } + cmpwi cr7,r4,15 + { less than 63 bytes? } + cmpwi cr1,r4,63 + { fill r5 with ValueValueValueValue } + rlwimi r5,r5,8,16,23 + { setup for aligning x to multiple of 4} + rlwinm r10,r3,0,31-2+1,31 + rlwimi r5,r5,16,0,15 + beq cr6,LFillCharDone + { get the start of the data in the cache (and mark it as "will be } + { modified") } + dcbst 0,r3 + subfic r10,r10,4 + blt cr7,LFillCharVerySmall + { just store 4 bytes instead of using a loop to align (there are } + { plenty of other instructions now to keep the processor busy } + { while it handles the (possibly unaligned) store) } + stw r5,0(r3) + { r3 := align(r3,4) } + add r3,r3,r10 + { decrease count with number of bytes already stored } + sub r4,r4,r10 + blt cr1,LFillCharSmall + { if we have to fill with 0 (which happens a lot), we can simply use } + { dcbz for the most part, which is very fast, so make a special case } + { for that } + cmplwi cr1,r5,0 + { align to a multiple of 32 (and immediately check whether we aren't } + { already 32 byte aligned) } + rlwinm. r10,r3,0,31-5+1,31 + { setup r3 for using update forms of store instructions } + subi r3,r3,4 + { get number of bytes to store } + subfic r10,r10,32 + { if already 32byte aligned, skip align loop } + beq L32ByteAlignLoopDone + { substract from the total count } + sub r4,r4,r10 +L32ByteAlignLoop: + { we were already aligned to 4 byres, so this will count down to } + { exactly 0 } + subic. r10,r10,4 + stwu r5,4(r3) + bne L32ByteAlignLoop +L32ByteAlignLoopDone: + { get the amount of 32 byte blocks } + srwi r10,r4,5 + { and keep the rest in r4 (recording whether there is any rest) } + rlwinm. r4,r4,0,31-5+2,31 + { move to ctr } + mtctr r10 + { check how many rest there is (to decide whether we'll use } + { FillCharSmall or FillCharVerySmall) } + cmpl cr7,r4,11 + { if filling with zero, only use dcbz } + bne cr1, LFillCharNoZero + { make r3 point again to the actual store position } + addi r3,r3,4 +LFillCharDCBZLoop: + dcbz 0,r3 + addi r3,r3,32 + bdnz LFillCharDCBZLoop + { if there was no rest, we're finished } + beq LFillCharDone + b LFillCharSmall +LFillCharNoZero: +{$ifdef ABI_AIX} + stw r5,0(sp) + stw r5,4(sp) + lfd f0,0(sp) +{$else ABI_AIX} + stw r5,temp + stw r5,4+temp + lfd f0,temp +{$endif ABI_AIX} + { make r3 point to address-8, so we're able to use fp double stores } + { with update (it's already -4 now) } + subi r3,r3,4 + { load r10 with 8, so that dcbz uses the correct address } +LFillChar32ByteLoop: + dcbz r3,r10 + stfdu f0,8(r3) + stfdu f0,8(r3) + stfdu f0,8(r3) + stfdu f0,8(r3) + bdnz LFillChar32ByteLoop + { if there was no rest, we're finished } + beq LFillCharDone +LFillCharSmall: + { when we arrive here, we're already 4 byte aligned } + { get count div 4 to store dwords } + srwi r10,r4,2 + { get ready for use of update stores } + subi r3,r3,4 + mtctr r10 + rlwinm. r4,r4,0,31-2+1,31 +LFillCharSmallLoop: + stwu r5,4(r3) + bdnz LFillCharSmallLoop + { if nothing left, stop } + beq LFillCharDone + { get ready to store bytes } + addi r3,r3,4 +LFillCharVerySmall: + mtctr r4 + subi r3,r3,1 +LFillCharVerySmallLoop: + stbu r5,1(r3) + bdnz LFillCharVerySmallLoop +LFillCharDone: +end; + + +{$define FPC_SYSTEM_HAS_FILLDWORD} +procedure filldword(var x;count : longint;value : dword); +assembler; +asm +{ registers: + r3 x + r4 count + r5 value + r13 value.value + r14 ptr to dest word + r15 increment 1 + r16 increment 2 + r17 scratch + r18 scratch + f1 value.value.value.value +} + cmpwi cr0,r3,0 + mtctr r4 + subi r3,r3,4 + ble .FillWordEnd //if count<=0 Then Exit +.FillWordLoop: + stwu r5,4(r3) + bdnz .FillWordLoop +.FillWordEnd: +end ['R3','R4','R5','CTR']; + + +{$define FPC_SYSTEM_HAS_INDEXBYTE} +function IndexByte(const buf;len:longint;b:byte):longint; assembler; +{ input: r3 = buf, r4 = len, r5 = b } +{ output: r3 = position of b in buf (-1 if not found) } +asm + { load the begin of the buffer in the data cache } + dcbt 0,r3 + cmplwi r4,0 + mtctr r4 + subi r10,r3,1 + mr r0,r3 + { assume not found } + li r3,-1 + beq LIndexByteDone +LIndexByteLoop: + lbzu r9,1(r10) + cmplw r9,r5 + bdnzf cr0*4+eq,LIndexByteLoop + { r3 still contains -1 here } + bne LIndexByteDone + sub r3,r10,r0 +LIndexByteDone: +end ['R0','R3','R9','R10','CR0','CTR']; + + +{$define FPC_SYSTEM_HAS_INDEXWORD} +function IndexWord(const buf;len:longint;b:word):longint; assembler; +{ input: r3 = buf, r4 = len, r5 = b } +{ output: r3 = position of b in buf (-1 if not found) } +asm + { load the begin of the buffer in the data cache } + dcbt 0,r3 + cmplwi r4,0 + mtctr r4 + subi r10,r3,2 + mr r0,r3 + { assume not found } + li r3,-1 + beq LIndexWordDone +LIndexWordLoop: + lhzu r9,2(r10) + cmplw r9,r5 + bdnzf cr0*4+eq,LIndexWordLoop + { r3 still contains -1 here } + bne LIndexWordDone + sub r3,r10,r0 +LIndexWordDone: +end ['R0','R3','R9','R10','CR0','CTR']; + + +{$define FPC_SYSTEM_HAS_INDEXDWORD} +function IndexDWord(const buf;len:longint;b:DWord):longint; assembler; +{ input: r3 = buf, r4 = len, r5 = b } +{ output: r3 = position of b in buf (-1 if not found) } +asm + { load the begin of the buffer in the data cache } + dcbt 0,r3 + cmplwi r4,0 + mtctr r4 + subi r10,r3,4 + mr r0,r3 + { assume not found } + li r3,-1 + beq LIndexDWordDone +LIndexDWordLoop: + lwzu r9,4(r30) + cmplw r9,r5 + bdnzf cr0*4+eq, LIndexDWordLoop + { r3 still contains -1 here } + bne LIndexDWordDone + sub r3,r10,r0 +LIndexDWordDone: +end ['R0','R3','R9','R10','CR0','CTR']; + +{$define FPC_SYSTEM_HAS_COMPAREBYTE} +function CompareByte(const buf1,buf2;len:longint):longint; assembler; +{ input: r3 = buf1, r4 = buf2, r5 = len } +{ output: r3 = 0 if equal, < 0 if buf1 < str2, > 0 if buf1 > str2 } +{ note: almost direct copy of strlcomp() from strings.inc } +asm + { load the begin of the first buffer in the data cache } + dcbt 0,r3 + { use r0 instead of r3 for buf1 since r3 contains result } + cmplwi r5,0 + mtctr r5 + subi r11,r3,1 + subi r4,r4,1 + li r3,0 + beq LCompByteDone +LCompByteLoop: + { load next chars } + lbzu r9,1(r11) + lbzu r10,1(r4) + { calculate difference } + sub. r3,r9,r10 + { if chars not equal or at the end, we're ready } + bdnzt cr0*4+eq, LCompByteLoop +LCompByteDone: +end ['R0','R3','R4','R9','R10','R11','CR0','CTR']; + +{$define FPC_SYSTEM_HAS_COMPAREWORD} +function CompareWord(const buf1,buf2;len:longint):longint; assembler; +{ input: r3 = buf1, r4 = buf2, r5 = len } +{ output: r3 = 0 if equal, < 0 if buf1 < str2, > 0 if buf1 > str2 } +{ note: almost direct copy of strlcomp() from strings.inc } +asm + { load the begin of the first buffer in the data cache } + dcbt 0,r3 + { use r0 instead of r3 for buf1 since r3 contains result } + cmplwi r5,0 + mtctr r5 + subi r11,r3,2 + subi r4,r4,2 + li r3,0 + beq LCompWordDone +LCompWordLoop: + { load next chars } + lhzu r9,2(r11) + lhzu r10,2(r4) + { calculate difference } + sub. r3,r9,r10 + { if chars not equal or at the end, we're ready } + bdnzt cr0*4+eq, LCompWordLoop +LCompWordDone: +end ['R0','R3','R4','R9','R10','R11','CR0','CTR']; + + +{$define FPC_SYSTEM_HAS_COMPAREDWORD} +function CompareDWord(const buf1,buf2;len:longint):longint; assembler; +{ input: r3 = buf1, r4 = buf2, r5 = len } +{ output: r3 = 0 if equal, < 0 if buf1 < str2, > 0 if buf1 > str2 } +{ note: almost direct copy of strlcomp() from strings.inc } +asm + { load the begin of the first buffer in the data cache } + dcbt 0,r3 + { use r0 instead of r3 for buf1 since r3 contains result } + cmplwi r5,0 + mtctr r5 + subi r11,r3,4 + subi r4,r4,4 + li r3,0 + beq LCompDWordDone +LCompDWordLoop: + { load next chars } + lwzu r9,4(r11) + lwzu r10,4(r4) + { calculate difference } + sub. r3,r9,r10 + { if chars not equal or at the end, we're ready } + bdnzt cr0*4+eq, LCompDWordLoop +LCompDWordDone: +end ['R0','R3','R4','R9','R10','R11','CR0','CTR']; + +{$define FPC_SYSTEM_HAS_INDEXCHAR0} +function IndexChar0(const buf;len:longint;b:Char):longint; assembler; +{ input: r3 = buf, r4 = len, r5 = b } +{ output: r3 = position of found position (-1 if not found) } +asm + { load the begin of the buffer in the data cache } + dcbt 0,r3 + { length = 0? } + cmplwi r4,0 + mtctr r4 + subi r9,r3,1 + mr r0,r9 + { assume not found } + li r3,-1 + { if yes, do nothing } + beq LIndexChar0Done + subi r3,r3,1 +LIndexChar0Loop: + lbzu r10,1(r9) + cmplwi cr1,r10,0 + cmplw r10,r5 + beq cr1,LIndexChar0Done + bdnzf cr0*4+eq, LIndexChar0Loop + bne LIndexChar0Done + sub r3,r9,r0 +LIndexChar0Done: +end ['R0','R3','R4','R9','R10','CR0','CTR']; + + +{**************************************************************************** + Object Helpers +****************************************************************************} + +{ use generic implementation for now } +{ that's a problem currently, the generic has a another prototyp than this defined in compproc.inc (FK) } + +{$define FPC_SYSTEM_HAS_FPC_HELP_CONSTRUCTOR} +procedure fpc_help_constructor; assembler;compilerproc; +asm +end; + +{$define FPC_SYSTEM_HAS_FPC_HELP_FAIL} +procedure fpc_help_fail;assembler;[public,alias:'FPC_HELP_FAIL']; compilerproc; +assembler; +asm +{$warning FIX ME!} +// !!!!!!!!!!! +end; + + +{$define FPC_SYSTEM_HAS_FPC_HELP_DESTRUCTOR} +{ use generic implementation for now } +{ that's a problem currently, the generic has a another prototyp than this defined in compproc.inc (FK) } + +procedure fpc_help_destructor;assembler; compilerproc; +asm +end; + +{$define FPC_SYSTEM_HAS_FPC_NEW_CLASS} +procedure fpc_new_class;assembler;[public,alias:'FPC_NEW_CLASS']; compilerproc; +assembler; +asm +{$warning FIX ME!} +// !!!!!!!!!!! +end; + + +{$define FPC_SYSTEM_HAS_FPC_DISPOSE_CLASS} +procedure fpc_dispose_class;assembler;[public,alias:'FPC_DISPOSE_CLASS']; compilerproc; +assembler; +asm +{$warning FIX ME!} +// !!!!!!!!!!! +end; + +{$define FPC_SYSTEM_HAS_FPC_HELP_FAIL_CLASS} +procedure fpc_help_fail_class;assembler;[public,alias:'FPC_HELP_FAIL_CLASS']; {$ifdef hascompilerproc} compilerproc; {$endif} +{ a non zero class must allways be disposed + VMT is allways at pos 0 } +assembler; +asm +{$warning FIX ME!} +// !!!!!!!!!!! +end; + + + +{$define FPC_SYSTEM_HAS_FPC_CHECK_OBJECT} +{ use generic implementation for now } +{ that's a problem currently, the generic has a another prototy than this defined in compproc.inc (FK) } +procedure fpc_check_object(obj : pointer);assembler; compilerproc; +asm +{$warning FIX ME!} +// !!!!!!!!!!! +end; + +{ use generic implementation for now } +{ that's a problem currently, the generic has a another prototy than this defined in compproc.inc (FK) } +{$define FPC_SYSTEM_HAS_FPC_CHECK_OBJECT_EXT} +procedure fpc_check_object_ext; compilerproc;assembler; +asm +{$warning FIX ME!} +// !!!!!!!!!!! +end; + +{**************************************************************************** + String +****************************************************************************} + +{$define FPC_SYSTEM_HAS_FPC_SHORTSTR_COPY} +function fpc_shortstr_to_shortstr(len:longint; const sstr: shortstring): shortstring; [public,alias: 'FPC_SHORTSTR_TO_SHORTSTR']; compilerproc; +assembler; +{ input: r3: pointer to result, r4: len, r5: sstr } +asm + { load length source } + lbz r10,0(r5) + { load the begin of the dest buffer in the data cache } + dcbtst r0,r3 + + { put min(length(sstr),len) in r3 } + subc r0,r4,r10 { r0 := r3 - r10 } + subfme r4,r4 { if r3 >= r4 then r3' := 0 else r3' := -1 } + and r4,r0,r4 { if r3 >= r4 then r3' := 0 else r3' := r3-r10 } + add r4,r4,r10 { if r3 >= r4 then r3' := r10 else r3' := r3 } + + cmplwi r4,0 + { put length in ctr } + mtctr r4 + stb r4,0(r3) + beq LShortStrCopyDone +LShortStrCopyLoop: + lbzu r0,1(r5) + stbu r0,1(r3) + bdnz LShortStrCopyLoop +LShortStrCopyDone: +end ['R0','R3','R4','R5','R10','CR0','CTR']; + + +{$define FPC_SYSTEM_HAS_FPC_SHORTSTR_COPY} +procedure fpc_shortstr_copy(len:longint;sstr,dstr:pointer);[public,alias:'FPC_SHORTSTR_COPY']; +assembler; +{ input: r3: len, r4: sstr, r5: dstr } +asm + { load length source } + lbz r10,0(r4) + { load the begin of the dest buffer in the data cache } + dcbtst r0,r5 + + { put min(length(sstr),len) in r3 } + subc r0,r3,r10 { r0 := r3 - r10 } + subfme r3,r3 { if r3 >= r4 then r3' := 0 else r3' := -1 } + and r3,r0,r3 { if r3 >= r4 then r3' := 0 else r3' := r3-r10 } + add r3,r3,r10 { if r3 >= r4 then r3' := r10 else r3' := r3 } + + cmplwi r3,0 + { put length in ctr } + mtctr r3 + stb r3,0(r5) + beq LShortStrCopyDone2 +LShortStrCopyLoop2: + lbzu r0,1(r4) + stbu r0,1(r5) + bdnz LShortStrCopyLoop2 +LShortStrCopyDone2: +end ['R0','R3','R4','R5','R10','CR0','CTR']; + +{$define FPC_SYSTEM_HAS_FPC_SHORTSTR_CONCAT} +function fpc_shortstr_concat(const s1,s2: shortstring): shortstring; compilerproc; +{ expects that results (r3) contains a pointer to the current string and s1 } +{ (r4) a pointer to the one that has to be concatenated } +assembler; +asm + { load length s1 } + lbz r9, 0(r4) + { load length result } + lbz r10, 0(r3) + { go to last current character of result } + add r4,r9,r4 + + { calculate min(length(s1),255-length(result)) } + subfic r9,r9,255 + subc r8,r9,r10 { r8 := r9 - r10 } + subfme r9,r9 { if r9 >= r10 then r9' := 0 else r9' := -1 } + and r9,r8,r9 { if r9 >= r10 then r9' := 0 else r9' := r9-r8 } + add r9,r9,r10 { if r9 >= r10 then r9' := r10 else r9' := r9 } + + { and concatenate } + mtctr r9 +LShortStrConcatLoop: + lbzu r10,1(r4) + stbu r10,1(r3) + bdnz LShortStrConcatLoop +end ['R3','R4','R8','R9','R10','CTR']; + + +{$define FPC_SYSTEM_HAS_FPC_SHORTSTR_COMPARE} +function fpc_shortstr_compare(const dstr,sstr:shortstring): longint; [public,alias:'FPC_SHORTSTR_COMPARE']; compilerproc; +assembler; +asm + { load length sstr } + lbz r9,0(r4) + { load length dstr } + lbz r10,0(r3) + { save their difference for later and } + { calculate min(length(sstr),length(dstr)) } + subc r0,r9,r10 { r0 := r9 - r10 } + subfme r9,r9 { if r9 >= r10 then r9' := 0 else r9' := -1 } + and r9,r0,r9 { if r9 >= r10 then r9' := 0 else r9' := r9-r8 } + add r9,r9,r10 { if r9 >= r10 then r9' := r10 else r9' := r9 } + + { first compare dwords (length/4) } + srwi. r8,r9,2 + { keep length mod 4 for the ends } + rlwinm r9,r9,0,30,31 + { already check whether length mod 4 = 0 } + cmplwi cr1,r9,0 + { length div 4 in ctr for loop } + mtctr r8 + { if length < 3, goto byte comparing } + beq LShortStrCompare1 + { setup for use of update forms of load/store with dwords } + subi r4,r4,3 + subi r8,r3,3 +LShortStrCompare4Loop: + lwzu r3,4(r4) + lwzu r10,4(r8) + sub. r3,r3,r10 + bdnzt cr0+eq,LShortStrCompare4Loop + { r3 contains result if we stopped because of "ne" flag } + bne LShortStrCompareDone + { setup for use of update forms of load/store with bytes } + addi r4,r4,3 + addi r8,r8,3 +LShortStrCompare1: + { if comparelen mod 4 = 0, skip this and return the difference in } + { lengths } + beq cr1,LShortStrCompareLen +LShortStrCompare1Loop: + lbzu r3,1(r4) + lbzu r10,1(r8) + sub. r3,r3,r10 + bdnzt cr0+eq,LShortStrCompare4Loop + bne LShortStrCompareDone +LShortStrCompareLen: + { also return result in flags, maybe we can use this in the CG } + mr. r3,r0 +LShortStrCompareDone: +end ['R0','R3','R4','R8','R9','R10','CR0','CR1','CTR']; + + +{$define FPC_SYSTEM_HAS_FPC_PCHAR_TO_SHORTSTR} +function fpc_pchar_to_shortstr(p:pchar):shortstring;[public,alias:'FPC_PCHAR_TO_SHORTSTR']; compilerproc; +assembler; +{$include strpas.inc} + + +{$define FPC_SYSTEM_HAS_STRLEN} +function strlen(p:pchar):longint;assembler; +{$include strlen.inc} + + +{$define FPC_SYSTEM_HAS_GET_FRAME} +function get_frame:longint;assembler; +asm + {$warning FIX ME!} + // !!!!!!! depends on ABI !!!!!!!! +end ['R3']; + + +{$define FPC_SYSTEM_HAS_GET_CALLER_ADDR} +function get_caller_addr(framebp:longint):longint;assembler; +asm + {$warning FIX ME!} + // !!!!!!! depends on ABI !!!!!!!! +end ['R3']; + + +{$define FPC_SYSTEM_HAS_GET_CALLER_FRAME} +function get_caller_frame(framebp:longint):longint;assembler; +asm + {$warning FIX ME!} + // !!!!!!! depends on ABI !!!!!!!! +end ['R3']; + +{$define FPC_SYSTEM_HAS_ABS_LONGINT} +function abs(l:longint):longint; assembler;[internconst:in_const_abs]; +asm + srawi r0,r3,31 + add r3,r0,r3 + xor r3,r3,r0 +end ['R0','R3']; + + +{**************************************************************************** + Math +****************************************************************************} + +{$define FPC_SYSTEM_HAS_ODD_LONGINT} +function odd(l:longint):boolean;assembler;[internconst:in_const_odd]; +asm + rlwinm r3,r3,0,31,31 +end ['R3']; + + +{$define FPC_SYSTEM_HAS_SQR_LONGINT} +function sqr(l:longint):longint;assembler;[internconst:in_const_sqr]; +asm + mullw r3,r3,r3 +end ['R3']; + + +{$define FPC_SYSTEM_HAS_SPTR} +Function Sptr : Longint;assembler; +asm + mr r3,r1 +end ['R3']; + + +{**************************************************************************** + Str() +****************************************************************************} + +{ int_str: generic implementation is used for now } + + +{**************************************************************************** + Multithreading +****************************************************************************} + +{ do a thread save inc/dec } + +function declocked(var l : longint) : boolean;assembler; +{ input: address of l in r3 } +{ output: boolean indicating whether l is zero after decrementing } +asm +LDecLockedLoop: +{$ifdef MT} + lwarx r10,0,r3 + subi r10,r10,1 + stwcx. r10,0,r3 + bne- LDecLockedLoop +{$else MT} + lwzx r10,0,r3 + subi r10,r10,1 + stw r10,0(r3) +{$endif MT} + mr. r3,r10 +end ['R3','R10']; + +procedure inclocked(var l : longint);assembler; +asm +LIncLockedLoop: +{$ifdef MT} + lwarx r10,0,r3 + addi r10,r10,1 + stwcx. r10,0,r3 + bne- LDecLockedLoop +{$else MT} + lwzx r10,0,r3 + addi r10,r10,1 + stw r10,0(r3) +{$endif MT} +end ['R3','R10']; + + +{ $Log$ - Revision 1.16 2002-08-31 16:08:36 florian - * fixed undefined labels - - Revision 1.15 2002/08/31 13:11:11 florian - * several fixes for Linux/PPC compilation - - Revision 1.14 2002/08/18 22:11:10 florian - * fixed remaining assembler errors - - Revision 1.13 2002/08/18 21:37:48 florian - * several errors in inline assembler fixed - - Revision 1.12 2002/08/10 17:14:36 jonas - * various fixes, mostly changing the names of the modifies registers to - upper case since that seems to be required by the compiler - - Revision 1.11 2002/07/30 17:29:53 florian - + dummy setjmp and longjmp added - + dummy implemtation of the destructor helper - - Revision 1.10 2002/07/28 21:39:29 florian - * made abs a compiler proc if it is generic - - Revision 1.9 2002/07/28 20:43:49 florian - * several fixes for linux/powerpc - * several fixes to MT - - Revision 1.8 2002/07/26 15:45:56 florian - * changed multi threading define: it's MT instead of MTRTL - - Revision 1.7 2001/09/28 13:28:49 jonas - * small changes to move (different count values trigger the selection of - moving bytes instead dwords/doubles and move dcbt instruction) - + implemented fillchar (untested) - - Revision 1.6 2001/09/27 15:30:29 jonas - * conversion to compilerproc and to structure used by i386 rtl - * some bugfixes - * powerpc.inc is almost complete (only fillchar/word/dword, get_frame etc - and the class helpers are still needed - - removed unnecessary register saving in set.inc (thanks to compilerproc) - * use registers reserved for parameters as much as possible instead of - those reserved for local vars (since those have to be saved by the - called anyway, while the ones for local vars have to be saved by the - callee) - - Revision 1.5 2001/07/07 12:46:12 jonas - * some small bugfixes and cache optimizations - - Revision 1.4 2001/03/03 13:53:36 jonas - * fixed small bug in move - - Revision 1.3 2001/03/02 13:24:10 jonas - + new, complete implementation of move procedure (including support for - overlapping regions) - - Revision 1.2 2001/02/11 17:59:46 jonas - * implemented several more procedures - - Revision 1.1 2000/07/27 07:32:12 jonas - + initial version by Casey Duncan (not yet thoroughly debugged or complete) -} + Revision 1.17 2002-08-31 21:29:57 florian + * several PC related fixes + + Revision 1.16 2002/08/31 16:08:36 florian + * fixed undefined labels + + Revision 1.15 2002/08/31 13:11:11 florian + * several fixes for Linux/PPC compilation + + Revision 1.14 2002/08/18 22:11:10 florian + * fixed remaining assembler errors + + Revision 1.13 2002/08/18 21:37:48 florian + * several errors in inline assembler fixed + + Revision 1.12 2002/08/10 17:14:36 jonas + * various fixes, mostly changing the names of the modifies registers to + upper case since that seems to be required by the compiler + + Revision 1.11 2002/07/30 17:29:53 florian + + dummy setjmp and longjmp added + + dummy implemtation of the destructor helper + + Revision 1.10 2002/07/28 21:39:29 florian + * made abs a compiler proc if it is generic + + Revision 1.9 2002/07/28 20:43:49 florian + * several fixes for linux/powerpc + * several fixes to MT + + Revision 1.8 2002/07/26 15:45:56 florian + * changed multi threading define: it's MT instead of MTRTL + + Revision 1.7 2001/09/28 13:28:49 jonas + * small changes to move (different count values trigger the selection of + moving bytes instead dwords/doubles and move dcbt instruction) + + implemented fillchar (untested) + + Revision 1.6 2001/09/27 15:30:29 jonas + * conversion to compilerproc and to structure used by i386 rtl + * some bugfixes + * powerpc.inc is almost complete (only fillchar/word/dword, get_frame etc + and the class helpers are still needed + - removed unnecessary register saving in set.inc (thanks to compilerproc) + * use registers reserved for parameters as much as possible instead of + those reserved for local vars (since those have to be saved by the + called anyway, while the ones for local vars have to be saved by the + callee) + + Revision 1.5 2001/07/07 12:46:12 jonas + * some small bugfixes and cache optimizations + + Revision 1.4 2001/03/03 13:53:36 jonas + * fixed small bug in move + + Revision 1.3 2001/03/02 13:24:10 jonas + + new, complete implementation of move procedure (including support for + overlapping regions) + + Revision 1.2 2001/02/11 17:59:46 jonas + * implemented several more procedures + + Revision 1.1 2000/07/27 07:32:12 jonas + + initial version by Casey Duncan (not yet thoroughly debugged or complete) +} diff --git a/rtl/unix/sysunix.inc b/rtl/unix/sysunix.inc index 1453416e0f..beb17bcabd 100644 --- a/rtl/unix/sysunix.inc +++ b/rtl/unix/sysunix.inc @@ -1,880 +1,883 @@ -{ - $Id$ - This file is part of the Free Pascal run time library. - Copyright (c) 1999-2000 by Michael Van Canneyt, - member of the Free Pascal development team. - - This is the core of the system unit *nix systems (now FreeBSD - and Unix). - - See the file COPYING.FPC, included in this distribution, - for details about the copyright. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - **********************************************************************} - -{ These things are set in the makefile, } -{ But you can override them here.} - -{ If you use an aout system, set the conditional AOUT} -{ $Define AOUT} - -{$I system.inc} - -{ used in syscall to report errors.} -var - Errno : longint; - -{ Include constant and type definitions } -{$i errno.inc } { Error numbers } -{$i sysnr.inc } { System call numbers } -{$i sysconst.inc } { Miscellaneous constants } -{$i systypes.inc } { Types needed for system calls } - -{ Read actual system call definitions. } -{$i signal.inc} -{$i syscalls.inc } - - -{***************************************************************************** - Misc. System Dependent Functions -*****************************************************************************} - -{$ifdef I386} -{ this should be defined in i386 directory !! PM } -const - fpucw : word = $1332; - FPU_Invalid = 1; - FPU_Denormal = 2; - FPU_DivisionByZero = 4; - FPU_Overflow = 8; - FPU_Underflow = $10; - FPU_StackUnderflow = $20; - FPU_StackOverflow = $40; - -{$endif I386} - -Procedure ResetFPU; -begin -{$ifdef I386} - asm - fninit - fldcw fpucw - end; -{$endif I386} -end; - - -procedure prthaltproc;external name '_haltproc'; - -Procedure System_exit; -Begin - prthaltproc; -End; - - -Function ParamCount: Longint; -Begin - Paramcount:=argc-1; -End; - - -Function ParamStr(l: Longint): String; -var - link, - hs : string; - i : longint; -begin - if l=0 then - begin - str(sys_getpid,hs); - {$ifdef FreeBSD} - hs:='/proc/'+hs+'/file'#0; - {$else} - hs:='/proc/'+hs+'/exe'#0; - {$endif} - i:=Sys_readlink(@hs[1],@link[1],high(link)); - { it must also be an absolute filename, linux 2.0 points to a memory - location so this will skip that } - if (i>0) and (link[1]='/') then - begin - link[0]:=chr(i); - paramstr:=link; - end - else - paramstr:=strpas(argv[0]); - end - else - if (l>0) and (l-1 then - errno:=0; - {! It must be -1, not 0 as before, see heap.inc. Should be in sysmmap?} -end; - - -{ include standard heap management } -{$I heap.inc} - - -{***************************************************************************** - Low Level File Routines -*****************************************************************************} - -{ - The lowlevel file functions should take care of setting the InOutRes to the - correct value if an error has occured, else leave it untouched -} - -Procedure Errno2Inoutres; -{ - Convert ErrNo error to the correct Inoutres value -} - -begin - if ErrNo=0 then { Else it will go through all the cases } - exit; - If errno<0 then Errno:=-errno; - case ErrNo of - Sys_ENFILE, - Sys_EMFILE : Inoutres:=4; - Sys_ENOENT : Inoutres:=2; - Sys_EBADF : Inoutres:=6; - Sys_ENOMEM, - Sys_EFAULT : Inoutres:=217; - Sys_EINVAL : Inoutres:=218; - Sys_EPIPE, - Sys_EINTR, - Sys_EIO, - Sys_EAGAIN, - Sys_ENOSPC : Inoutres:=101; - Sys_ENAMETOOLONG, - Sys_ELOOP, - Sys_ENOTDIR : Inoutres:=3; - Sys_EROFS, - Sys_EEXIST, - Sys_EISDIR, - Sys_ENOTEMPTY, - Sys_EACCES : Inoutres:=5; - Sys_ETXTBSY : Inoutres:=162; - else - InOutRes := Integer(Errno); - end; -end; - - -Procedure Do_Close(Handle:Longint); -Begin - sys_close(Handle); - {Errno2Inoutres;} -End; - - -Procedure Do_Erase(p:pchar); -{$ifdef BSD} - var FileInfo : Stat; -{$endif} - -Begin - {$ifdef BSD} {or POSIX} - { verify if the filename is actually a directory } - { if so return error and do nothing, as defined } - { by POSIX } - if sys_stat(p,fileinfo)<0 then - begin - Errno2Inoutres; - exit; - end; - {$ifdef BSD} - if (fileinfo.mode and STAT_IFMT)=STAT_IFDIR then - {$else} - if s_ISDIR(fileinfo.st_mode) then - {$endif} - begin - InOutRes := 2; - exit; - end; - {$endif} - sys_unlink(p); - Errno2Inoutres; - {$ifdef Linux} - { tp compatible result } - if (Errno=Sys_EISDIR) then - InOutRes:=2; - {$endif} -End; - - -Procedure Do_Rename(p1,p2:pchar); -Begin - sys_rename(p1,p2); - Errno2Inoutres; -End; - -Function Do_Write(Handle,Addr,Len:Longint):longint; -Begin - repeat - Do_Write:=sys_write(Handle,pchar(addr),len); - until ErrNo<>Sys_EINTR; - Errno2Inoutres; - if Do_Write<0 then - Do_Write:=0; -End; - - -Function Do_Read(Handle,Addr,Len:Longint):Longint; -Begin - repeat - Do_Read:=sys_read(Handle,pchar(addr),len); - until ErrNo<>Sys_EINTR; - Errno2Inoutres; - if Do_Read<0 then - Do_Read:=0; -End; - - -Function Do_FilePos(Handle: Longint): Longint; -Begin - Do_FilePos:=sys_lseek(Handle, 0, Seek_Cur); - Errno2Inoutres; -End; - - -Procedure Do_Seek(Handle,Pos:Longint); -Begin - sys_lseek(Handle, pos, Seek_set); - errno2inoutres; -End; - - -Function Do_SeekEnd(Handle:Longint): Longint; -begin - Do_SeekEnd:=sys_lseek(Handle,0,Seek_End); - errno2inoutres; -end; - -Function Do_FileSize(Handle:Longint): Longint; -var - Info : Stat; -Begin - if sys_fstat(handle,info)=0 then - Do_FileSize:=Info.Size - else - Do_FileSize:=0; - Errno2Inoutres; -End; - - -Procedure Do_Truncate(Handle,fPos:longint); -begin - sys_ftruncate(handle,fpos); - Errno2Inoutres; -end; - - -Procedure Do_Open(var f;p:pchar;flags:longint); -{ - FileRec and textrec have both Handle and mode as the first items so - they could use the same routine for opening/creating. - when (flags and $100) the file will be append - when (flags and $1000) the file will be truncate/rewritten - when (flags and $10000) there is no check for close (needed for textfiles) -} -var - oflags : longint; - -Begin -{ close first if opened } - if ((flags and $10000)=0) then - begin - case FileRec(f).mode of - fminput,fmoutput,fminout : Do_Close(FileRec(f).Handle); - fmclosed : ; - else - begin - inoutres:=102; {not assigned} - exit; - end; - end; - end; -{ reset file Handle } - FileRec(f).Handle:=UnusedHandle; -{ We do the conversion of filemodes here, concentrated on 1 place } - case (flags and 3) of - 0 : begin - oflags :=Open_RDONLY; - FileRec(f).mode:=fminput; - end; - 1 : begin - oflags :=Open_WRONLY; - FileRec(f).mode:=fmoutput; - end; - 2 : begin - oflags :=Open_RDWR; - FileRec(f).mode:=fminout; - end; - end; - if (flags and $1000)=$1000 then - oflags:=oflags or (Open_CREAT or Open_TRUNC) - else - if (flags and $100)=$100 then - oflags:=oflags or (Open_APPEND); -{ empty name is special } - if p[0]=#0 then - begin - case FileRec(f).mode of - fminput : - FileRec(f).Handle:=StdInputHandle; - fminout, { this is set by rewrite } - fmoutput : - FileRec(f).Handle:=StdOutputHandle; - fmappend : - begin - FileRec(f).Handle:=StdOutputHandle; - FileRec(f).mode:=fmoutput; {fool fmappend} - end; - end; - exit; - end; -{ real open call } - FileRec(f).Handle:=sys_open(p,oflags,438); - if (ErrNo=Sys_EROFS) and ((OFlags and Open_RDWR)<>0) then - begin - Oflags:=Oflags and not(Open_RDWR); - FileRec(f).Handle:=sys_open(p,oflags,438); - end; - Errno2Inoutres; -End; - - -Function Do_IsDevice(Handle:Longint):boolean; -{ - Interface to Unix ioctl call. - Performs various operations on the filedescriptor Handle. - Ndx describes the operation to perform. - Data points to data needed for the Ndx function. The structure of this - data is function-dependent. -} -var - Data : array[0..255] of byte; {Large enough for termios info} -begin - Do_IsDevice:=(sys_ioctl(handle,IOCTL_TCGETS,@data)<>-1); -end; - - -{***************************************************************************** - UnTyped File Handling -*****************************************************************************} - -{$i file.inc} - -{***************************************************************************** - Typed File Handling -*****************************************************************************} - -{$i typefile.inc} - -{***************************************************************************** - Text File Handling -*****************************************************************************} - -{$DEFINE SHORT_LINEBREAK} -{$DEFINE EXTENDED_EOF} - -{$i text.inc} - -{***************************************************************************** - Directory Handling -*****************************************************************************} - -Procedure MkDir(Const s: String);[IOCheck]; -Var - Buffer: Array[0..255] of Char; -Begin - If (s='') or (InOutRes <> 0) then - exit; - Move(s[1], Buffer, Length(s)); - Buffer[Length(s)] := #0; - sys_mkdir(@buffer, 511); - Errno2Inoutres; -End; - - -Procedure RmDir(Const s: String);[IOCheck]; -Var - Buffer: Array[0..255] of Char; -Begin - if (s ='.') then - InOutRes := 16; - If (s='') or (InOutRes <> 0) then - exit; - Move(s[1], Buffer, Length(s)); - Buffer[Length(s)] := #0; - sys_rmdir(@buffer); - {$ifdef BSD} - if (Errno=Sys_EINVAL) Then - InOutRes:=5 - Else - {$endif} - Errno2Inoutres; -End; - - -Procedure ChDir(Const s: String);[IOCheck]; -Var - Buffer: Array[0..255] of Char; -Begin - If (s='') or (InOutRes <> 0) then - exit; - Move(s[1], Buffer, Length(s)); - Buffer[Length(s)] := #0; - sys_chdir(@buffer); - Errno2Inoutres; - { file not exists is path not found under tp7 } - if InOutRes=2 then - InOutRes:=3; -End; - - -procedure GetDir (DriveNr: byte; var Dir: ShortString); -var - thisdir : stat; - rootino, - thisino, - dotdotino : longint; - rootdev, - thisdev, - dotdotdev : dev_t; - thedir,dummy : string[255]; - dirstream : pdir; - d : pdirent; - mountpoint,validdir : boolean; - predot : string[255]; -begin - drivenr:=0; - dir:=''; - thedir:='/'#0; - if sys_stat(@thedir[1],thisdir)<0 then - exit; - rootino:=thisdir.ino; - rootdev:=thisdir.dev; - thedir:='.'#0; - if sys_stat(@thedir[1],thisdir)<0 then - exit; - thisino:=thisdir.ino; - thisdev:=thisdir.dev; - { Now we can uniquely identify the current and root dir } - thedir:=''; - predot:=''; - while not ((thisino=rootino) and (thisdev=rootdev)) do - begin - { Are we on a mount point ? } - dummy:=predot+'..'#0; - if sys_stat(@dummy[1],thisdir)<0 then - exit; - dotdotino:=thisdir.ino; - dotdotdev:=thisdir.dev; - mountpoint:=(thisdev<>dotdotdev); - { Now, Try to find the name of this dir in the previous one } - dirstream:=opendir (@dummy[1]); - if dirstream=nil then - exit; - repeat - d:=sys_readdir (dirstream); - validdir:=false; - if (d<>nil) and - (not ((d^.name[0]='.') and ((d^.name[1]=#0) or ((d^.name[1]='.') - and (d^.name[2]=#0))))) and - (mountpoint or (d^.ino=thisino)) then - begin - dummy:=predot+'../'+strpas(@(d^.name[0]))+#0; - validdir:=not (sys_stat (@(dummy[1]),thisdir)<0); - end - else - validdir:=false; - until (d=nil) or - ((validdir) and (thisdir.dev=thisdev) and (thisdir.ino=thisino) ); - { At this point, d.name contains the name of the current dir} - if (d<>nil) then - thedir:='/'+strpas(@(d^.name[0]))+thedir; - { closedir also makes d invalid } - if (closedir(dirstream)<0) or (d=nil) then - exit; - thisdev:=dotdotdev; - thisino:=dotdotino; - predot:=predot+'../'; - end; -{ Now rootino=thisino and rootdev=thisdev so we've reached / } - dir:=thedir -end; - -{$ifdef Unix} -{***************************************************************************** - Thread Handling -*****************************************************************************} - -{ include threading stuff, this is os independend part } -{$I thread.inc} -{$endif Unix} - -{***************************************************************************** - SystemUnit Initialization -*****************************************************************************} - -{$ifdef BSD} - procedure SignalToRunerror(Sig: longint; SigContext: SigContextRec;someptr:pointer); cdecl; -{$else} - {$ifdef Solaris} - procedure SignalToRunerror(Sig: longint; SigContext: SigContextRec;someptr:pointer); cdecl; - {$else} - procedure SignalToRunerror(Sig: longint; SigContext: SigContextRec); cdecl; - {$endif} -{$ENDIF} -var - - res,fpustate : word; -begin - res:=0; - case sig of - SIGFPE : - begin - { this is not allways necessary but I don't know yet - how to tell if it is or not PM } -{$ifdef I386} - fpustate:=0; - res:=200; - {$ifndef FreeBSD} - if assigned(SigContext.fpstate) then - fpuState:=SigContext.fpstate^.sw; - {$else} - fpustate:=SigContext.en_sw; - {$ifdef SYSTEM_DEBUG} - writeln('xx:',sigcontext.en_tw,' ',sigcontext.en_cw); - {$endif SYSTEM_DEBUG} - {$endif} - {$ifdef SYSTEM_DEBUG} - Writeln(stderr,'FpuState = ',FpuState); - {$endif SYSTEM_DEBUG} - if (FpuState and $7f) <> 0 then - begin - { first check te more precise options } - if (FpuState and FPU_DivisionByZero)<>0 then - res:=200 - else if (FpuState and FPU_Overflow)<>0 then - res:=205 - else if (FpuState and FPU_Underflow)<>0 then - res:=206 - else if (FpuState and FPU_Denormal)<>0 then - res:=216 - else if (FpuState and (FPU_StackOverflow or FPU_StackUnderflow))<>0 then - res:=207 - else if (FpuState and FPU_Invalid)<>0 then - res:=216 - else - res:=207; {'Coprocessor Error'} - end; -{$endif I386} - ResetFPU; - end; - SIGILL, - SIGBUS, - SIGSEGV : - res:=216; - end; -{ give runtime error at the position where the signal was raised } - if res<>0 then - begin -{$ifdef I386} - {$ifdef FreeBSD} - HandleErrorAddrFrame(res,SigContext.sc_eip,SigContext.sc_ebp); - {$else} - HandleErrorAddrFrame(res,SigContext.eip,SigContext.ebp); - {$endif} -{$else} - HandleError(res); -{$endif} - end; -end; - - -Procedure InstallSignals; -const -{$Ifndef BSD} - {$ifdef solaris} - act: SigActionRec =(sa_flags:SA_SIGINFO;Handler:(sa:@signaltorunerror;sa_mask:0); - {$else} - act: SigActionRec = (handler:(Sa:@SignalToRunError);sa_mask:0;sa_flags:0; - Sa_restorer: NIL); - {$endif} -{$ELSE} - act: SigActionRec = (handler:(Sa:@SignalToRunError);sa_flags:SA_SIGINFO; - sa_mask:0); -{$endif} - - oldact: PSigActionRec = Nil; {Probably not necessary anymore, now - VAR is removed} -begin - ResetFPU; - SigAction(SIGFPE,@act,oldact); -{$ifndef Solaris} - SigAction(SIGSEGV,@act,oldact); - SigAction(SIGBUS,@act,oldact); - SigAction(SIGILL,@act,oldact); -{$endif} -end; - - -procedure SetupCmdLine; -var - bufsize, - len,j, - size,i : longint; - found : boolean; - buf : array[0..1026] of char; - - procedure AddBuf; - begin - reallocmem(cmdline,size+bufsize); - move(buf,cmdline[size],bufsize); - inc(size,bufsize); - bufsize:=0; - end; - -begin - size:=0; - bufsize:=0; - i:=0; - while (isizeof(buf)-2 then - len:=sizeof(buf)-2; - found:=false; - for j:=1 to len do - if argv[i][j]=' ' then - begin - found:=true; - break; - end; - if bufsize+len>=sizeof(buf)-2 then - AddBuf; - if found then - begin - buf[bufsize]:='"'; - inc(bufsize); - end; - move(argv[i]^,buf[bufsize],len); - inc(bufsize,len); - if found then - begin - buf[bufsize]:='"'; - inc(bufsize); - end; - if i0) and (link[1]='/') then + begin + link[0]:=chr(i); + paramstr:=link; + end + else + paramstr:=strpas(argv[0]); + end + else + if (l>0) and (l-1 then + errno:=0; + {! It must be -1, not 0 as before, see heap.inc. Should be in sysmmap?} +end; + + +{ include standard heap management } +{$I heap.inc} + + +{***************************************************************************** + Low Level File Routines +*****************************************************************************} + +{ + The lowlevel file functions should take care of setting the InOutRes to the + correct value if an error has occured, else leave it untouched +} + +Procedure Errno2Inoutres; +{ + Convert ErrNo error to the correct Inoutres value +} + +begin + if ErrNo=0 then { Else it will go through all the cases } + exit; + If errno<0 then Errno:=-errno; + case ErrNo of + Sys_ENFILE, + Sys_EMFILE : Inoutres:=4; + Sys_ENOENT : Inoutres:=2; + Sys_EBADF : Inoutres:=6; + Sys_ENOMEM, + Sys_EFAULT : Inoutres:=217; + Sys_EINVAL : Inoutres:=218; + Sys_EPIPE, + Sys_EINTR, + Sys_EIO, + Sys_EAGAIN, + Sys_ENOSPC : Inoutres:=101; + Sys_ENAMETOOLONG, + Sys_ELOOP, + Sys_ENOTDIR : Inoutres:=3; + Sys_EROFS, + Sys_EEXIST, + Sys_EISDIR, + Sys_ENOTEMPTY, + Sys_EACCES : Inoutres:=5; + Sys_ETXTBSY : Inoutres:=162; + else + InOutRes := Integer(Errno); + end; +end; + + +Procedure Do_Close(Handle:Longint); +Begin + sys_close(Handle); + {Errno2Inoutres;} +End; + + +Procedure Do_Erase(p:pchar); +{$ifdef BSD} + var FileInfo : Stat; +{$endif} + +Begin + {$ifdef BSD} {or POSIX} + { verify if the filename is actually a directory } + { if so return error and do nothing, as defined } + { by POSIX } + if sys_stat(p,fileinfo)<0 then + begin + Errno2Inoutres; + exit; + end; + {$ifdef BSD} + if (fileinfo.mode and STAT_IFMT)=STAT_IFDIR then + {$else} + if s_ISDIR(fileinfo.st_mode) then + {$endif} + begin + InOutRes := 2; + exit; + end; + {$endif} + sys_unlink(p); + Errno2Inoutres; + {$ifdef Linux} + { tp compatible result } + if (Errno=Sys_EISDIR) then + InOutRes:=2; + {$endif} +End; + + +Procedure Do_Rename(p1,p2:pchar); +Begin + sys_rename(p1,p2); + Errno2Inoutres; +End; + +Function Do_Write(Handle,Addr,Len:Longint):longint; +Begin + repeat + Do_Write:=sys_write(Handle,pchar(addr),len); + until ErrNo<>Sys_EINTR; + Errno2Inoutres; + if Do_Write<0 then + Do_Write:=0; +End; + + +Function Do_Read(Handle,Addr,Len:Longint):Longint; +Begin + repeat + Do_Read:=sys_read(Handle,pchar(addr),len); + until ErrNo<>Sys_EINTR; + Errno2Inoutres; + if Do_Read<0 then + Do_Read:=0; +End; + + +Function Do_FilePos(Handle: Longint): Longint; +Begin + Do_FilePos:=sys_lseek(Handle, 0, Seek_Cur); + Errno2Inoutres; +End; + + +Procedure Do_Seek(Handle,Pos:Longint); +Begin + sys_lseek(Handle, pos, Seek_set); + errno2inoutres; +End; + + +Function Do_SeekEnd(Handle:Longint): Longint; +begin + Do_SeekEnd:=sys_lseek(Handle,0,Seek_End); + errno2inoutres; +end; + +Function Do_FileSize(Handle:Longint): Longint; +var + Info : Stat; +Begin + if sys_fstat(handle,info)=0 then + Do_FileSize:=Info.Size + else + Do_FileSize:=0; + Errno2Inoutres; +End; + + +Procedure Do_Truncate(Handle,fPos:longint); +begin + sys_ftruncate(handle,fpos); + Errno2Inoutres; +end; + + +Procedure Do_Open(var f;p:pchar;flags:longint); +{ + FileRec and textrec have both Handle and mode as the first items so + they could use the same routine for opening/creating. + when (flags and $100) the file will be append + when (flags and $1000) the file will be truncate/rewritten + when (flags and $10000) there is no check for close (needed for textfiles) +} +var + oflags : longint; + +Begin +{ close first if opened } + if ((flags and $10000)=0) then + begin + case FileRec(f).mode of + fminput,fmoutput,fminout : Do_Close(FileRec(f).Handle); + fmclosed : ; + else + begin + inoutres:=102; {not assigned} + exit; + end; + end; + end; +{ reset file Handle } + FileRec(f).Handle:=UnusedHandle; +{ We do the conversion of filemodes here, concentrated on 1 place } + case (flags and 3) of + 0 : begin + oflags :=Open_RDONLY; + FileRec(f).mode:=fminput; + end; + 1 : begin + oflags :=Open_WRONLY; + FileRec(f).mode:=fmoutput; + end; + 2 : begin + oflags :=Open_RDWR; + FileRec(f).mode:=fminout; + end; + end; + if (flags and $1000)=$1000 then + oflags:=oflags or (Open_CREAT or Open_TRUNC) + else + if (flags and $100)=$100 then + oflags:=oflags or (Open_APPEND); +{ empty name is special } + if p[0]=#0 then + begin + case FileRec(f).mode of + fminput : + FileRec(f).Handle:=StdInputHandle; + fminout, { this is set by rewrite } + fmoutput : + FileRec(f).Handle:=StdOutputHandle; + fmappend : + begin + FileRec(f).Handle:=StdOutputHandle; + FileRec(f).mode:=fmoutput; {fool fmappend} + end; + end; + exit; + end; +{ real open call } + FileRec(f).Handle:=sys_open(p,oflags,438); + if (ErrNo=Sys_EROFS) and ((OFlags and Open_RDWR)<>0) then + begin + Oflags:=Oflags and not(Open_RDWR); + FileRec(f).Handle:=sys_open(p,oflags,438); + end; + Errno2Inoutres; +End; + + +Function Do_IsDevice(Handle:Longint):boolean; +{ + Interface to Unix ioctl call. + Performs various operations on the filedescriptor Handle. + Ndx describes the operation to perform. + Data points to data needed for the Ndx function. The structure of this + data is function-dependent. +} +var + Data : array[0..255] of byte; {Large enough for termios info} +begin + Do_IsDevice:=(sys_ioctl(handle,IOCTL_TCGETS,@data)<>-1); +end; + + +{***************************************************************************** + UnTyped File Handling +*****************************************************************************} + +{$i file.inc} + +{***************************************************************************** + Typed File Handling +*****************************************************************************} + +{$i typefile.inc} + +{***************************************************************************** + Text File Handling +*****************************************************************************} + +{$DEFINE SHORT_LINEBREAK} +{$DEFINE EXTENDED_EOF} + +{$i text.inc} + +{***************************************************************************** + Directory Handling +*****************************************************************************} + +Procedure MkDir(Const s: String);[IOCheck]; +Var + Buffer: Array[0..255] of Char; +Begin + If (s='') or (InOutRes <> 0) then + exit; + Move(s[1], Buffer, Length(s)); + Buffer[Length(s)] := #0; + sys_mkdir(@buffer, 511); + Errno2Inoutres; +End; + + +Procedure RmDir(Const s: String);[IOCheck]; +Var + Buffer: Array[0..255] of Char; +Begin + if (s ='.') then + InOutRes := 16; + If (s='') or (InOutRes <> 0) then + exit; + Move(s[1], Buffer, Length(s)); + Buffer[Length(s)] := #0; + sys_rmdir(@buffer); + {$ifdef BSD} + if (Errno=Sys_EINVAL) Then + InOutRes:=5 + Else + {$endif} + Errno2Inoutres; +End; + + +Procedure ChDir(Const s: String);[IOCheck]; +Var + Buffer: Array[0..255] of Char; +Begin + If (s='') or (InOutRes <> 0) then + exit; + Move(s[1], Buffer, Length(s)); + Buffer[Length(s)] := #0; + sys_chdir(@buffer); + Errno2Inoutres; + { file not exists is path not found under tp7 } + if InOutRes=2 then + InOutRes:=3; +End; + + +procedure GetDir (DriveNr: byte; var Dir: ShortString); +var + thisdir : stat; + rootino, + thisino, + dotdotino : longint; + rootdev, + thisdev, + dotdotdev : dev_t; + thedir,dummy : string[255]; + dirstream : pdir; + d : pdirent; + mountpoint,validdir : boolean; + predot : string[255]; +begin + drivenr:=0; + dir:=''; + thedir:='/'#0; + if sys_stat(@thedir[1],thisdir)<0 then + exit; + rootino:=thisdir.ino; + rootdev:=thisdir.dev; + thedir:='.'#0; + if sys_stat(@thedir[1],thisdir)<0 then + exit; + thisino:=thisdir.ino; + thisdev:=thisdir.dev; + { Now we can uniquely identify the current and root dir } + thedir:=''; + predot:=''; + while not ((thisino=rootino) and (thisdev=rootdev)) do + begin + { Are we on a mount point ? } + dummy:=predot+'..'#0; + if sys_stat(@dummy[1],thisdir)<0 then + exit; + dotdotino:=thisdir.ino; + dotdotdev:=thisdir.dev; + mountpoint:=(thisdev<>dotdotdev); + { Now, Try to find the name of this dir in the previous one } + dirstream:=opendir (@dummy[1]); + if dirstream=nil then + exit; + repeat + d:=sys_readdir (dirstream); + validdir:=false; + if (d<>nil) and + (not ((d^.name[0]='.') and ((d^.name[1]=#0) or ((d^.name[1]='.') + and (d^.name[2]=#0))))) and + (mountpoint or (d^.ino=thisino)) then + begin + dummy:=predot+'../'+strpas(@(d^.name[0]))+#0; + validdir:=not (sys_stat (@(dummy[1]),thisdir)<0); + end + else + validdir:=false; + until (d=nil) or + ((validdir) and (thisdir.dev=thisdev) and (thisdir.ino=thisino) ); + { At this point, d.name contains the name of the current dir} + if (d<>nil) then + thedir:='/'+strpas(@(d^.name[0]))+thedir; + { closedir also makes d invalid } + if (closedir(dirstream)<0) or (d=nil) then + exit; + thisdev:=dotdotdev; + thisino:=dotdotino; + predot:=predot+'../'; + end; +{ Now rootino=thisino and rootdev=thisdev so we've reached / } + dir:=thedir +end; + +{$ifdef Unix} +{***************************************************************************** + Thread Handling +*****************************************************************************} + +{ include threading stuff, this is os independend part } +{$I thread.inc} +{$endif Unix} + +{***************************************************************************** + SystemUnit Initialization +*****************************************************************************} + +{$ifdef BSD} + procedure SignalToRunerror(Sig: longint; SigContext: SigContextRec;someptr:pointer); cdecl; +{$else} + {$ifdef Solaris} + procedure SignalToRunerror(Sig: longint; SigContext: SigContextRec;someptr:pointer); cdecl; + {$else} + procedure SignalToRunerror(Sig: longint; SigContext: SigContextRec); cdecl; + {$endif} +{$ENDIF} +var + + res,fpustate : word; +begin + res:=0; + case sig of + SIGFPE : + begin + { this is not allways necessary but I don't know yet + how to tell if it is or not PM } +{$ifdef I386} + fpustate:=0; + res:=200; + {$ifndef FreeBSD} + if assigned(SigContext.fpstate) then + fpuState:=SigContext.fpstate^.sw; + {$else} + fpustate:=SigContext.en_sw; + {$ifdef SYSTEM_DEBUG} + writeln('xx:',sigcontext.en_tw,' ',sigcontext.en_cw); + {$endif SYSTEM_DEBUG} + {$endif} + {$ifdef SYSTEM_DEBUG} + Writeln(stderr,'FpuState = ',FpuState); + {$endif SYSTEM_DEBUG} + if (FpuState and $7f) <> 0 then + begin + { first check te more precise options } + if (FpuState and FPU_DivisionByZero)<>0 then + res:=200 + else if (FpuState and FPU_Overflow)<>0 then + res:=205 + else if (FpuState and FPU_Underflow)<>0 then + res:=206 + else if (FpuState and FPU_Denormal)<>0 then + res:=216 + else if (FpuState and (FPU_StackOverflow or FPU_StackUnderflow))<>0 then + res:=207 + else if (FpuState and FPU_Invalid)<>0 then + res:=216 + else + res:=207; {'Coprocessor Error'} + end; +{$endif I386} + ResetFPU; + end; + SIGILL, + SIGBUS, + SIGSEGV : + res:=216; + end; +{ give runtime error at the position where the signal was raised } + if res<>0 then + begin +{$ifdef I386} + {$ifdef FreeBSD} + HandleErrorAddrFrame(res,SigContext.sc_eip,SigContext.sc_ebp); + {$else} + HandleErrorAddrFrame(res,SigContext.eip,SigContext.ebp); + {$endif} +{$else} + HandleError(res); +{$endif} + end; +end; + + +Procedure InstallSignals; +const +{$Ifndef BSD} + {$ifdef solaris} + act: SigActionRec =(sa_flags:SA_SIGINFO;Handler:(sa:@signaltorunerror;sa_mask:0); + {$else} + act: SigActionRec = (handler:(Sa:@SignalToRunError);sa_mask:0;sa_flags:0; + Sa_restorer: NIL); + {$endif} +{$ELSE} + act: SigActionRec = (handler:(Sa:@SignalToRunError);sa_flags:SA_SIGINFO; + sa_mask:0); +{$endif} + + oldact: PSigActionRec = Nil; {Probably not necessary anymore, now + VAR is removed} +begin + ResetFPU; + SigAction(SIGFPE,@act,oldact); +{$ifndef Solaris} + SigAction(SIGSEGV,@act,oldact); + SigAction(SIGBUS,@act,oldact); + SigAction(SIGILL,@act,oldact); +{$endif} +end; + + +procedure SetupCmdLine; +var + bufsize, + len,j, + size,i : longint; + found : boolean; + buf : array[0..1026] of char; + + procedure AddBuf; + begin + reallocmem(cmdline,size+bufsize); + move(buf,cmdline[size],bufsize); + inc(size,bufsize); + bufsize:=0; + end; + +begin + size:=0; + bufsize:=0; + i:=0; + while (isizeof(buf)-2 then + len:=sizeof(buf)-2; + found:=false; + for j:=1 to len do + if argv[i][j]=' ' then + begin + found:=true; + break; + end; + if bufsize+len>=sizeof(buf)-2 then + AddBuf; + if found then + begin + buf[bufsize]:='"'; + inc(bufsize); + end; + move(argv[i]^,buf[bufsize],len); + inc(bufsize,len); + if found then + begin + buf[bufsize]:='"'; + inc(bufsize); + end; + if i