fpc/rtl/i386/i386.inc
1998-03-25 11:18:12 +00:00

901 lines
21 KiB
PHP

{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 1993,97 by the Free Pascal development team.
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.
**********************************************************************}
{****************************************************************************
i386.inc : Processor dependent implementation of the system unit
for the Intel Ix86, x>=3
****************************************************************************}
procedure int_help_constructor;
begin
asm
.globl HELP_CONSTRUCTOR_NE
{$IFDEF LINUX}
.type HELP_CONSTRUCTOR_NE,@function
{$ENDIF}
HELP_CONSTRUCTOR_NE:
.globl HELP_CONSTRUCTOR
{$IFDEF LINUX}
.type HELP_CONSTRUCTOR,@function
{$ENDIF}
HELP_CONSTRUCTOR:
{ Entry without preamble, since we need the ESP of the
constructor }
{ Stack (relative to %ebp):
12 Self
8 VMT-Address
4 main programm-Addr
0 %ebp
}
{eax isn't touched anywhere, so it doesn't have to reloaded}
movl 8(%ebp),%eax
{ initialise self ? }
orl %esi,%esi
jne .LHC_4
{ get memory, but save register first }
{ temporary variable }
subl $4,%esp
movl %esp,%esi
{ Save Register}
pushal
{ Memory size }
pushl (%eax)
pushl %esi
call GETMEM
popal
{ Memory size to %esi }
movl (%esi),%esi
addl $4,%esp
{ If no memory available : fail() }
orl %esi,%esi
jz .LHC_5
{ init self for the constructor }
movl %esi,12(%ebp)
.LHC_4:
{ is there a VMT address ? }
orl %eax,%eax
jnz .LHC_7
{ In case the constructor doesn't do anything, the Zero-Flag }
{ can't be put, because this calls Fail() }
incl %eax
ret
.LHC_7:
{ set zero inside the object }
pushal
pushw $0
pushl (%eax)
pushl %esi
{ }
call .L_FILL_OBJECT
popal
{ set the VMT address for the new created object }
movl %eax,(%esi)
orl %eax,%eax
.LHC_5:
ret
end;
end;
procedure help_fail;
begin
asm
end;
end;
procedure int_new_class;assembler;
asm
.global NEW_CLASS
{$IFDEF LINUX}
.type NEW_CLASS,@function
{$ENDIF}
NEW_CLASS:
{ create class ? }
movl 8(%ebp),%edi
orl %edi,%edi
jz .LNEW_CLASS1
{ esi contains vmt }
pushl %esi
{ call newinstance (class method!) }
call 16(%esi)
{ new instance returns a pointer to the new created }
{ instance in eax }
{ load esi and insert self }
movl %eax,8(%ebp)
movl %eax,%esi
ret
.LNEW_CLASS1:
movl %esi,8(%ebp)
ret
end;
procedure int_dispose_class;assembler;
asm
.global DISPOSE_CLASS
{$IFDEF LINUX}
.type DISPOSE_CLASS,@function
{$ENDIF}
DISPOSE_CLASS:
{ destroy class ? }
movl 8(%ebp),%edi
{ save self }
movl %esi,8(%ebp)
orl %edi,%edi
jz .LDISPOSE_CLASS1
{ no inherited call }
movl (%esi),%edi
{ push self }
pushl %esi
{ call freeinstance }
call 20(%edi)
.LDISPOSE_CLASS1:
{ load self }
movl 8(%ebp),%esi
ret
end;
{ checks for a correct vmt pointer }
procedure co;assembler;
asm
.globl CHECK_OBJECT
{$IFDEF LINUX}
.type CHECK_OBJECT,@function
{$ENDIF}
CHECK_OBJECT:
pushl %edi
movl 8(%esp),%edi
pushl %eax
{ Here we must check if the VMT pointer is nil before }
{ accessing it... }
{ WARNING: Will only probably work with GAS, as fields }
{ are ZEROED automatically in BSS, which might not be }
{ the case with other linkers/assemblers... }
orl %edi,%edi
jz .Lco_re
movl (%edi),%eax
addl 4(%edi),%eax
jnz .Lco_re
popl %eax
popl %edi
ret $4
.Lco_re:
pushw $210
call runerror
end;
procedure int_help_destructor;
begin
asm
{ Stack (relative to %ebp):
12 Self
8 VMT-Address
4 Main program-Addr
0 %ebp
}
.globl HELP_DESTRUCTOR_NE
{$IFDEF LINUX}
.type HELP_DESTRUCTOR_NE,@function
{$ENDIF}
HELP_DESTRUCTOR_NE:
.globl HELP_DESTRUCTOR
{$IFDEF LINUX}
.type HELP_DESTRUCTOR,@function
{$ENDIF}
HELP_DESTRUCTOR:
{ temporary Variable }
subl $4,%esp
movl %esp,%edi
pushal
{ Should the object be resolved ? }
movl 8(%ebp),%eax
orl %eax,%eax
jz .LHD_3
{ Yes, get size from SELF! }
movl 12(%ebp),%eax
{ get VMT-pointer (from Self) to %ebx }
movl (%eax),%ebx
{ And put size on the Stack }
pushl (%ebx)
{ SELF }
{ I think for precaution }
{ that we should clear the VMT here }
movl $0,(%eax)
movl %eax,(%edi)
pushl %edi
call FREEMEM
.LHD_3:
popal
addl $4,%esp
ret
end;
end;
function get_addr(BP : longint) : longint;
begin
asm
movl BP,%eax
cmpl $0,%eax
je .Lnul_address
movl 4(%eax),%eax
.Lnul_address:
movl %eax,__RESULT
end ['EAX'];
end;
function get_next_frame(bp : longint) : longint;
begin
asm
movl bp,%eax
cmpl $0,%eax
je .Lnul_frame
movl (%eax),%eax
.Lnul_frame:
movl %eax,__RESULT
end ['EAX'];
end;
procedure runerror(w : word);[alias: 'runerror'];
function get_addr : longint;
begin
asm
movl (%ebp),%eax
movl 4(%eax),%eax
movl %eax,__RESULT
end ['EAX'];
end;
function get_error_bp : longint;
begin
asm
movl (%ebp),%eax {%ebp of run_error}
movl %eax,__RESULT
end ['EAX'];
end;
begin
errorcode:=w;
exitcode:=w;
erroraddr:=pointer(get_addr);
errorbase:=get_error_bp;
doError:=True;
halt(errorcode);
end;
procedure io1(addr : longint);[public,alias: 'IOCHECK'];
var
l : longint;
begin
{ Since IOCHECK is called directly and only later the optimiser }
{ Maybe also save global registers }
asm
pushal
end;
l:=ioresult;
if l<>0 then
begin
writeln('IO-Error ',l,' at ',addr);
halt(l);
end;
asm
popal
end;
end;
procedure re_overflow;[public,alias: 'RE_OVERFLOW'];
var
addr : longint;
begin
{ Overflow was shortly before the return address }
asm
movl 4(%ebp),%edi
movl %edi,addr
end;
writeln('Overflow at ',addr);
RunError(215);
end;
{ this procedure must save all modified registers except EDI and ESI !!! }
procedure strcopy(dstr,sstr : pointer;len : longint);[public,alias: 'STRCOPY'];
begin
asm
pushl %eax
pushl %ecx
cld
movl 16(%ebp),%edi
movl 12(%ebp),%esi
xorl %eax,%eax
movl 8(%ebp),%ecx
lodsb
cmpl %ecx,%eax
jbe .LStrCopy1
movl %ecx,%eax
.LStrCopy1:
stosb
cmpl $7,%eax
jl .LStrCopy2
movl %edi,%ecx # Align on 32bits
negl %ecx
andl $3,%ecx
subl %ecx,%eax
rep
movsb
movl %eax,%ecx
andl $3,%eax
shrl $2,%ecx
rep
movsl
.LStrCopy2:
movl %eax,%ecx
rep
movsb
popl %ecx
popl %eax
end ['ECX','EAX','ESI','EDI'];
end;
procedure strconcat(s1,s2 : pointer);[public,alias: 'STRCONCAT'];
begin
asm
xorl %ecx,%ecx
movl 12(%ebp),%edi
movl 8(%ebp),%esi
movl %edi,%ebx
movb (%edi),%cl
lea 1(%edi,%ecx),%edi
negl %ecx
xor %eax,%eax
addl $0xff,%ecx
lodsb
cmpl %ecx,%eax
jbe .LStrConcat1
movl %ecx,%eax
.LStrConcat1:
addb %al,(%ebx)
cmpl $7,%eax
jl .LStrConcat2
movl %edi,%ecx # Align on 32bits
negl %ecx
andl $3,%ecx
subl %ecx,%eax
rep
movsb
movl %eax,%ecx
andl $3,%eax
shrl $2,%ecx
rep
movsl
.LStrConcat2:
movl %eax,%ecx
rep
movsb
end ['EBX','ECX','EAX','ESI','EDI'];
end;
procedure strcmp(dstr,sstr : pointer);[public,alias: 'STRCMP'];
begin
asm
cld
xorl %ebx,%ebx
xorl %eax,%eax
movl 12(%ebp),%esi
movl 8(%ebp),%edi
movb (%esi),%al
movb (%edi),%bl
movl %eax,%edx
incl %esi
incl %edi
cmpl %ebx,%eax
jbe .LStrCmp1
movl %ebx,%eax
.LStrCmp1:
cmpl $7,%eax
jl .LStrCmp2
movl %edi,%ecx # Align on 32bits
negl %ecx
andl $3,%ecx
subl %ecx,%eax
orl %ecx,%ecx
rep
cmpsb
jne .LStrCmp3
movl %eax,%ecx
andl $3,%eax
shrl $2,%ecx
orl %ecx,%ecx
rep
cmpsl
je .LStrCmp2
movl $4,%eax
sub %eax,%esi
sub %eax,%edi
.LStrCmp2:
movl %eax,%ecx
orl %eax,%eax
rep
cmpsb
jne .LStrCmp3
cmp %ebx,%edx
.LStrCmp3:
end ['EDX','ECX','EBX','EAX','ESI','EDI'];
end;
function strpas(p : pchar) : string;
begin
asm
cld
movl 12(%ebp),%edi
movl $0xff,%ecx
xorl %eax,%eax
movl %edi,%esi
repne
scasb
movl %ecx,%eax
movl 8(%ebp),%edi
notb %al
decl %eax
stosb
cmpl $7,%eax
jl .LStrPas2
movl %edi,%ecx # Align on 32bits
negl %ecx
andl $3,%ecx
subl %ecx,%eax
rep
movsb
movl %eax,%ecx
andl $3,%eax
shrl $2,%ecx
rep
movsl
.LStrPas2:
movl %eax,%ecx
rep
movsb
end ['ECX','EAX','ESI','EDI'];
end;
function strlen(p : pchar) : longint;
begin
asm
cld
movl 8(%ebp),%edi
movl $0xffffffff,%ecx
xorl %eax,%eax
repne
scasb
movl $0xfffffffe,%eax
subl %ecx,%eax
leave
ret $4
end ['EDI','ECX','EAX'];
end;
procedure Move(var source;var dest;count:longint);
begin
asm
movl dest,%edi
movl source,%esi
movl %edi,%eax
movl count,%ebx
## Check for back or forward
sub %esi,%eax
jz .LMoveEnd # Do nothing when source=dest
jc .LFMove # Do forward, dest<source
cmp %ebx,%eax
jb .LBMove # Dest is in range of move, do backward
## Forward Copy
.LFMove:
cld
cmpl $7,%ebx
jl .LFMove1
movl %edi,%ecx # Align on 32bits
negl %ecx
andl $3,%ecx
subl %ecx,%ebx
rep
movsb
movl %ebx,%ecx
andl $3,%ebx
shrl $2,%ecx
rep
movsl
.LFMove1:
movl %ebx,%ecx
rep
movsb
jmp .LMoveEnd
## Backward Copy
.LBMove:
std
addl %ebx,%esi
addl %ebx,%edi
movl %edi,%ecx
decl %esi
decl %edi
cmpl $7,%ebx
jl .LBMove1
negl %ecx # Align on 32bits
andl $3,%ecx
subl %ecx,%ebx
rep
movsb
movl %ebx,%ecx
andl $3,%ebx
shrl $2,%ecx
subl $3,%esi
subl $3,%edi
rep
movsl
addl $3,%esi
addl $3,%edi
.LBMove1:
movl %ebx,%ecx
rep
movsb
cld
.LMoveEnd:
end;
end;
Procedure FillChar(var x;count:longint;value:byte);[alias: '.L_FILL_OBJECT'];
begin
asm
cld
movl x,%edi
movl value,%eax # Only lower 8 bits will be used
movl count,%ecx
cmpl $7,%ecx
jl .LFill1
movb %al,%ah
movl %eax,%ebx
shll $16,%eax
movl %ecx,%edx
movw %bx,%ax
movl %edi,%ecx # Align on 32bits
negl %ecx
andl $3,%ecx
subl %ecx,%edx
rep
stosb
movl %edx,%ecx
andl $3,%edx
shrl $2,%ecx
rep
stosl
movl %edx,%ecx
.LFill1:
rep
stosb
end;
end;
procedure fillword(var x;count : longint;value : word);
begin
asm
movl 8(%ebp),%edi
movl 12(%ebp),%ecx
movl 16(%ebp),%eax
movl %eax,%edx
shll $16,%eax
movw %dx,%ax
movl %ecx,%edx
shrl $1,%ecx
cld
rep
stosl
movl %edx,%ecx
andl $1,%ecx
rep
stosw
end ['EAX','ECX','EDX','EDI'];
end;
{$ifndef ordintern}
{!!!!!! not very fast, but easy. }
function ord(b : boolean) : byte;
begin
asm
movb 8(%ebp),%al
leave
ret $2
end;
end;
{$endif}
function abs(l : longint) : longint;
begin
asm
movl 8(%ebp),%eax
orl %eax,%eax
jns .LMABS1
negl %eax
.LMABS1:
leave
ret $4
end ['EAX'];
end;
function odd(l : longint) : boolean;
begin
asm
movl 8(%ebp),%eax
andl $1,%eax
setnz %al
leave
ret $4
end ['EAX'];
end;
function sqr(l : longint) : longint;
begin
asm
movl 8(%ebp),%eax
imull %eax,%eax
leave
ret $4
end ['EAX'];
end;
{$ifndef str_intern }
procedure str(l : longint;var s : string);
{$else str_intern }
procedure int_str(l : longint;var s : string);
{$endif str_intern }
var
buffer : array[0..11] of byte;
begin
{ Workaround: }
if l=$80000000 then
begin
s:='-2147483648';
exit;
end;
asm
movl 8(%ebp),%eax // load Integer
movl 12(%ebp),%edi // Load String address
xorl %ecx,%ecx // String length=0
xorl %ebx,%ebx // Buffer length=0
movl $0x0a,%esi // load 10 as dividing constant.
or %eax,%eax // Sign ?
jns .LM2
neg %eax
movb $0x2d,1(%edi) // put '-' in String
incl %ecx
.LM2:
cdq
idivl %esi,%eax
addb $0x30,%dl // convert Rest to ASCII.
movb %dl,-12(%ebp,%ebx)
incl %ebx
cmpl $0,%eax
jnz .LM2
// copy String
.LM3:
movb -13(%ebp,%ebx),%al // -13 because EBX is decreased only
// later.
movb %al,1(%edi,%ecx)
incl %ecx
decl %ebx
jnz .LM3
movb %cl,(%edi) // Copy String length
end;
end;
{$ifndef str_intern }
procedure str(c : cardinal;var s : string);
{$else str_intern }
procedure int_str(c : cardinal;var s : string);
{$endif str_intern }
var
buffer : array[0..14] of byte;
begin
asm
movl 8(%ebp),%eax // load CARDINAL
movl 12(%ebp),%edi // Load String address
xorl %ecx,%ecx // String length=0
xorl %ebx,%ebx // Buffer length=0
movl $0x0a,%esi // load 10 as dividing constant.
.LM4:
xorl %edx,%edx
divl %esi,%eax
addb $0x30,%dl // convert Rest to ASCII.
movb %dl,-12(%ebp,%ebx)
incl %ebx
cmpl $0,%eax
jnz .LM4
{ now copy the string }
.LM5:
movb -13(%ebp,%ebx),%al // -13 because EBX is decreased only
// later.
movb %al,1(%edi,%ecx)
incl %ecx
decl %ebx
jnz .LM5
movb %cl,(%edi) // Copy String length
end;
end;
procedure f1;[public,alias: 'FLUSH_STDOUT'];
begin
asm
pushal
end;
FileFunc(textrec(output).flushfunc)(textrec(output));
asm
popal
end;
end;
Function Sptr : Longint;
begin
asm
movl %esp,%eax
addl $8,%eax
movl %eax,-4(%ebp)
end ['EAX'];
end;
{
$Log$
Revision 1.1 1998-03-25 11:18:43 root
Initial revision
Revision 1.30 1998/03/20 05:11:17 carl
* bugfix of register usage list for strcmp and strconcat
Revision 1.29 1998/03/15 19:38:41 peter
* fixed a bug in Move()
Revision 1.28 1998/03/10 23:50:39 florian
* strcopy saves now the used registers except ESI and EDI, solves
a problem with the optimizer
Revision 1.27 1998/03/10 16:25:52 jonas
* removed reloading of eax with 8(ebp), in int_help_constructor, as eax is nowhere modified
Revision 1.25 1998/03/02 11:44:43 florian
* writing of large cardinals fixed
Revision 1.24 1998/03/02 04:14:02 carl
* page fault bug fix with CHECK_OBJECT
warning: Will only work with GAS as VMT pointer field is an
.lcomm and will be ZEROED by linker (might not be true for TASM)
Revision 1.23 1998/02/24 17:50:46 peter
* upto 100% (255's char is different ;) faster STRCMP
* faster StrPas from i386.inc also strings.pp
Revision 1.22 1998/02/22 22:01:26 carl
+ IOCHECK halts with the correct errorcode now
Revision 1.21 1998/02/11 16:55:14 michael
fixed cardinal printing. Large cardinals (>0fffffff) not yet working
Revision 1.20 1998/02/06 09:12:39 florian
* bug in CHECK_OBJECT fixed
Revision 1.19 1998/02/05 22:30:25 florian
+ CHECK_OBJECT to check for an valid VMT (before calling a virtual method)
Revision 1.18 1998/02/04 14:46:36 daniel
* Some small tweaks
Revision 1.17 1998/01/27 22:05:07 florian
* again small fixes to DOM (Delphi Object Model)
Revision 1.16 1998/01/26 11:59:01 michael
+ Added log at the end
revision 1.15
date: 1998/01/25 22:52:52; author: peter; state: Exp; lines: +140 -122
* Faster string functions by using aligning
----------------------------
revision 1.14
date: 1998/01/25 22:30:48; author: florian; state: Exp; lines: +14 -2
* DOM: some fixes to tobject and the con-/destructor help routines
----------------------------
revision 1.13
date: 1998/01/23 18:08:29; author: florian; state: Exp; lines: +10 -4
* more bugs in FCL object model removed
----------------------------
revision 1.12
date: 1998/01/23 15:54:47; author: florian; state: Exp; lines: +5 -5
+ small extensions to FCL object model
----------------------------
revision 1.11
date: 1998/01/20 00:14:24; author: peter; state: Exp; lines: +18 -5
* .type is linux only, go32v2 doesn't like it
----------------------------
revision 1.10
date: 1998/01/19 16:19:53; author: peter; state: Exp; lines: +7 -1
* Works now correct with shared libs, .globl always needs a .type
----------------------------
revision 1.9
date: 1998/01/19 10:21:35; author: michael; state: Exp; lines: +1 -6
* moved Fillchar t(..,char) to system.inc
----------------------------
revision 1.8
date: 1998/01/19 09:15:05; author: michael; state: Exp; lines: +40 -132
* Bugfixes in Move and FillChar
----------------------------
revision 1.7
date: 1998/01/16 23:10:52; author: florian; state: Exp; lines: +23 -1
+ some tobject stuff
----------------------------
revision 1.6
date: 1998/01/16 22:21:35; author: michael; state: Exp; lines: +601 -493
+ Installed pentium-optimized move (optional)
----------------------------
revision 1.5
date: 1998/01/12 03:39:17; author: carl; state: Exp; lines: +2 -2
* bugfix of RE_OVERFLOW, gives out now a Runerror(215)
----------------------------
revision 1.4
date: 1998/01/01 16:57:36; author: michael; state: Exp; lines: +1 -21
Moved DO_EXIT to system.inc. Now processor independent
----------------------------
revision 1.3
date: 1997/12/10 12:12:31; author: michael; state: Exp; lines: +2 -2
* changed dateifunc to FileFunc
----------------------------
revision 1.2
date: 1997/12/01 12:34:36; author: michael; state: Exp; lines: +13 -0
+ added copyright reference in header.
----------------------------
revision 1.1
date: 1997/11/27 08:33:48; author: michael; state: Exp;
Initial revision
----------------------------
revision 1.1.1.1
date: 1997/11/27 08:33:48; author: michael; state: Exp; lines: +0 -0
FPC RTL CVS start
=============================================================================
}