development/compilers/freepascal/rtl/go32v2/emu387.pp

   1 {
   2     $Id$
   3     This file is part of the Free Pascal run time library.
   4     Copyright (c) 1999-2000 by Pierre Muller
   5
   6     FPU Emulator support
   7
   8     See the file COPYING.FPC, included in this distribution,
   9     for details about the copyright.
  10
  11     This program is distributed in the hope that it will be useful,
  12     but WITHOUT ANY WARRANTY; without even the implied warranty of
  13     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  14
  15  **********************************************************************}
  16 unit emu387;
  17 interface
  18
  19 procedure npxsetup(prog_name : string);
  20
  21
  22 implementation
  23
  24 {$asmmode ATT}
  25
  26 uses
  27   dxeload,dpmiexcp,strings;
  28
  29 type
  30   emu_entry_type = function(exc : pexception_state) : longint;
  31
  32 var
  33   _emu_entry : emu_entry_type;
  34
  35
  36 procedure _control87(mask1,mask2 : longint);
  37 begin
  38 { Copyright (C) 1995 DJ Delorie, see COPYING.DJ for details }
  39 { from file cntrl87.s in src/libc/pc_hw/fpu }
  40   asm
  41         { make room on stack }
  42         pushl   %eax
  43         fstcw   (%esp)
  44         fwait
  45         popl    %eax
  46         andl    $0xffff, %eax
  47         { OK;  we have the old value ready }
  48
  49         movl    mask2, %ecx
  50         notl    %ecx
  51         andl    %eax, %ecx      { the bits we want to keep }
  52
  53         movl    mask2, %edx
  54         andl    mask1, %edx      { the bits we want to change }
  55
  56         orl     %ecx, %edx      { the new value }
  57         pushl   %edx
  58         fldcw   (%esp)
  59         popl    %edx
  60   end;
  61 end;
  62
  63
  64 { the problem with the stack that is not cleared }
  65 function emu_entry(exc : pexception_state) : longint;
  66 begin
  67   emu_entry:=_emu_entry(exc);
  68 end;
  69
  70
  71 function nofpsig( sig : longint) : longint;
  72 const
  73   last_eip : longint = 0;
  74 var
  75   res : longint;
  76 begin
  77   {if last_eip=djgpp_exception_state^.__eip then
  78     begin
  79        writeln('emu call two times at same address');
  80        dpmi_set_coprocessor_emulation(1);
  81        _raise(SIGFPE);
  82        exit(0);
  83     end; }
  84   last_eip:=djgpp_exception_state^.__eip;
  85   res:=emu_entry(djgpp_exception_state);
  86   if res<>0 then
  87     begin
  88        writeln('emu call failed. res = ',res);
  89        dpmi_set_coprocessor_emulation(1);
  90        _raise(SIGFPE);
  91        exit(0);
  92     end;
  93   dpmi_longjmp(pdpmi_jmp_buf(djgpp_exception_state)^, djgpp_exception_state^.__eax);
  94   nofpsig:=0;
  95 end;
  96
  97
  98 var
  99   prev_exit : pointer;
 100
 101 procedure restore_DPMI_fpu_state;
 102 begin
 103   exitproc:=prev_exit;
 104   { Enable Coprocessor, no exceptions }
 105   dpmi_set_coprocessor_emulation(1);
 106 {$ifdef SYSTEMDEBUG}
 107   writeln(stderr,'Coprocessor restored ');
 108 {$endif}
 109 end;
 110
 111 { function _detect_80387 : boolean;
 112   not used because of the underscore problem }
 113
 114 {$L fpu.o }
 115
 116
 117 function getenv(const envvar:string):string;
 118 { Copied here, preserves uses Dos (PFV) }
 119 var
 120   hp      : ppchar;
 121   hs,
 122   _envvar : string;
 123   eqpos   : longint;
 124 begin
 125   _envvar:=upcase(envvar);
 126   hp:=envp;
 127   getenv:='';
 128   while assigned(hp^) do
 129    begin
 130      hs:=strpas(hp^);
 131      eqpos:=pos('=',hs);
 132      if copy(hs,1,eqpos-1)=_envvar then
 133       begin
 134         getenv:=copy(hs,eqpos+1,255);
 135         exit;
 136       end;
 137      inc(hp);
 138    end;
 139 end;
 140
 141
 142 function __detect_80387:byte;external name '__detect_80387';
 143
 144 procedure npxsetup(prog_name : string);
 145 var
 146   cp : string;
 147   i : byte;
 148   have_80387 : boolean;
 149   emu_p : pointer;
 150 const
 151   veryfirst : boolean = True;
 152 begin
 153   cp:=getenv('387');
 154   if (length(cp)>0) and (upcase(cp[1])='N') then
 155     have_80387:=False
 156   else
 157     begin
 158        dpmi_set_coprocessor_emulation(1);
 159        asm
 160           call __detect_80387
 161           movb %al,have_80387
 162        end;
 163     end;
 164   if (length(cp)>0) and (upcase(cp[1])='Q') then
 165     begin
 166        if not have_80387 then
 167          write(stderr,'No ');
 168        writeln(stderr,'80387 detected.');
 169     end;
 170
 171   if have_80387 then
 172    begin
 173      { mask all exceptions, except invalid operation }
 174      { change to same value as in v2prt0.as (PM)     }
 175      _control87($0332, $ffff)
 176    end
 177   else
 178     begin
 179        { Flags value 3 means coprocessor emulation, exceptions to us }
 180        if (dpmi_set_coprocessor_emulation(3)<>0) then
 181          begin
 182             writeln(stderr,'Warning: Coprocessor not present and DPMI setup failed!');
 183             writeln(stderr,'         If application attempts floating operations system may hang!');
 184          end
 185        else
 186          begin
 187             cp:=getenv('EMU387');
 188             if length(cp)=0 then
 189               begin
 190                  for i:=length(prog_name) downto 1 do
 191                    if (prog_name[i]='\') or (prog_name[i]='/') then
 192                      break;
 193                  if i>1 then
 194                    cp:=copy(prog_name,1,i);
 195                  cp:=cp+'wmemu387.dxe';
 196               end;
 197             emu_p:=dxe_load(cp);
 198             _emu_entry:=emu_entry_type(emu_p);
 199             if (emu_p=nil) then
 200               begin
 201                  writeln(cp+' load failed !');
 202                  halt;
 203               end;
 204             if veryfirst then
 205               begin
 206                  veryfirst:=false;
 207                  prev_exit:=exitproc;
 208                  exitproc:=@restore_DPMI_fpu_state;
 209               end;
 210             signal(SIGNOFP,@nofpsig);
 211          end;
 212     end;
 213 end;
 214
 215 begin
 216    npxsetup(paramstr(0));
 217 end.
 218 {
 219   $Log$
 220   Revision 1.1  2002/02/19 08:25:08  sasu
 221   Initial revision
 222
 223   Revision 1.1  2000/07/13 06:30:37  michael
 224   + Initial import
 225
 226   Revision 1.8  2000/02/09 16:59:28  peter
 227     * truncated log
 228
 229   Revision 1.7  2000/01/07 16:41:31  daniel
 230     * copyright 2000
 231
 232   Revision 1.6  2000/01/07 16:32:23  daniel
 233     * copyright 2000 added
 234
 235   Revision 1.5  1999/09/08 18:55:50  peter
 236     * pointer fixes
 237
 238 }