mathu.inc 13 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499
  1. {
  2. This file is part of the Free Pascal run time library.
  3. Copyright (c) 2004 by Florian Klaempfl
  4. member of the Free Pascal development team
  5. See the file COPYING.FPC, included in this distribution,
  6. for details about the copyright.
  7. This program is distributed in the hope that it will be useful,
  8. but WITHOUT ANY WARRANTY; without even the implied warranty of
  9. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  10. **********************************************************************}
  11. { for bootstrapping with 3.0.x/3.2.x }
  12. {$if defined(darwin) or defined(FPUVFPV2) or defined(FPUVFPV3) or defined(FPUVFPV4) or defined(FPUVFPV3_d16) or defined(FPUFPV4_s16)}
  13. {$define FPUARM_HAS_VFP_EXTENSION}
  14. {$endif}
  15. {$if defined(wince)}
  16. const
  17. _DN_SAVE = $00000000;
  18. _DN_FLUSH = $01000000;
  19. _EM_INVALID = $00000010;
  20. _EM_DENORMAL = $00080000;
  21. _EM_ZERODIVIDE = $00000008;
  22. _EM_OVERFLOW = $00000004;
  23. _EM_UNDERFLOW = $00000002;
  24. _EM_INEXACT = $00000001;
  25. _IC_AFFINE = $00040000;
  26. _IC_PROJECTIVE = $00000000;
  27. _RC_CHOP = $00000300;
  28. _RC_UP = $00000200;
  29. _RC_DOWN = $00000100;
  30. _RC_NEAR = $00000000;
  31. _PC_24 = $00020000;
  32. _PC_53 = $00010000;
  33. _PC_64 = $00000000;
  34. _MCW_DN = $03000000;
  35. _MCW_EM = $0008001F;
  36. _MCW_IC = $00040000;
  37. _MCW_RC = $00000300;
  38. _MCW_PC = $00030000;
  39. function _controlfp(new: DWORD; mask: DWORD): DWORD; cdecl; external 'coredll';
  40. function GetRoundMode: TFPURoundingMode;
  41. var
  42. c: dword;
  43. begin
  44. c:=_controlfp(0, 0);
  45. Result:=TFPURoundingMode((c shr 16) and 3);
  46. end;
  47. function SetRoundMode(const RoundMode: TFPURoundingMode): TFPURoundingMode;
  48. var
  49. c: dword;
  50. begin
  51. c:=Ord(RoundMode) shl 16;
  52. c:=_controlfp(c, _MCW_RC);
  53. Result:=TFPURoundingMode((c shr 16) and 3);
  54. end;
  55. function GetPrecisionMode: TFPUPrecisionMode;
  56. var
  57. c: dword;
  58. begin
  59. c:=_controlfp(0, 0);
  60. if c and _MCW_PC = _PC_64 then
  61. Result:=pmDouble
  62. else
  63. Result:=pmSingle;
  64. end;
  65. function SetPrecisionMode(const Precision: TFPUPrecisionMode): TFPUPrecisionMode;
  66. var
  67. c: dword;
  68. begin
  69. Result:=GetPrecisionMode;
  70. if Precision = pmSingle then
  71. c:=_PC_24
  72. else
  73. c:=_PC_64;
  74. _controlfp(c, _MCW_PC);
  75. end;
  76. function ConvertExceptionMask(em: dword): TFPUExceptionMask;
  77. begin
  78. Result:=[];
  79. if em and _EM_INVALID = 0 then
  80. Result:=Result + [exInvalidOp];
  81. if em and _EM_DENORMAL = 0 then
  82. Result:=Result + [exDenormalized];
  83. if em and _EM_ZERODIVIDE = 0 then
  84. Result:=Result + [exZeroDivide];
  85. if em and _EM_OVERFLOW = 0 then
  86. Result:=Result + [exOverflow];
  87. if em and _EM_UNDERFLOW = 0 then
  88. Result:=Result + [exUnderflow];
  89. if em and _EM_INEXACT = 0 then
  90. Result:=Result + [exPrecision];
  91. end;
  92. function GetExceptionMask: TFPUExceptionMask;
  93. begin
  94. Result:=ConvertExceptionMask(_controlfp(0, 0));
  95. end;
  96. function SetExceptionMask(const Mask: TFPUExceptionMask): TFPUExceptionMask;
  97. var
  98. c: dword;
  99. begin
  100. c:=0;
  101. if not(exInvalidOp in Mask) then
  102. c:=c or _EM_INVALID;
  103. if not(exDenormalized in Mask) then
  104. c:=c or _EM_DENORMAL;
  105. if not(exZeroDivide in Mask) then
  106. c:=c or _EM_ZERODIVIDE;
  107. if not(exOverflow in Mask) then
  108. c:=c or _EM_OVERFLOW;
  109. if not(exUnderflow in Mask) then
  110. c:=c or _EM_UNDERFLOW;
  111. if not(exPrecision in Mask) then
  112. c:=c or _EM_INEXACT;
  113. c:=_controlfp(c, _MCW_EM);
  114. Result:=ConvertExceptionMask(c);
  115. end;
  116. procedure ClearExceptions(RaisePending: Boolean =true);
  117. begin
  118. end;
  119. {$elseif defined(FPUARM_HAS_VFP_EXTENSION)}
  120. const
  121. _VFP_ENABLE_IM = 1 shl 8; { invalid operation }
  122. _VFP_ENABLE_ZM = 1 shl 9; { divide by zero }
  123. _VFP_ENABLE_OM = 1 shl 10; { overflow }
  124. _VFP_ENABLE_UM = 1 shl 11; { underflow }
  125. _VFP_ENABLE_PM = 1 shl 12; { inexact }
  126. _VFP_ENABLE_DM = 1 shl 15; { denormalized operation }
  127. _VFP_ENABLE_ALL = _VFP_ENABLE_IM or
  128. _VFP_ENABLE_ZM or
  129. _VFP_ENABLE_OM or
  130. _VFP_ENABLE_UM or
  131. _VFP_ENABLE_PM or
  132. _VFP_ENABLE_DM; { mask for all flags }
  133. _VFP_ROUNDINGMODE_MASK_SHIFT = 22;
  134. _VFP_ROUNDINGMODE_MASK = 3 shl _VFP_ROUNDINGMODE_MASK_SHIFT;
  135. _VFP_EXCEPTIONS_PENDING_MASK =
  136. (1 shl 0) or
  137. (1 shl 1) or
  138. (1 shl 2) or
  139. (1 shl 3) or
  140. (1 shl 4) or
  141. (1 shl 7);
  142. function VFP_GetCW : dword; nostackframe; assembler;
  143. asm
  144. fmrx r0,fpscr
  145. end;
  146. procedure VFP_SetCW(cw : dword); nostackframe; assembler;
  147. asm
  148. fmxr fpscr,r0
  149. end;
  150. function VFPCw2RoundingMode(cw: dword): TFPURoundingMode;
  151. begin
  152. case (cw and _VFP_ROUNDINGMODE_MASK) shr _VFP_ROUNDINGMODE_MASK_SHIFT of
  153. 0 : result := rmNearest;
  154. 1 : result := rmUp;
  155. 2 : result := rmDown;
  156. 3 : result := rmTruncate;
  157. end;
  158. end;
  159. function GetRoundMode: TFPURoundingMode;
  160. begin
  161. result:=VFPCw2RoundingMode(VFP_GetCW);
  162. end;
  163. function SetRoundMode(const RoundMode: TFPURoundingMode): TFPURoundingMode;
  164. var
  165. mode: dword;
  166. oldcw: dword;
  167. begin
  168. softfloat_rounding_mode:=RoundMode;
  169. oldcw:=VFP_GetCW;
  170. case (RoundMode) of
  171. rmNearest : mode := 0;
  172. rmUp : mode := 1;
  173. rmDown : mode := 2;
  174. rmTruncate : mode := 3;
  175. end;
  176. mode:=mode shl _VFP_ROUNDINGMODE_MASK_SHIFT;
  177. VFP_SetCW((oldcw and (not _VFP_ROUNDINGMODE_MASK)) or mode);
  178. result := VFPCw2RoundingMode(oldcw);
  179. end;
  180. function GetPrecisionMode: TFPUPrecisionMode;
  181. begin
  182. result := pmDouble;
  183. end;
  184. function SetPrecisionMode(const Precision: TFPUPrecisionMode): TFPUPrecisionMode;
  185. begin
  186. { nothing to do, not supported }
  187. result := pmDouble;
  188. end;
  189. function VFPCw2ExceptionMask(cw: dword): TFPUExceptionMask;
  190. begin
  191. Result:=[];
  192. if (cw and _VFP_ENABLE_IM)=0 then
  193. include(Result,exInvalidOp);
  194. if (cw and _VFP_ENABLE_DM)=0 then
  195. include(Result,exDenormalized);
  196. if (cw and _VFP_ENABLE_ZM)=0 then
  197. include(Result,exZeroDivide);
  198. if (cw and _VFP_ENABLE_OM)=0 then
  199. include(Result,exOverflow);
  200. if (cw and _VFP_ENABLE_UM)=0 then
  201. include(Result,exUnderflow);
  202. if (cw and _VFP_ENABLE_PM)=0 then
  203. include(Result,exPrecision);
  204. end;
  205. function GetExceptionMask: TFPUExceptionMask;
  206. begin
  207. Result:=VFPCw2ExceptionMask(VFP_GetCW);
  208. end;
  209. function SetExceptionMask(const Mask: TFPUExceptionMask): TFPUExceptionMask;
  210. var
  211. cw : dword;
  212. begin
  213. cw:=VFP_GetCW;
  214. Result:=VFPCw2ExceptionMask(cw);
  215. cw:=cw and not(_VFP_ENABLE_ALL);
  216. {$ifndef darwin}
  217. if not(exInvalidOp in Mask) then
  218. cw:=cw or _VFP_ENABLE_IM;
  219. if not(exDenormalized in Mask) then
  220. cw:=cw or _VFP_ENABLE_DM;
  221. if not(exZeroDivide in Mask) then
  222. cw:=cw or _VFP_ENABLE_ZM;
  223. if not(exOverflow in Mask) then
  224. cw:=cw or _VFP_ENABLE_OM;
  225. if not(exUnderflow in Mask) then
  226. cw:=cw or _VFP_ENABLE_UM;
  227. if not(exPrecision in Mask) then
  228. cw:=cw or _VFP_ENABLE_PM;
  229. {$endif}
  230. VFP_SetCW(cw);
  231. softfloat_exception_mask:=Mask;
  232. end;
  233. procedure ClearExceptions(RaisePending: Boolean =true);
  234. begin
  235. { RaisePending has no effect on ARM, it always raises them at the correct location }
  236. VFP_SetCW(VFP_GetCW and (not _VFP_EXCEPTIONS_PENDING_MASK));
  237. end;
  238. {$else FPUARM_HAS_VFP_EXTENSION}
  239. {*****************************************************************************
  240. FPA code
  241. *****************************************************************************}
  242. {
  243. Docs from uclib
  244. * We have a slight terminology confusion here. On the ARM, the register
  245. * we're interested in is actually the FPU status word - the FPU control
  246. * word is something different (which is implementation-defined and only
  247. * accessible from supervisor mode.)
  248. *
  249. * The FPSR looks like this:
  250. *
  251. * 31-24 23-16 15-8 7-0
  252. * | system ID | trap enable | system control | exception flags |
  253. *
  254. * We ignore the system ID bits; for interest's sake they are:
  255. *
  256. * 0000 "old" FPE
  257. * 1000 FPPC hardware
  258. * 0001 FPE 400
  259. * 1001 FPA hardware
  260. *
  261. * The trap enable and exception flags are both structured like this:
  262. *
  263. * 7 - 5 4 3 2 1 0
  264. * | reserved | INX | UFL | OFL | DVZ | IVO |
  265. *
  266. * where a `1' bit in the enable byte means that the trap can occur, and
  267. * a `1' bit in the flags byte means the exception has occurred.
  268. *
  269. * The exceptions are:
  270. *
  271. * IVO - invalid operation
  272. * DVZ - divide by zero
  273. * OFL - overflow
  274. * UFL - underflow
  275. * INX - inexact (do not use; implementations differ)
  276. *
  277. * The system control byte looks like this:
  278. *
  279. * 7-5 4 3 2 1 0
  280. * | reserved | AC | EP | SO | NE | ND |
  281. *
  282. * where the bits mean
  283. *
  284. * ND - no denormalised numbers (force them all to zero)
  285. * NE - enable NaN exceptions
  286. * SO - synchronous operation
  287. * EP - use expanded packed-decimal format
  288. * AC - use alternate definition for C flag on compare operations
  289. */
  290. /* masking of interrupts */
  291. #define _FPU_MASK_IM 0x00010000 /* invalid operation */
  292. #define _FPU_MASK_ZM 0x00020000 /* divide by zero */
  293. #define _FPU_MASK_OM 0x00040000 /* overflow */
  294. #define _FPU_MASK_UM 0x00080000 /* underflow */
  295. #define _FPU_MASK_PM 0x00100000 /* inexact */
  296. #define _FPU_MASK_DM 0x00000000 /* denormalized operation */
  297. /* The system id bytes cannot be changed.
  298. Only the bottom 5 bits in the trap enable byte can be changed.
  299. Only the bottom 5 bits in the system control byte can be changed.
  300. Only the bottom 5 bits in the exception flags are used.
  301. The exception flags are set by the fpu, but can be zeroed by the user. */
  302. #define _FPU_RESERVED 0xffe0e0e0 /* These bits are reserved. */
  303. /* The fdlibm code requires strict IEEE double precision arithmetic,
  304. no interrupts for exceptions, rounding to nearest. Changing the
  305. rounding mode will break long double I/O. Turn on the AC bit,
  306. the compiler generates code that assumes it is on. */
  307. #define _FPU_DEFAULT 0x00001000 /* Default value. */
  308. #define _FPU_IEEE 0x001f1000 /* Default + exceptions enabled. */
  309. }
  310. {$if not(defined(gba)) and not(defined(nds)) and not(defined(FPUSOFT)) and not(defined(FPULIBGCC))}
  311. const
  312. _FPU_MASK_IM = $00010000; { invalid operation }
  313. _FPU_MASK_ZM = $00020000; { divide by zero }
  314. _FPU_MASK_OM = $00040000; { overflow }
  315. _FPU_MASK_UM = $00080000; { underflow }
  316. _FPU_MASK_PM = $00100000; { inexact }
  317. _FPU_MASK_DM = $00000000; { denormalized operation }
  318. _FPU_MASK_ALL = $001f0000; { mask for all flags }
  319. function FPU_GetCW : dword; nostackframe; assembler;
  320. asm
  321. rfs r0
  322. end;
  323. procedure FPU_SetCW(cw : dword); nostackframe; assembler;
  324. asm
  325. wfs r0
  326. end;
  327. function FPUCw2ExceptionMask(cw: dword): TFPUExceptionMask;
  328. begin
  329. Result:=[];
  330. if (cw and _FPU_MASK_IM)=0 then
  331. include(Result,exInvalidOp);
  332. if (cw and _FPU_MASK_DM)=0 then
  333. include(Result,exDenormalized);
  334. if (cw and _FPU_MASK_ZM)=0 then
  335. include(Result,exZeroDivide);
  336. if (cw and _FPU_MASK_OM)=0 then
  337. include(Result,exOverflow);
  338. if (cw and _FPU_MASK_UM)=0 then
  339. include(Result,exUnderflow);
  340. if (cw and _FPU_MASK_PM)=0 then
  341. include(Result,exPrecision);
  342. end;
  343. {$endif}
  344. function GetRoundMode: TFPURoundingMode;
  345. begin
  346. GetRoundMode:=softfloat_rounding_mode;
  347. end;
  348. function SetRoundMode(const RoundMode: TFPURoundingMode): TFPURoundingMode;
  349. begin
  350. result:=softfloat_rounding_mode;
  351. softfloat_rounding_mode:=RoundMode;
  352. end;
  353. function GetPrecisionMode: TFPUPrecisionMode;
  354. begin
  355. result := pmDouble;
  356. end;
  357. function SetPrecisionMode(const Precision: TFPUPrecisionMode): TFPUPrecisionMode;
  358. begin
  359. { does not apply }
  360. result := pmDouble;
  361. end;
  362. function GetExceptionMask: TFPUExceptionMask;
  363. begin
  364. {$if not(defined(gba)) and not(defined(nds)) and not(defined(FPUSOFT)) and not(defined(FPULIBGCC))}
  365. Result:=FPUCw2ExceptionMask(FPU_GetCW);
  366. {$else}
  367. Result:=softfloat_exception_mask;
  368. {$endif}
  369. end;
  370. function SetExceptionMask(const Mask: TFPUExceptionMask): TFPUExceptionMask;
  371. {$if not(defined(gba)) and not(defined(nds)) and not(defined(FPUSOFT)) and not(defined(FPULIBGCC))}
  372. var
  373. cw : dword;
  374. {$endif}
  375. begin
  376. {$if not(defined(gba)) and not(defined(nds)) and not(defined(FPUSOFT)) and not(defined(FPULIBGCC))}
  377. cw:=FPU_GetCW;
  378. Result:=FPUCw2ExceptionMask(cw);
  379. cw:=cw or _FPU_MASK_ALL;
  380. if exInvalidOp in Mask then
  381. cw:=cw and not(_FPU_MASK_IM);
  382. if exDenormalized in Mask then
  383. cw:=cw and not(_FPU_MASK_DM);
  384. if exZeroDivide in Mask then
  385. cw:=cw and not(_FPU_MASK_ZM);
  386. if exOverflow in Mask then
  387. cw:=cw and not(_FPU_MASK_OM);
  388. if exUnderflow in Mask then
  389. cw:=cw and not(_FPU_MASK_UM);
  390. if exPrecision in Mask then
  391. cw:=cw and not(_FPU_MASK_PM);
  392. FPU_SetCW(cw);
  393. {$else}
  394. Result:=softfloat_exception_mask;
  395. {$endif}
  396. softfloat_exception_mask:=Mask;
  397. end;
  398. procedure ClearExceptions(RaisePending: Boolean =true);
  399. begin
  400. softfloat_exception_flags:=[];
  401. end;
  402. {$endif wince}