1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
|
{
This file is part of the Free Pascal run time library.
Copyright (c) 2000 by Jonas Maebe and other members of the
Free Pascal development team
Implementation of mathematical Routines (only for real)
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.
**********************************************************************}
const
longint_to_real_helper: int64 = $4330000080000000;
cardinal_to_real_helper: int64 = $4330000000000000;
int_to_real_factor: double = double(high(cardinal))+1.0;
{****************************************************************************
EXTENDED data type routines
****************************************************************************}
{$define FPC_SYSTEM_HAS_ABS}
function fpc_abs_real(d : valreal) : valreal;compilerproc;
begin
{ Function is handled internal in the compiler }
runerror(207);
result:=0;
end;
{$define FPC_SYSTEM_HAS_SQR}
function fpc_sqr_real(d : valreal) : valreal;compilerproc;
begin
{ Function is handled internal in the compiler }
runerror(207);
result:=0;
end;
const
factor: double = double(int64(1) shl 32);
factor2: double = double(int64(1) shl 31);
{$ifndef FPC_SYSTEM_HAS_TRUNC}
{$define FPC_SYSTEM_HAS_TRUNC}
function fpc_trunc_real(d : valreal) : int64;assembler;compilerproc;
{ input: d in fr1 }
{ output: result in r3 }
assembler;
var
temp: packed record
case byte of
0: (l1,l2: longint);
1: (d: double);
end;
asm
// store d in temp
stfd f1,temp
// extract sign bit (record in cr0)
lwz r3,temp
rlwinm. r3,r3,1,31,31
// make d positive
fabs f1,f1
// load 2^32 in f2
{$if not defined(macos) and not defined(aix)}
{$ifdef FPC_PIC}
{$ifdef darwin}
mflr r0
bcl 20,31,.Lpiclab
.Lpiclab:
mflr r5
mtlr r0
addis r4,r5,(factor-.Lpiclab)@ha
lfd f2,(factor-.Lpiclab)@l(r4)
{$else darwin}
{$error Add pic code for linux/ppc32}
{$endif darwin}
{$else FPC_PIC}
lis r4,factor@ha
lfd f2,factor@l(r4)
{$endif FPC_PIC}
{$else not macos/aix}
lwz r4,factor(r2)
lfd f2,0(r4)
{$endif not macos/aix}
// check if value is < 0
// f3 := d / 2^32;
fdiv f3,f1,f2
// round
fctiwz f4,f3
// store
stfd f4,temp
// and load into r4
lwz r3,temp+4
// convert back to float
lis r0,0x4330
stw r0,temp
xoris r0,r3,0x8000
stw r0,temp+4
{$if not defined(macos) and not defined(aix)}
{$ifdef FPC_PIC}
{$ifdef darwin}
addis r4,r5,(longint_to_real_helper-.Lpiclab)@ha
lfd f0,(longint_to_real_helper-.Lpiclab)@l(r4)
{$else darwin}
{$error Add pic code for linux/ppc32}
{$endif darwin}
{$else FPC_PIC}
lis r4,longint_to_real_helper@ha
lfd f0,longint_to_real_helper@l(r4)
{$endif FPC_PIC}
{$else not macos/aix}
lwz r4,longint_to_real_helper(r2)
lfd f0,0(r4)
{$endif not macos/aix}
lfd f3,temp
fsub f3,f3,f0
// f4 := d "mod" 2^32 ( = d - ((d / 2^32) * 2^32))
fnmsub f4,f3,f2,f1
// now, convert to unsigned 32 bit
// load 2^31 in f2
{$if not defined(macos) and not defined(aix)}
{$ifdef FPC_PIC}
{$ifdef darwin}
addis r4,r5,(factor2-.Lpiclab)@ha
lfd f2,(factor2-.Lpiclab)@l(r4)
{$else darwin}
{$error Add pic code for linux/ppc32}
{$endif darwin}
{$else FPC_PIC}
lis r4,factor2@ha
lfd f2,factor2@l(r4)
{$endif FPC_PIC}
{$else not macos/aix}
lwz r4,factor2(r2)
lfd f2,0(r4)
{$endif not macos/aix}
// subtract 2^31
fsub f3,f4,f2
// was the value > 2^31?
fcmpu cr1,f4,f2
// use diff if >= 2^31
fsel f4,f3,f3,f4
// next part same as conversion to signed integer word
fctiwz f4,f4
stfd f4,temp
lwz r4,temp+4
// add 2^31 if value was >=2^31
blt cr1, .LTruncNoAdd
xoris r4,r4,0x8000
.LTruncNoAdd:
// negate value if it was negative to start with
beq cr0,.LTruncPositive
subfic r4,r4,0
subfze r3,r3
.LTruncPositive:
end;
{$endif not FPC_SYSTEM_HAS_TRUNC}
(*
{$ifndef FPC_SYSTEM_HAS_ROUND}
{$define FPC_SYSTEM_HAS_ROUND}
function round(d : extended) : int64;
function fpc_round(d : extended) : int64;assembler;[public, alias:'FPC_ROUND'];compilerproc;
{ exactly the same as trunc, except that one fctiwz has become fctiw }
{ input: d in fr1 }
{ output: result in r3 }
assembler;
var
temp: packed record
case byte of
0: (l1,l2: longint);
1: (d: double);
end;
asm
// store d in temp
stfd f1, temp
// extract sign bit (record in cr0)
lwz r4,temp
rlwinm. r4,r4,1,31,31
// make d positive
fabs f1,f1
// load 2^32 in f2
{$if not defined(macos) and not defined(aix)}
lis r4,factor@ha
lfd f2,factor@l(r4)
{$else}
lwz r4,factor(r2)
lfd f2,0(r4)
{$endif}
// check if value is < 0
// f3 := d / 2^32;
fdiv f3,f1,f2
// round
fctiwz f4,f3
// store
stfd f4,temp
// and load into r4
lwz r3,temp+4
// convert back to float
lis r0,0x4330
stw r0,temp
xoris r0,r3,0x8000
stw r0,temp+4
{$if not defined(macos) and not defined(aix)}
lis r4,longint_to_real_helper@ha
lfd f0,longint_to_real_helper@l(r4)
{$else}
lwz r4,longint_to_real_helper(r2)
lfd f0,0(r4)
{$endif}
lfd f3,temp
fsub f3,f3,f0
// f4 := d "mod" 2^32 ( = d - ((d / 2^32) * 2^32))
fnmsub f4,f3,f2,f1
// now, convert to unsigned 32 bit
// load 2^31 in f2
{$if not defined(macos) and not defined(aix)}
lis r4,factor2@ha
lfd f2,factor2@l(r4)
{$else}
lwz r4,factor2(r2)
lfd f2,0(r4)
{$endif}
// subtract 2^31
fsub f3,f4,f2
// was the value > 2^31?
fcmpu cr1,f4,f2
// use diff if >= 2^31
fsel f4,f3,f3,f4
// next part same as conversion to signed integer word
fctiw f4,f4
stfd f4,temp
lwz r4,temp+4
// add 2^31 if value was >=2^31
blt cr1, .LRoundNoAdd
xoris r4,r4,0x8000
.LRoundNoAdd:
// negate value if it was negative to start with
beq cr0,.LRoundPositive
subfic r4,r4,0
subfze r3,r3
.LRoundPositive:
end;
{$endif not FPC_SYSTEM_HAS_ROUND}
*)
{****************************************************************************
Int to real helpers
****************************************************************************}
{$ifndef aix}
{ these helpers somehow don't seem to work on AIX/Power 7 }
{$define FPC_SYSTEM_HAS_INT64_TO_DOUBLE}
function fpc_int64_to_double(i: int64): double; compilerproc;
assembler;
{ input: high(i) in r4, low(i) in r3 }
{ output: double(i) in f0 }
var
temp: packed record
case byte of
0: (l1,l2: cardinal);
1: (d: double);
end;
asm
lis r0,0x4330
stw r0,temp
xoris r3,r3,0x8000
stw r3,temp+4
{$if not defined(macos) and not defined(aix)}
{$ifdef FPC_PIC}
{$ifdef darwin}
mflr r0
bcl 20,31,.Lpiclab
.Lpiclab:
mflr r5
mtlr r0
addis r3,r5,(longint_to_real_helper-.Lpiclab)@ha
lfd f1,(longint_to_real_helper-.Lpiclab)@l(r3)
{$else darwin}
{$error Add pic code for linux/ppc32}
{$endif darwin}
{$else FPC_PIC}
lis r3,longint_to_real_helper@ha
lfd f1,longint_to_real_helper@l(r3)
{$endif FPC_PIC}
{$else not macos/aix}
lwz r3,longint_to_real_helper(r2)
lfd f1,0(r3)
{$endif not mac os}
lfd f0,temp
stw r4,temp+4
fsub f0,f0,f1
{$if not defined(macos) and not defined(aix)}
{$ifdef FPC_PIC}
{$ifdef darwin}
addis r4,r5,(cardinal_to_real_helper-.Lpiclab)@ha
lfd f1,(cardinal_to_real_helper-.Lpiclab)@l(r4)
addis r4,r5,(int_to_real_factor-.Lpiclab)@ha
lfd f3,temp
lfd f2,(int_to_real_factor-.Lpiclab)@l(r4)
{$else darwin}
{$error Add pic code for linux/ppc32}
{$endif darwin}
{$else FPC_PIC}
lis r4,cardinal_to_real_helper@ha
lfd f1,cardinal_to_real_helper@l(r4)
lis r4,int_to_real_factor@ha
lfd f3,temp
lfd f2,int_to_real_factor@l(r4)
{$endif FPC_PIC}
{$else not macos/aix}
lwz r4,cardinal_to_real_helper(r2)
lwz r3,int_to_real_factor(r2)
lfd f3,temp
lfd f1,0(r4)
lfd f2,0(r3)
{$endif not macos/aix}
fsub f3,f3,f1
fmadd f1,f0,f2,f3
end;
{$define FPC_SYSTEM_HAS_QWORD_TO_DOUBLE}
function fpc_qword_to_double(q: qword): double; compilerproc;
assembler;
{ input: high(q) in r4, low(q) in r3 }
{ output: double(q) in f0 }
var
temp: packed record
case byte of
0: (l1,l2: cardinal);
1: (d: double);
end;
asm
lis r0,0x4330
stw r0,temp
stw r3,temp+4
lfd f0,temp
{$if not defined(macos) and not defined(aix)}
{$ifdef FPC_PIC}
{$ifdef darwin}
mflr r0
bcl 20,31,.Lpiclab
.Lpiclab:
mflr r5
mtlr r0
addis r3,r5,(cardinal_to_real_helper-.Lpiclab)@ha
lfd f1,(cardinal_to_real_helper-.Lpiclab)@l(r3)
{$else darwin}
{$error Add pic code for linux/ppc32}
{$endif darwin}
{$else FPC_PIC}
lis r3,cardinal_to_real_helper@ha
lfd f1,cardinal_to_real_helper@l(r3)
{$endif FPC_PIC}
{$else not macos/aix}
lwz r3,longint_to_real_helper(r2)
lfd f1,0(r3)
{$endif not macos/aix}
stw r4,temp+4
fsub f0,f0,f1
lfd f3,temp
{$if not defined(macos) and not defined(aix)}
{$ifdef FPC_PIC}
{$ifdef darwin}
addis r4,r5,(int_to_real_factor-.Lpiclab)@ha
lfd f2,(int_to_real_factor-.Lpiclab)@l(r4)
{$else darwin}
{$error Add pic code for linux/ppc32}
{$endif darwin}
{$else FPC_PIC}
lis r4,int_to_real_factor@ha
lfd f2,int_to_real_factor@l(r4)
{$endif FPC_PIC}
{$else not macos/aix}
lwz r4,int_to_real_factor(r2)
lfd f2,0(r4)
{$endif not macos/aix}
fsub f3,f3,f1
fmadd f1,f0,f2,f3
end;
{$endif}
|
