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
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
|
/*
Title: poly_specific.cpp - Poly/ML specific RTS calls.
Copyright (c) 2006, 2015 David C. J. Matthews
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License version 2.1 as published by the Free Software Foundation.
This 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 this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
*/
/* This module is used for various run-time calls that are either in the
PolyML structure or otherwise specific to Poly/ML. */
#ifdef HAVE_CONFIG_H
#include "config.h"
#elif defined(_WIN32)
#include "winconfig.h"
#else
#error "No configuration file"
#endif
#ifdef HAVE_ASSERT_H
#include <assert.h>
#endif
#include "globals.h"
#include "poly_specific.h"
#include "arb.h"
#include "mpoly.h"
#include "sys.h"
#include "machine_dep.h"
#include "polystring.h"
#include "run_time.h"
#include "version.h"
#include "save_vec.h"
#include "exporter.h"
#include "version.h"
#include "sharedata.h"
#include "objsize.h"
#include "memmgr.h"
#include "processes.h"
#include "savestate.h"
#include "statistics.h"
#include "../polystatistics.h"
#define SAVE(x) taskData->saveVec.push(x)
static const char *poly_runtime_system_copyright =
"Copyright (c) 2002-15 CUTS, David C.J. Matthews and contributors.";
#define Str(x) #x
#define Xstr(x) Str(x)
#ifdef GIT_VERSION
#define GitVersion Xstr(GIT_VERSION)
#else
#define GitVersion ""
#endif
// Property bits for functions. For compiled functions these are
// stored in the register mask word. None of the architectures has
// more than 20 usable registers so we're safe putting them in these bits.
// N.B. These are untagged values.
// NORAISE means the function does not raise an exception.
// NOUPDATE means the function does not perform any side-effects so if
// its value is not used and it doesn't raise an exception it can be eliminated.
// NODEREF means the value of the function depends only on the value of its arguments
// and not on any other state.
#define PROPWORD_NORAISE 0x40000000
#define PROPWORD_NOUPDATE 0x20000000
#define PROPWORD_NODEREF 0x10000000
static POLYUNSIGNED rtsProperties(TaskData *taskData, int i)
{
switch (i) {
case POLY_SYS_exit: return 0;
case POLY_SYS_chdir: return 0;
case POLY_SYS_alloc_store:
case POLY_SYS_alloc_uninit:
// Allocating memory doesn't have any visible effect on the state. It can raise Size.
// Two allocations return different addresses.
return PROPWORD_NOUPDATE;
case POLY_SYS_raisex: return 0;
case POLY_SYS_get_length: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_get_flags:
// This isn't quite true. It is possible to clear the mutable flag on a mutable segment.
return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_str_compare: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_teststrgtr: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_teststrlss: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_teststrgeq: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_teststrleq: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_exception_trace_fn: return 0;
case POLY_SYS_give_ex_trace_fn: return 0;
case POLY_SYS_lockseg: return PROPWORD_NORAISE|PROPWORD_NODEREF;
case POLY_SYS_emptystring: return 0; // Not a function
case POLY_SYS_nullvector: return 0; // Not a function
case POLY_SYS_network: return 0;
case POLY_SYS_os_specific: return 0;
case POLY_SYS_eq_longword: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_neq_longword: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_geq_longword: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_leq_longword: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_gt_longword: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_lt_longword: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_io_dispatch: return 0;
case POLY_SYS_signal_handler: return 0;
case POLY_SYS_atomic_reset: return PROPWORD_NORAISE;
case POLY_SYS_atomic_incr: return PROPWORD_NORAISE;
case POLY_SYS_atomic_decr: return PROPWORD_NORAISE;
case POLY_SYS_thread_self: return PROPWORD_NORAISE|PROPWORD_NOUPDATE;
case POLY_SYS_thread_dispatch: return 0;
case POLY_SYS_plus_longword: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_minus_longword: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_mul_longword: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_div_longword: return PROPWORD_NOUPDATE|PROPWORD_NODEREF; // Can raise Divide
case POLY_SYS_mod_longword: return PROPWORD_NOUPDATE|PROPWORD_NODEREF; // Can raise Divide
case POLY_SYS_andb_longword: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_orb_longword: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_xorb_longword: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_kill_self: return 0;
case POLY_SYS_shift_left_longword: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_shift_right_longword: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_shift_right_arith_longword: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_profiler: return 0;
case POLY_SYS_longword_to_tagged: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_signed_to_longword: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_unsigned_to_longword: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_full_gc: return PROPWORD_NORAISE; // Effectively has a side-effect
case POLY_SYS_stack_trace: return 0;
case POLY_SYS_timing_dispatch: return 0;
case POLY_SYS_objsize: return PROPWORD_NORAISE;
case POLY_SYS_showsize: return PROPWORD_NORAISE;
case POLY_SYS_quotrem: return PROPWORD_NOUPDATE|PROPWORD_NODEREF; // Can raise Divide
case POLY_SYS_is_short: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_aplus: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_aminus: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_amul: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_adiv: return PROPWORD_NOUPDATE|PROPWORD_NODEREF; // Can raise Divide
case POLY_SYS_amod: return PROPWORD_NOUPDATE|PROPWORD_NODEREF; // Can raise Divide
case POLY_SYS_aneg: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_xora: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_equala: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_ora: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_anda: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
// Floating point operations depend on the current rounding mode. That means
// that it's not possible to perform floating point operations at compile-time.
case POLY_SYS_Real_str: return PROPWORD_NORAISE|PROPWORD_NOUPDATE;
case POLY_SYS_Real_geq: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_Real_leq: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_Real_gtr: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_Real_lss: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_Real_eq: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_Real_neq: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_Real_Dispatch: return 0;
case POLY_SYS_Add_real: return PROPWORD_NORAISE|PROPWORD_NOUPDATE;
case POLY_SYS_Sub_real: return PROPWORD_NORAISE|PROPWORD_NOUPDATE;
case POLY_SYS_Mul_real: return PROPWORD_NORAISE|PROPWORD_NOUPDATE;
case POLY_SYS_Div_real: return PROPWORD_NORAISE|PROPWORD_NOUPDATE;
case POLY_SYS_Abs_real: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF; // Only affects sign
case POLY_SYS_Neg_real: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF; // Only affects sign
case POLY_SYS_conv_real: return PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_real_to_int: return PROPWORD_NORAISE|PROPWORD_NOUPDATE;
case POLY_SYS_int_to_real: return PROPWORD_NORAISE|PROPWORD_NOUPDATE;
case POLY_SYS_sqrt_real: return PROPWORD_NORAISE|PROPWORD_NOUPDATE;
case POLY_SYS_sin_real: return PROPWORD_NORAISE|PROPWORD_NOUPDATE;
case POLY_SYS_cos_real: return PROPWORD_NORAISE|PROPWORD_NOUPDATE;
case POLY_SYS_arctan_real: return PROPWORD_NORAISE|PROPWORD_NOUPDATE;
case POLY_SYS_exp_real: return PROPWORD_NORAISE|PROPWORD_NOUPDATE;
case POLY_SYS_ln_real: return PROPWORD_NORAISE|PROPWORD_NOUPDATE;
case POLY_SYS_stdin: return 0; // Not a function
case POLY_SYS_stdout: return 0; // Not a function
case POLY_SYS_process_env: return 0;
case POLY_SYS_set_string_length: return PROPWORD_NORAISE|PROPWORD_NODEREF;
case POLY_SYS_get_first_long_word: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_poly_specific: return 0;
case POLY_SYS_bytevec_eq: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_cmem_load_8: return PROPWORD_NORAISE|PROPWORD_NOUPDATE;
case POLY_SYS_cmem_load_16: return PROPWORD_NORAISE|PROPWORD_NOUPDATE;
case POLY_SYS_cmem_load_32: return PROPWORD_NORAISE|PROPWORD_NOUPDATE;
case POLY_SYS_cmem_load_float: return PROPWORD_NORAISE|PROPWORD_NOUPDATE;
case POLY_SYS_cmem_load_double: return PROPWORD_NORAISE|PROPWORD_NOUPDATE;
case POLY_SYS_cmem_store_8: return PROPWORD_NORAISE|PROPWORD_NODEREF;
case POLY_SYS_cmem_store_16: return PROPWORD_NORAISE|PROPWORD_NODEREF;
case POLY_SYS_cmem_store_32: return PROPWORD_NORAISE|PROPWORD_NODEREF;
#if (SIZEOF_VOIDP == 8)
case POLY_SYS_cmem_load_64: return PROPWORD_NORAISE|PROPWORD_NOUPDATE;
case POLY_SYS_cmem_store_64: return PROPWORD_NORAISE|PROPWORD_NODEREF;
#else
// These aren't implemented in 32-bit mode.
case POLY_SYS_cmem_load_64: return 0;
case POLY_SYS_cmem_store_64: return 0;
#endif
case POLY_SYS_cmem_store_float: return PROPWORD_NORAISE|PROPWORD_NODEREF;
case POLY_SYS_cmem_store_double: return PROPWORD_NORAISE|PROPWORD_NODEREF;
case POLY_SYS_io_operation: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_ffi: return 0;
case POLY_SYS_set_code_constant: return 0;
case POLY_SYS_move_words: return PROPWORD_NORAISE;
case POLY_SYS_move_words_overlap: return PROPWORD_NORAISE;
case POLY_SYS_shift_right_arith_word: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_int_to_word: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_move_bytes: return PROPWORD_NORAISE;
case POLY_SYS_move_bytes_overlap: return PROPWORD_NORAISE;
case POLY_SYS_code_flags: return 0;
case POLY_SYS_shrink_stack: return 0;
case POLY_SYS_stderr: return 0; // Not a function
case POLY_SYS_callcode_tupled: return 0;
case POLY_SYS_foreign_dispatch: return 0;
case POLY_SYS_XWindows: return 0;
case POLY_SYS_is_big_endian: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_bytes_per_word: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_offset_address: return 0;
case POLY_SYS_shift_right_word: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_word_neq: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_not_bool: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_touch_final: return PROPWORD_NORAISE; // We need to treat this as though it had side-effects.
case POLY_SYS_string_length: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_int_geq: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_int_leq: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_int_gtr: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_int_lss: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
// Load_byte/word_immut are the same as load_byte/word except that they can only
// be applied to immutables so will always return the same result.
case POLY_SYS_load_byte_immut: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_load_word_immut: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_mul_word: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_plus_word: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_minus_word: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_div_word: return PROPWORD_NOUPDATE|PROPWORD_NODEREF; // Can raise Divide
case POLY_SYS_or_word: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_and_word: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_xor_word: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_shift_left_word: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_mod_word: return PROPWORD_NOUPDATE|PROPWORD_NODEREF; // Can raise Divide
case POLY_SYS_word_geq: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_word_leq: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_word_gtr: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_word_lss: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_word_eq: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_load_byte: return PROPWORD_NORAISE|PROPWORD_NOUPDATE;
case POLY_SYS_load_word: return PROPWORD_NORAISE|PROPWORD_NOUPDATE;
case POLY_SYS_assign_byte: return PROPWORD_NORAISE|PROPWORD_NODEREF;
case POLY_SYS_assign_word: return PROPWORD_NORAISE|PROPWORD_NODEREF;
default: raise_exception_string(taskData, EXC_Fail, "Unknown IO operation");
}
}
#if (0)
// Convert the statistics into ML data. This is further unpicked within ML.
static Handle unpackStats(TaskData *taskData, const polystatistics *stats)
{
// Vector for the counts. Initially created as mutable then locked.
Handle counts = alloc_and_save(taskData, N_PS_COUNTERS, F_MUTABLE_BIT);
for (unsigned i = 0; i < N_PS_COUNTERS; i++)
{
Handle mark = taskData->saveVec.mark();
Handle counterValue = Make_arbitrary_precision(taskData, stats->psCounters[i]);
counts->WordP()->Set(i, counterValue->Word());
taskData->saveVec.reset(mark);
}
// Can now lock the count vector by removing the mutable flag.
counts->WordP()->SetLengthWord(N_PS_COUNTERS);
// Vector for the sizes.
Handle sizes = alloc_and_save(taskData, N_PS_SIZES, F_MUTABLE_BIT);
for (unsigned j = 0; j < N_PS_SIZES; j++)
{
Handle mark = taskData->saveVec.mark();
Handle sizeValue = Make_arbitrary_precision(taskData, stats->psSizes[j]);
sizes->WordP()->Set(j, sizeValue->Word());
taskData->saveVec.reset(mark);
}
sizes->WordP()->SetLengthWord(N_PS_SIZES);
// Vector for the times.
Handle times = alloc_and_save(taskData, N_PS_TIMES, F_MUTABLE_BIT);
for (unsigned k = 0; k < N_PS_TIMES; k++)
{
Handle mark = taskData->saveVec.mark();
#ifdef HAVE_WINDOWS_H
Handle sizeValue = Make_arb_from_Filetime(taskData, stats->psTimers[k]);
#else
Handle sizeValue =
Make_arb_from_pair_scaled(taskData, stats->psTimers[k].tv_sec, stats->psTimers[k].tv_usec, 1000000);
#endif
times->WordP()->Set(k, sizeValue->Word());
taskData->saveVec.reset(mark);
}
times->WordP()->SetLengthWord(N_PS_TIMES);
// Vector for the user stats
Handle users = alloc_and_save(taskData, N_PS_USER, F_MUTABLE_BIT);
for (unsigned l = 0; l < N_PS_USER; l++)
{
Handle mark = taskData->saveVec.mark();
Handle userValue = Make_arbitrary_precision(taskData, stats->psUser[l]);
users->WordP()->Set(l, userValue->Word());
taskData->saveVec.reset(mark);
}
users->WordP()->SetLengthWord(N_PS_USER);
// Result vector
Handle resultVec = alloc_and_save(taskData, 4);
resultVec->WordP()->Set(0, counts->Word());
resultVec->WordP()->Set(1, sizes->Word());
resultVec->WordP()->Set(2, times->Word());
resultVec->WordP()->Set(3, users->Word());
return resultVec;
}
#endif
Handle poly_dispatch_c(TaskData *taskData, Handle args, Handle code)
{
unsigned c = get_C_unsigned(taskData, DEREFWORDHANDLE(code));
switch (c)
{
case 1:
return exportNative(taskData, args); // Export
case 2:
raise_syscall(taskData, "C Export has been withdrawn", 0);
return 0;
case 3:
return exportPortable(taskData, args); // Export as portable format
case 9: // Return the GIT version if appropriate
{
return SAVE(C_string_to_Poly(taskData, GitVersion));
}
case 10: // Return the RTS version string.
{
const char *version;
switch (machineDependent->MachineArchitecture())
{
case MA_Interpreted: version = "Portable-" TextVersion; break;
case MA_I386: version = "I386-" TextVersion; break;
case MA_X86_64: version = "X86_64-" TextVersion; break;
default: version = "Unknown-" TextVersion; break;
}
return SAVE(C_string_to_Poly(taskData, version));
}
case 11: // Return the RTS copyright string
return SAVE(C_string_to_Poly(taskData, poly_runtime_system_copyright));
case 12: // Return the architecture
{
const char *arch;
switch (machineDependent->MachineArchitecture())
{
case MA_Interpreted: arch = "Interpreted"; break;
case MA_I386: arch = "I386"; break;
case MA_X86_64: arch = "X86_64"; break;
default: arch = "Unknown"; break;
}
return SAVE(C_string_to_Poly(taskData, arch));
}
case 13: // Share common immutable data.
{
ShareData(taskData, args);
return SAVE(TAGGED(0));
}
// ObjSize and ShowSize have their own IO vector entries but really they don't
// need them. Include them here and add ObjProfile.
case 14:
return ObjSize(taskData, args);
case 15:
return ShowSize(taskData, args);
case 16:
return ObjProfile(taskData, args);
/* 17 and 18 are no longer used. */
case 19: // Return the RTS argument help string.
return SAVE(C_string_to_Poly(taskData, RTSArgHelp()));
case 20: // Write a saved state file.
return SaveState(taskData, args);
case 21: // Load a saved state file and any ancestors.
return LoadState(taskData, false, args);
case 22: // Show the hierarchy.
return ShowHierarchy(taskData);
case 23: // Change the name of the immediate parent stored in a child
return RenameParent(taskData, args);
case 24: // Return the name of the immediate parent stored in a child
return ShowParent(taskData, args);
case 25: // Old statistics - now removed
case 26:
raise_exception_string(taskData, EXC_Fail, "No statistics available");
case 27: // Get number of user statistics available
return Make_arbitrary_precision(taskData, N_PS_USER);
case 28: // Set an entry in the user stats table.
{
unsigned index = get_C_unsigned(taskData, DEREFHANDLE(args)->Get(0));
if (index >= N_PS_USER)
raise_exception0(taskData, EXC_subscript);
POLYSIGNED value = getPolySigned(taskData, DEREFHANDLE(args)->Get(1));
globalStats.setUserCounter(index, value);
Make_arbitrary_precision(taskData, 0);
}
case 29: // Get local statistics.
return globalStats.getLocalStatistics(taskData);
case 30: // Get remote statistics. The argument is the process ID to get the statistics.
return globalStats.getRemoteStatistics(taskData, getPolyUnsigned(taskData, DEREFHANDLE(args)));
case 31: // Store a module
return StoreModule(taskData, args);
case 32: // Load a module
return LoadModule(taskData, args);
case 33: // Load hierarchy. This provides a complete list of children and parents.
return LoadState(taskData, true, args);
case 34: // Return the system directory for modules. This is configured differently
// in Unix and in Windows.
#if (defined(MODULEDIR))
return SAVE(C_string_to_Poly(taskData, Xstr(MODULEDIR)));
#elif (defined(_WIN32) && ! defined(__CYGWIN__))
{
// This registry key is configured when Poly/ML is installed using the installer.
// It gives the path to the Poly/ML installation directory. We return the
// Modules subdirectory.
HKEY hk;
if (RegOpenKeyEx(HKEY_LOCAL_MACHINE,
_T("SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\App Paths\\PolyML.exe"), 0,
KEY_QUERY_VALUE, &hk) == ERROR_SUCCESS)
{
DWORD valSize;
if (RegQueryValueEx(hk, _T("Path"), 0, NULL, NULL, &valSize) == ERROR_SUCCESS)
{
#define MODULEDIR _T("Modules")
TempString buff((TCHAR*)malloc(valSize + (_tcslen(MODULEDIR) + 1)*sizeof(TCHAR)));
DWORD dwType;
if (RegQueryValueEx(hk, _T("Path"), 0, &dwType, (LPBYTE)(LPTSTR)buff, &valSize) == ERROR_SUCCESS)
{
RegCloseKey(hk);
// The registry entry should end with a backslash.
_tcscat(buff, MODULEDIR);
return SAVE(C_string_to_Poly(taskData, buff));
}
}
RegCloseKey(hk);
}
return SAVE(C_string_to_Poly(taskData, ""));
}
#else
return SAVE(C_string_to_Poly(taskData, ""));
#endif
case 50: // GCD
return gcd_arbitrary(taskData, SAVE(DEREFHANDLE(args)->Get(0)), SAVE(DEREFHANDLE(args)->Get(1)));
case 51: // LCM
return lcm_arbitrary(taskData, SAVE(DEREFHANDLE(args)->Get(0)), SAVE(DEREFHANDLE(args)->Get(1)));
// These next ones were originally in process_env and have now been moved here,
case 100: /* Return the maximum word segment size. */
return taskData->saveVec.push(TAGGED(MAX_OBJECT_SIZE));
case 101: /* Return the maximum string size (in bytes).
It is the maximum number of bytes in a segment
less one word for the length field. */
return taskData->saveVec.push(TAGGED((MAX_OBJECT_SIZE)*sizeof(PolyWord) - sizeof(PolyWord)));
case 102: /* Test whether the supplied address is in the io area.
This was previously done by having get_flags return
256 but this was changed so that get_flags simply
returns the top byte of the length word. */
{
PolyWord *pt = (PolyWord*)DEREFWORDHANDLE(args);
if (gMem.IsIOPointer(pt))
return Make_arbitrary_precision(taskData, 1);
else return Make_arbitrary_precision(taskData, 0);
}
case 103: /* Return the register mask for the given function.
This is used by the code-generator to find out
which registers are modified by the function and
so need to be saved if they are used by the caller. */
{
PolyObject *pt = DEREFWORDHANDLE(args);
if (gMem.IsIOPointer(pt))
{
/* IO area. We need to get this from the vector. */
int i;
for (i=0; i < POLY_SYS_vecsize; i++)
{
if (pt == (PolyObject*)IoEntry(i))
{
int regMask = taskData->GetIOFunctionRegisterMask(i);
POLYUNSIGNED props = rtsProperties(taskData, i);
return taskData->saveVec.push(TAGGED(regMask | props));
}
}
raise_exception_string(taskData, EXC_Fail, "Io pointer not found");
}
else
{
/* We may have a pointer to the code or a pointer to
a closure. If it's a closure we have to find the
code. */
if (! pt->IsCodeObject() && ! pt->IsByteObject())
pt = pt->Get(0).AsObjPtr();
/* Should now be a code object. */
if (pt->IsCodeObject())
{
/* Compiled code. This is the second constant in the
constant area. */
PolyWord *codePt = pt->ConstPtrForCode();
PolyWord mask = codePt[1];
// A real mask will be an integer.
if (IS_INT(mask)) return SAVE(mask);
else raise_exception_string(taskData, EXC_Fail, "Invalid mask");
}
else raise_exception_string(taskData, EXC_Fail, "Not a code pointer");
}
}
case 104: return Make_arbitrary_precision(taskData, POLY_version_number);
case 105: /* Get the name of the function. */
{
PolyObject *pt = DEREFWORDHANDLE(args);
if (gMem.IsIOPointer(pt))
{
/* IO area. */
int i;
for (i=0; i < POLY_SYS_vecsize; i++)
{
if (pt == (PolyObject*)IoEntry(i))
{
char buff[8];
sprintf(buff, "RTS%d", i);
return SAVE(C_string_to_Poly(taskData, buff));
}
}
raise_syscall(taskData, "Io pointer not found", 0);
}
else if (pt->IsCodeObject()) /* Should now be a code object. */
{
/* Compiled code. This is the first constant in the constant area. */
PolyWord *codePt = pt->ConstPtrForCode();
PolyWord name = codePt[0];
/* May be zero indicating an anonymous segment - return null string. */
if (name == PolyWord::FromUnsigned(0))
return SAVE(C_string_to_Poly(taskData, ""));
else return SAVE(name);
}
else raise_syscall(taskData, "Not a code pointer", 0);
}
default:
{
char msg[100];
sprintf(msg, "Unknown poly-specific function: %d", c);
raise_exception_string(taskData, EXC_Fail, msg);
return 0;
}
}
}
|
