1 /*
2 Title: poly_specific.cpp - Poly/ML specific RTS calls.
3
4 Copyright (c) 2006, 2015-17, 2019 David C. J. Matthews
5
6 This library is free software; you can redistribute it and/or
7 modify it under the terms of the GNU Lesser General Public
8 License version 2.1 as published by the Free Software Foundation.
9
10 This library is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 Lesser General Public License for more details.
14
15 You should have received a copy of the GNU Lesser General Public
16 License along with this library; if not, write to the Free Software
17 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
18
19 */
20
21 /* This module is used for various run-time calls that are either in the
22 PolyML structure or otherwise specific to Poly/ML. */
23
24 #ifdef HAVE_CONFIG_H
25 #include "config.h"
26 #elif defined(_WIN32)
27 #include "winconfig.h"
28 #else
29 #error "No configuration file"
30 #endif
31
32 #ifdef HAVE_ASSERT_H
33 #include <assert.h>
34 #define ASSERT(x) assert(x)
35 #else
36 #define ASSERT(x) 0
37 #endif
38
39 #ifdef HAVE_STRING_H
40 #include <string.h>
41 #endif
42
43 #include "globals.h"
44 #include "poly_specific.h"
45 #include "arb.h"
46 #include "mpoly.h"
47 #include "sys.h"
48 #include "machine_dep.h"
49 #include "polystring.h"
50 #include "run_time.h"
51 #include "version.h"
52 #include "save_vec.h"
53 #include "version.h"
54 #include "memmgr.h"
55 #include "processes.h"
56 #include "gc.h"
57 #include "rtsentry.h"
58
59 extern "C" {
60 POLYEXTERNALSYMBOL POLYUNSIGNED PolySpecificGeneral(FirstArgument threadId, PolyWord code, PolyWord arg);
61 POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetABI();
62 POLYEXTERNALSYMBOL POLYUNSIGNED PolyLockMutableClosure(FirstArgument threadId, PolyWord closure);
63 POLYEXTERNALSYMBOL POLYUNSIGNED PolyCopyByteVecToClosure(FirstArgument threadId, PolyWord byteVec, PolyWord closure);
64 POLYEXTERNALSYMBOL POLYUNSIGNED PolySetCodeConstant(PolyWord closure, PolyWord offset, PolyWord c, PolyWord flags);
65 POLYEXTERNALSYMBOL POLYUNSIGNED PolySetCodeByte(PolyWord closure, PolyWord offset, PolyWord c);
66 POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetCodeByte(PolyWord closure, PolyWord offset);
67 POLYEXTERNALSYMBOL POLYUNSIGNED PolySortArrayOfAddresses(PolyWord array);
68 POLYEXTERNALSYMBOL POLYUNSIGNED PolyTest4(FirstArgument threadId, PolyWord arg1, PolyWord arg2, PolyWord arg3, PolyWord arg4);
69 POLYEXTERNALSYMBOL POLYUNSIGNED PolyTest5(FirstArgument threadId, PolyWord arg1, PolyWord arg2, PolyWord arg3, PolyWord arg4, PolyWord arg5);
70 }
71
72 #define SAVE(x) taskData->saveVec.push(x)
73
74 #ifndef GIT_VERSION
75 #define GIT_VERSION ""
76 #endif
77
78
poly_dispatch_c(TaskData * taskData,Handle args,Handle code)79 Handle poly_dispatch_c(TaskData *taskData, Handle args, Handle code)
80 {
81 unsigned c = get_C_unsigned(taskData, DEREFWORD(code));
82 switch (c)
83 {
84 case 9: // Return the GIT version if appropriate
85 {
86 return SAVE(C_string_to_Poly(taskData, GIT_VERSION));
87 }
88
89 case 10: // Return the RTS version string.
90 {
91 const char *version;
92 switch (machineDependent->MachineArchitecture())
93 {
94 case MA_Interpreted: version = "Portable-" TextVersion; break;
95 case MA_I386: version = "I386-" TextVersion; break;
96 case MA_X86_64: version = "X86_64-" TextVersion; break;
97 default: version = "Unknown-" TextVersion; break;
98 }
99 return SAVE(C_string_to_Poly(taskData, version));
100 }
101
102 case 12: // Return the architecture
103 // Used in InitialPolyML.ML for PolyML.architecture
104 {
105 const char *arch;
106 switch (machineDependent->MachineArchitecture())
107 {
108 case MA_Interpreted: arch = "Interpreted"; break;
109 case MA_I386: arch = "I386"; break;
110 case MA_X86_64: arch = "X86_64"; break;
111 case MA_X86_64_32: arch = "X86_64_32"; break;
112 default: arch = "Unknown"; break;
113 }
114 return SAVE(C_string_to_Poly(taskData, arch));
115 }
116
117 case 19: // Return the RTS argument help string.
118 return SAVE(C_string_to_Poly(taskData, RTSArgHelp()));
119
120 default:
121 {
122 char msg[100];
123 sprintf(msg, "Unknown poly-specific function: %d", c);
124 raise_exception_string(taskData, EXC_Fail, msg);
125 return 0;
126 }
127 }
128 }
129
130 // General interface to poly-specific. Ideally the various cases will be made into
131 // separate functions.
PolySpecificGeneral(FirstArgument threadId,PolyWord code,PolyWord arg)132 POLYUNSIGNED PolySpecificGeneral(FirstArgument threadId, PolyWord code, PolyWord arg)
133 {
134 TaskData *taskData = TaskData::FindTaskForId(threadId);
135 ASSERT(taskData != 0);
136 taskData->PreRTSCall();
137 Handle reset = taskData->saveVec.mark();
138 Handle pushedCode = taskData->saveVec.push(code);
139 Handle pushedArg = taskData->saveVec.push(arg);
140 Handle result = 0;
141
142 try {
143 result = poly_dispatch_c(taskData, pushedArg, pushedCode);
144 } catch (...) { } // If an ML exception is raised
145
146 taskData->saveVec.reset(reset);
147 taskData->PostRTSCall();
148 if (result == 0) return TAGGED(0).AsUnsigned();
149 else return result->Word().AsUnsigned();
150 }
151
152 // Return the ABI - i.e. the calling conventions used when calling external functions.
PolyGetABI()153 POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetABI()
154 {
155 // Return the ABI. For 64-bit we need to know if this is Windows.
156 #if (SIZEOF_VOIDP == 8)
157 #if (defined(_WIN32) || defined(__CYGWIN__))
158 return TAGGED(2).AsUnsigned(); // 64-bit Windows
159 #else
160 return TAGGED(1).AsUnsigned(); // 64-bit Unix
161 #endif
162 #else
163 return TAGGED(0).AsUnsigned(); // 32-bit Unix and Windows
164 #endif
165 }
166
167 // Code generation - Code is initially allocated in a byte segment. When all the
168 // values have been set apart from any addresses the byte segment is copied into
169 // a mutable code segment.
170
171 // Copy the byte vector into code space.
PolyCopyByteVecToClosure(FirstArgument threadId,PolyWord byteVec,PolyWord closure)172 POLYUNSIGNED PolyCopyByteVecToClosure(FirstArgument threadId, PolyWord byteVec, PolyWord closure)
173 {
174 TaskData *taskData = TaskData::FindTaskForId(threadId);
175 ASSERT(taskData != 0);
176 taskData->PreRTSCall();
177 Handle reset = taskData->saveVec.mark();
178 Handle pushedByteVec = taskData->saveVec.push(byteVec);
179 Handle pushedClosure = taskData->saveVec.push(closure);
180 PolyObject *result = 0;
181
182 try {
183 if (!pushedByteVec->WordP()->IsByteObject())
184 raise_fail(taskData, "Not byte data area");
185 if (pushedClosure->WordP()->Length() != sizeof(PolyObject*)/sizeof(PolyWord))
186 raise_fail(taskData, "Invalid closure size");
187 if (!pushedClosure->WordP()->IsMutable())
188 raise_fail(taskData, "Closure is not mutable");
189 do {
190 PolyObject *initCell = pushedByteVec->WordP();
191 POLYUNSIGNED requiredSize = initCell->Length();
192 result = gMem.AllocCodeSpace(requiredSize);
193 if (result == 0)
194 {
195 // Could not allocate - must GC.
196 if (!QuickGC(taskData, pushedByteVec->WordP()->Length()))
197 raise_fail(taskData, "Insufficient memory");
198 }
199 else memcpy(gMem.SpaceForObjectAddress(result)->writeAble((byte*)result), initCell, requiredSize * sizeof(PolyWord));
200 } while (result == 0);
201 }
202 catch (...) {} // If an ML exception is raised
203
204 // Store the code address in the closure.
205 *((PolyObject**)pushedClosure->WordP()) = result;
206 // Lock the closure.
207 pushedClosure->WordP()->SetLengthWord(pushedClosure->WordP()->LengthWord() & ~_OBJ_MUTABLE_BIT);
208
209 taskData->saveVec.reset(reset);
210 taskData->PostRTSCall();
211 return TAGGED(0).AsUnsigned();
212 }
213
214 // Code generation - Lock a mutable code segment and return the original address.
215 // Currently this does not allocate so other than the exception it could
216 // be a fast call.
PolyLockMutableClosure(FirstArgument threadId,PolyWord closure)217 POLYEXTERNALSYMBOL POLYUNSIGNED PolyLockMutableClosure(FirstArgument threadId, PolyWord closure)
218 {
219 TaskData *taskData = TaskData::FindTaskForId(threadId);
220 ASSERT(taskData != 0);
221 taskData->PreRTSCall();
222 Handle reset = taskData->saveVec.mark();
223 PolyObject *codeObj = *(PolyObject**)(closure.AsObjPtr());
224
225 try {
226 if (!codeObj->IsCodeObject() || !codeObj->IsMutable())
227 raise_fail(taskData, "Not mutable code area");
228 POLYUNSIGNED segLength = codeObj->Length();
229 gMem.SpaceForObjectAddress(codeObj)->writeAble(codeObj)->SetLengthWord(segLength, F_CODE_OBJ);
230 // In the future it may be necessary to return a different address here.
231 // N.B. The code area should only have execute permission in the native
232 // code version, not the interpreted version.
233 }
234 catch (...) {} // If an ML exception is raised
235
236 taskData->saveVec.reset(reset);
237 taskData->PostRTSCall();
238 return TAGGED(0).AsUnsigned();
239 }
240
241 // Set code constant. This can be a fast call.
242 // This is in the RTS both because we pass a closure in here and cannot have
243 // code addresses in 32-in-64 and also because we need to ensure there is no
244 // possibility of a GC while the code is an inconsistent state.
PolySetCodeConstant(PolyWord closure,PolyWord offset,PolyWord cWord,PolyWord flags)245 POLYUNSIGNED PolySetCodeConstant(PolyWord closure, PolyWord offset, PolyWord cWord, PolyWord flags)
246 {
247 byte *pointer;
248 // Previously we passed the code address in here and we need to
249 // retain that for legacy code. This is now the closure.
250 if (closure.AsObjPtr()->IsCodeObject())
251 pointer = closure.AsCodePtr();
252 else pointer = *(POLYCODEPTR*)(closure.AsObjPtr());
253 // pointer is the start of the code segment.
254 // c will usually be an address.
255 // offset is a byte offset
256 pointer += offset.UnTaggedUnsigned();
257 byte* writeable = gMem.SpaceForAddress(pointer)->writeAble(pointer);
258 switch (UNTAGGED(flags))
259 {
260 case 0: // Absolute constant - size PolyWord
261 {
262 POLYUNSIGNED c = cWord.AsUnsigned();
263 #ifdef WORDS_BIGENDIAN
264 // This is used to store constants in the constant area
265 // on the interpreted version.
266 for (unsigned i = sizeof(PolyWord); i > 0; i--)
267 {
268 writeable[i-1] = (byte)(c & 255);
269 c >>= 8;
270 }
271 #else
272 for (unsigned i = 0; i < sizeof(PolyWord); i++)
273 {
274 writeable[i] = (byte)(c & 255);
275 c >>= 8;
276 }
277 #endif
278 break;
279 }
280 case 1: // Relative constant - X86 - size 4 bytes
281 {
282 // The offset is relative to the END of the constant.
283 byte *target;
284 // In 32-in-64 we pass in the closure address here
285 // rather than the code address.
286 if (cWord.AsObjPtr()->IsCodeObject())
287 target = cWord.AsCodePtr();
288 else target = *(POLYCODEPTR*)(cWord.AsObjPtr());
289 size_t c = target - pointer - 4;
290 for (unsigned i = 0; i < sizeof(PolyWord); i++)
291 {
292 writeable[i] = (byte)(c & 255);
293 c >>= 8;
294 }
295 break;
296 }
297 case 2: // Absolute constant - size uintptr_t
298 // This is the same as case 0 except in 32-in-64 when
299 // it is an absolute address rather than an object pointer.
300 {
301 uintptr_t c = (uintptr_t)(cWord.AsObjPtr());
302 for (unsigned i = 0; i < sizeof(uintptr_t); i++)
303 {
304 pointer[i] = (byte)(c & 255);
305 c >>= 8;
306 }
307 break;
308 }
309 }
310 return TAGGED(0).AsUnsigned();
311 }
312
313 // Set a code byte. This needs to be in the RTS because it uses the closure
PolySetCodeByte(PolyWord closure,PolyWord offset,PolyWord cWord)314 POLYEXTERNALSYMBOL POLYUNSIGNED PolySetCodeByte(PolyWord closure, PolyWord offset, PolyWord cWord)
315 {
316 byte *pointer = *(POLYCODEPTR*)(closure.AsObjPtr());
317 byte* writable = gMem.SpaceForAddress(pointer)->writeAble(pointer);
318 writable[UNTAGGED_UNSIGNED(offset)] = (byte)UNTAGGED_UNSIGNED(cWord);
319 return TAGGED(0).AsUnsigned();
320 }
321
PolyGetCodeByte(PolyWord closure,PolyWord offset)322 POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetCodeByte(PolyWord closure, PolyWord offset)
323 {
324 byte *pointer = *(POLYCODEPTR*)(closure.AsObjPtr());
325 return TAGGED(pointer[UNTAGGED_UNSIGNED(offset)]).AsUnsigned();
326 }
327
compare(const void * a,const void * b)328 static int compare(const void *a, const void *b)
329 {
330 PolyWord *av = (PolyWord*)a;
331 PolyWord *bv = (PolyWord*)b;
332 if ((*av).IsTagged() || (*bv).IsTagged()) return 0; // Shouldn't happen
333 PolyObject *ao = (*av).AsObjPtr(), *bo = (*bv).AsObjPtr();
334 if (ao->Length() < 1 || bo->Length() < 1) return 0; // Shouldn't happen
335 if (ao->Get(0).AsUnsigned() < bo->Get(0).AsUnsigned())
336 return -1;
337 if (ao->Get(0).AsUnsigned() > bo->Get(0).AsUnsigned())
338 return 1;
339 return 0;
340 }
341
342 // Sort an array of addresses. This is used in the code-generator to search for
343 // duplicates in the address area. The argument is an array of pairs. The first
344 // item of each pair is an address, the second is an identifier of some kind.
PolySortArrayOfAddresses(PolyWord array)345 POLYEXTERNALSYMBOL POLYUNSIGNED PolySortArrayOfAddresses(PolyWord array)
346 {
347 if (!array.IsDataPtr()) return(TAGGED(0)).AsUnsigned();
348 PolyObject *arrayP = array.AsObjPtr();
349 POLYUNSIGNED numberOfItems = arrayP->Length();
350 if (!arrayP->IsMutable()) return(TAGGED(0)).AsUnsigned();
351 qsort(arrayP, numberOfItems, sizeof(PolyWord), compare);
352 return (TAGGED(1)).AsUnsigned();
353 }
354
PolyTest4(FirstArgument threadId,PolyWord arg1,PolyWord arg2,PolyWord arg3,PolyWord arg4)355 POLYEXTERNALSYMBOL POLYUNSIGNED PolyTest4(FirstArgument threadId, PolyWord arg1, PolyWord arg2, PolyWord arg3, PolyWord arg4)
356 {
357 switch (arg1.UnTaggedUnsigned())
358 {
359 case 1: return arg1.AsUnsigned();
360 case 2: return arg2.AsUnsigned();
361 case 3: return arg3.AsUnsigned();
362 case 4: return arg4.AsUnsigned();
363 default: return TAGGED(0).AsUnsigned();
364 }
365 }
366
PolyTest5(FirstArgument threadId,PolyWord arg1,PolyWord arg2,PolyWord arg3,PolyWord arg4,PolyWord arg5)367 POLYEXTERNALSYMBOL POLYUNSIGNED PolyTest5(FirstArgument threadId, PolyWord arg1, PolyWord arg2, PolyWord arg3, PolyWord arg4, PolyWord arg5)
368 {
369 switch (arg1.UnTaggedUnsigned())
370 {
371 case 1: return arg1.AsUnsigned();
372 case 2: return arg2.AsUnsigned();
373 case 3: return arg3.AsUnsigned();
374 case 4: return arg4.AsUnsigned();
375 case 5: return arg5.AsUnsigned();
376 default: return TAGGED(0).AsUnsigned();
377 }
378
379 }
380
381
382 struct _entrypts polySpecificEPT[] =
383 {
384 { "PolySpecificGeneral", (polyRTSFunction)&PolySpecificGeneral},
385 { "PolyGetABI", (polyRTSFunction)&PolyGetABI },
386 { "PolyCopyByteVecToClosure", (polyRTSFunction)&PolyCopyByteVecToClosure },
387 { "PolyLockMutableClosure", (polyRTSFunction)&PolyLockMutableClosure },
388 { "PolySetCodeConstant", (polyRTSFunction)&PolySetCodeConstant },
389 { "PolySetCodeByte", (polyRTSFunction)&PolySetCodeByte },
390 { "PolyGetCodeByte", (polyRTSFunction)&PolyGetCodeByte },
391 { "PolySortArrayOfAddresses", (polyRTSFunction)&PolySortArrayOfAddresses },
392 { "PolyTest4", (polyRTSFunction)&PolyTest4 },
393 { "PolyTest5", (polyRTSFunction)&PolyTest5 },
394
395 { NULL, NULL} // End of list.
396 };
397