Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 2010-2011,2013-2014,2017 Matthew Fluet. |
2 | * Copyright (C) 1999-2009 Henry Cejtin, Matthew Fluet, Suresh | |
3 | * Jagannathan, and Stephen Weeks. | |
4 | * Copyright (C) 1997-2000 NEC Research Institute. | |
5 | * | |
6 | * MLton is released under a BSD-style license. | |
7 | * See the file MLton-LICENSE for details. | |
8 | *) | |
9 | ||
10 | (* Primitive names are special -- see atoms/prim.fun. *) | |
11 | ||
12 | structure Primitive = struct | |
13 | ||
14 | open Primitive | |
15 | ||
16 | structure MLton = struct | |
17 | ||
18 | val eq = _prim "MLton_eq": 'a * 'a -> bool; | |
19 | val equal = _prim "MLton_equal": 'a * 'a -> bool; | |
20 | (* val deserialize = _prim "MLton_deserialize": Word8Vector.vector -> 'a ref; *) | |
21 | val halt = _prim "MLton_halt": C_Status.t -> unit; | |
22 | val hash = _prim "MLton_hash": 'a -> Word32.word; | |
23 | (* val serialize = _prim "MLton_serialize": 'a ref -> Word8Vector.vector; *) | |
24 | val share = _prim "MLton_share": 'a -> unit; | |
25 | val size = _prim "MLton_size": 'a -> C_Size.t; | |
26 | ||
27 | val installSignalHandler = | |
28 | _prim "MLton_installSignalHandler": unit -> unit; | |
29 | ||
30 | structure GCState = | |
31 | struct | |
32 | type t = Pointer.t | |
33 | ||
34 | val gcState = #1 _symbol "gcStateAddress" private: t GetSet.t; () | |
35 | end | |
36 | ||
37 | structure Align = | |
38 | struct | |
39 | datatype t = Align4 | Align8 | |
40 | ||
41 | val align = | |
42 | case _build_const "MLton_Align_align": Int32.int; of | |
43 | 4 => Align4 | |
44 | | 8 => Align8 | |
45 | | _ => raise Primitive.Exn.Fail8 "MLton_Align_align" | |
46 | end | |
47 | ||
48 | structure CallStack = | |
49 | struct | |
50 | (* The most recent caller is at index 0 in the array. *) | |
51 | datatype t = T of Word32.word array | |
52 | ||
53 | val callStack = | |
54 | _import "GC_callStack" runtime private: GCState.t * Word32.word array -> unit; | |
55 | val frameIndexSourceSeq = | |
56 | _import "GC_frameIndexSourceSeq" runtime private: GCState.t * Word32.word -> Pointer.t; | |
57 | val keep = _command_line_const "CallStack.keep": bool = false; | |
58 | val numStackFrames = | |
59 | _import "GC_numStackFrames" runtime private: GCState.t -> Word32.word; | |
60 | val sourceName = _import "GC_sourceName" runtime private: GCState.t * Word32.word -> C_String.t; | |
61 | end | |
62 | ||
63 | structure Codegen = | |
64 | struct | |
65 | datatype t = AMD64 | C | LLVM | X86 | |
66 | ||
67 | val codegen = | |
68 | case _build_const "MLton_Codegen_codegen": Int32.int; of | |
69 | 0 => C | |
70 | | 1 => X86 | |
71 | | 2 => AMD64 | |
72 | | 3 => LLVM | |
73 | | _ => raise Primitive.Exn.Fail8 "MLton_Codegen_codegen" | |
74 | ||
75 | val isC = codegen = C | |
76 | val isAMD64 = codegen = AMD64 | |
77 | val isLLVM = codegen = LLVM | |
78 | val isX86 = codegen = X86 | |
79 | end | |
80 | ||
81 | structure Exn = | |
82 | struct | |
83 | (* The polymorphism with extra and setInitExtra is because primitives | |
84 | * are only supposed to deal with basic types. The polymorphism | |
85 | * allows the various passes like monomorphisation to translate | |
86 | * the types appropriately. | |
87 | *) | |
88 | type extra = CallStack.t option | |
89 | ||
90 | val extra = _prim "Exn_extra": exn -> 'a; | |
91 | val extra: exn -> extra = extra | |
92 | val keepHistory = _command_line_const "Exn.keepHistory": bool = false; | |
93 | val setExtendExtra = _prim "Exn_setExtendExtra": ('a -> 'a) -> unit; | |
94 | val setExtendExtra: (extra -> extra) -> unit = setExtendExtra | |
95 | ||
96 | (* Ensure that setExtendExtra is initialized. | |
97 | * Important for -const 'Exn.keepHistory true', so that | |
98 | * exceptions can be raised (and handled) during Basis Library | |
99 | * initialization. | |
100 | *) | |
101 | val setExtendExtra : (extra -> extra) -> unit = | |
102 | if keepHistory | |
103 | then (setExtendExtra (fn _ => NONE) | |
104 | ; setExtendExtra) | |
105 | else fn _ => () | |
106 | end | |
107 | ||
108 | structure FFI = | |
109 | struct | |
110 | val getOpArgsResPtr = #1 _symbol "MLton_FFI_opArgsResPtr" private: Pointer.t GetSet.t; | |
111 | val numExports = _build_const "MLton_FFI_numExports": Int32.int; | |
112 | end | |
113 | ||
114 | structure Finalizable = | |
115 | struct | |
116 | val touch = _prim "MLton_touch": 'a -> unit; | |
117 | end | |
118 | ||
119 | structure GC = | |
120 | struct | |
121 | val collect = _prim "GC_collect": unit -> unit; | |
122 | val pack = _import "GC_pack" runtime private: GCState.t -> unit; | |
123 | val getBytesAllocated = | |
124 | _import "GC_getCumulativeStatisticsBytesAllocated" runtime private: GCState.t -> C_UIntmax.t; | |
125 | val getNumCopyingGCs = | |
126 | _import "GC_getCumulativeStatisticsNumCopyingGCs" runtime private: GCState.t -> C_UIntmax.t; | |
127 | val getNumMarkCompactGCs = | |
128 | _import "GC_getCumulativeStatisticsNumMarkCompactGCs" runtime private: GCState.t -> C_UIntmax.t; | |
129 | val getNumMinorGCs = | |
130 | _import "GC_getCumulativeStatisticsNumMinorGCs" runtime private: GCState.t -> C_UIntmax.t; | |
131 | val getLastBytesLive = | |
132 | _import "GC_getLastMajorStatisticsBytesLive" runtime private: GCState.t -> C_Size.t; | |
133 | val getMaxBytesLive = | |
134 | _import "GC_getCumulativeStatisticsMaxBytesLive" runtime private: GCState.t -> C_Size.t; | |
135 | val setHashConsDuringGC = | |
136 | _import "GC_setHashConsDuringGC" runtime private: GCState.t * bool -> unit; | |
137 | val setMessages = _import "GC_setControlsMessages" runtime private: GCState.t * bool -> unit; | |
138 | val setRusageMeasureGC = | |
139 | _import "GC_setControlsRusageMeasureGC" runtime private: GCState.t * bool -> unit; | |
140 | val setSummary = _import "GC_setControlsSummary" runtime private: GCState.t * bool -> unit; | |
141 | val unpack = _import "GC_unpack" runtime private: GCState.t -> unit; | |
142 | end | |
143 | ||
144 | structure Platform = | |
145 | struct | |
146 | structure Arch = | |
147 | struct | |
148 | datatype t = | |
149 | Alpha | |
150 | | AMD64 | |
151 | | ARM | |
152 | | ARM64 | |
153 | | HPPA | |
154 | | IA64 | |
155 | | m68k | |
156 | | MIPS | |
157 | | PowerPC | |
158 | | PowerPC64 | |
159 | | S390 | |
160 | | Sparc | |
161 | | X86 | |
162 | ||
163 | val host: t = | |
164 | case _const "MLton_Platform_Arch_host": String8.string; of | |
165 | "alpha" => Alpha | |
166 | | "amd64" => AMD64 | |
167 | | "arm" => ARM | |
168 | | "arm64" => ARM64 | |
169 | | "hppa" => HPPA | |
170 | | "ia64" => IA64 | |
171 | | "m68k" => m68k | |
172 | | "mips" => MIPS | |
173 | | "powerpc" => PowerPC | |
174 | | "powerpc64" => PowerPC64 | |
175 | | "s390" => S390 | |
176 | | "sparc" => Sparc | |
177 | | "x86" => X86 | |
178 | | _ => raise Primitive.Exn.Fail8 "strange MLton_Platform_Arch_host" | |
179 | ||
180 | val hostIsBigEndian = _const "MLton_Platform_Arch_bigendian": bool; | |
181 | end | |
182 | ||
183 | structure Format = | |
184 | struct | |
185 | datatype t = | |
186 | Archive | |
187 | | Executable | |
188 | | LibArchive | |
189 | | Library | |
190 | ||
191 | val host: t = | |
192 | case _build_const "MLton_Platform_Format": String8.string; of | |
193 | "archive" => Archive | |
194 | | "executable" => Executable | |
195 | | "libarchive" => LibArchive | |
196 | | "library" => Library | |
197 | | _ => raise Primitive.Exn.Fail8 "strange MLton_Platform_Format" | |
198 | end | |
199 | ||
200 | structure OS = | |
201 | struct | |
202 | datatype t = | |
203 | AIX | |
204 | | Cygwin | |
205 | | Darwin | |
206 | | FreeBSD | |
207 | | Hurd | |
208 | | HPUX | |
209 | | Linux | |
210 | | MinGW | |
211 | | NetBSD | |
212 | | OpenBSD | |
213 | | Solaris | |
214 | ||
215 | val host: t = | |
216 | case _const "MLton_Platform_OS_host": String8.string; of | |
217 | "aix" => AIX | |
218 | | "cygwin" => Cygwin | |
219 | | "darwin" => Darwin | |
220 | | "freebsd" => FreeBSD | |
221 | | "hurd" => Hurd | |
222 | | "hpux" => HPUX | |
223 | | "linux" => Linux | |
224 | | "mingw" => MinGW | |
225 | | "netbsd" => NetBSD | |
226 | | "openbsd" => OpenBSD | |
227 | | "solaris" => Solaris | |
228 | | _ => raise Primitive.Exn.Fail8 "strange MLton_Platform_OS_host" | |
229 | ||
230 | val forkIsEnabled = | |
231 | case host of | |
232 | Cygwin => | |
233 | #1 _symbol "MLton_Platform_CygwinUseMmap" private: bool GetSet.t; () | |
234 | | MinGW => false | |
235 | | _ => true | |
236 | ||
237 | val useWindowsProcess = not forkIsEnabled | |
238 | end | |
239 | end | |
240 | ||
241 | structure Pointer = | |
242 | struct | |
243 | open Pointer | |
244 | type pointer = t | |
245 | ||
246 | val add = | |
247 | _prim "CPointer_add": t * C_Ptrdiff.t -> t; | |
248 | val sub = | |
249 | _prim "CPointer_sub": t * C_Ptrdiff.t -> t; | |
250 | val diff = | |
251 | _prim "CPointer_diff": t * t -> C_Ptrdiff.t; | |
252 | val < = _prim "CPointer_lt": t * t -> bool; | |
253 | local | |
254 | structure S = IntegralComparisons(type t = t | |
255 | val < = <) | |
256 | in | |
257 | open S | |
258 | end | |
259 | ||
260 | val fromWord = | |
261 | _prim "CPointer_fromWord": C_Size.t -> t; | |
262 | val toWord = | |
263 | _prim "CPointer_toWord": t -> C_Size.t; | |
264 | ||
265 | val null: t = fromWord 0w0 | |
266 | ||
267 | fun isNull p = p = null | |
268 | ||
269 | val getCPointer = _prim "CPointer_getCPointer": t * C_Ptrdiff.t -> t; | |
270 | val getInt8 = _prim "CPointer_getWord8": t * C_Ptrdiff.t -> Int8.int; | |
271 | val getInt16 = _prim "CPointer_getWord16": t * C_Ptrdiff.t -> Int16.int; | |
272 | val getInt32 = _prim "CPointer_getWord32": t * C_Ptrdiff.t -> Int32.int; | |
273 | val getInt64 = _prim "CPointer_getWord64": t * C_Ptrdiff.t -> Int64.int; | |
274 | val getObjptr = _prim "CPointer_getObjptr": t * C_Ptrdiff.t -> 'a; | |
275 | val getReal32 = _prim "CPointer_getReal32": t * C_Ptrdiff.t -> Real32.real; | |
276 | val getReal64 = _prim "CPointer_getReal64": t * C_Ptrdiff.t -> Real64.real; | |
277 | val getWord8 = _prim "CPointer_getWord8": t * C_Ptrdiff.t -> Word8.word; | |
278 | val getWord16 = _prim "CPointer_getWord16": t * C_Ptrdiff.t -> Word16.word; | |
279 | val getWord32 = _prim "CPointer_getWord32": t * C_Ptrdiff.t -> Word32.word; | |
280 | val getWord64 = _prim "CPointer_getWord64": t * C_Ptrdiff.t -> Word64.word; | |
281 | val setCPointer = _prim "CPointer_setCPointer": t * C_Ptrdiff.t * t -> unit; | |
282 | val setInt8 = _prim "CPointer_setWord8": t * C_Ptrdiff.t * Int8.int -> unit; | |
283 | val setInt16 = _prim "CPointer_setWord16": t * C_Ptrdiff.t * Int16.int -> unit; | |
284 | val setInt32 = _prim "CPointer_setWord32": t * C_Ptrdiff.t * Int32.int -> unit; | |
285 | val setInt64 = _prim "CPointer_setWord64": t * C_Ptrdiff.t * Int64.int -> unit; | |
286 | val setObjptr = _prim "CPointer_setObjptr": t * C_Ptrdiff.t * 'a -> unit; | |
287 | val setReal32 = _prim "CPointer_setReal32": t * C_Ptrdiff.t * Real32.real -> unit; | |
288 | val setReal64 = _prim "CPointer_setReal64": t * C_Ptrdiff.t * Real64.real -> unit; | |
289 | val setWord8 = _prim "CPointer_setWord8": t * C_Ptrdiff.t * Word8.word -> unit; | |
290 | val setWord16 = _prim "CPointer_setWord16": t * C_Ptrdiff.t * Word16.word -> unit; | |
291 | val setWord32 = _prim "CPointer_setWord32": t * C_Ptrdiff.t * Word32.word -> unit; | |
292 | val setWord64 = _prim "CPointer_setWord64": t * C_Ptrdiff.t * Word64.word -> unit; | |
293 | end | |
294 | ||
295 | structure Profile = | |
296 | struct | |
297 | val isOn = _build_const "MLton_Profile_isOn": bool; | |
298 | structure Data = | |
299 | struct | |
300 | type t = Pointer.t | |
301 | ||
302 | val dummy = Pointer.null | |
303 | val free = _import "GC_profileFree" runtime private: GCState.t * t -> unit; | |
304 | val malloc = _import "GC_profileMalloc" runtime private: GCState.t -> t; | |
305 | val write = | |
306 | _import "GC_profileWrite" runtime private: GCState.t * t * NullString8.t -> unit; | |
307 | end | |
308 | val done = _import "GC_profileDone" runtime private: GCState.t -> unit; | |
309 | val getCurrent = _import "GC_getProfileCurrent" runtime private: GCState.t -> Data.t; | |
310 | val setCurrent = _import "GC_setProfileCurrent" runtime private : GCState.t * Data.t -> unit; | |
311 | end | |
312 | ||
313 | structure Thread = | |
314 | struct | |
315 | type preThread = PreThread.t | |
316 | type thread = Thread.t | |
317 | ||
318 | val atomicState = _prim "Thread_atomicState": unit -> Word32.word; | |
319 | val atomicBegin = _prim "Thread_atomicBegin": unit -> unit; | |
320 | fun atomicEnd () = | |
321 | if atomicState () = 0w0 | |
322 | then raise Primitive.Exn.Fail8 "Thread.atomicEnd" | |
323 | else _prim "Thread_atomicEnd": unit -> unit; () | |
324 | val copy = _prim "Thread_copy": preThread -> thread; | |
325 | (* copyCurrent's result is accesible via savedPre (). | |
326 | * It is not possible to have the type of copyCurrent as | |
327 | * unit -> preThread, because there are two different ways to | |
328 | * return from the call to copyCurrent. One way is the direct | |
329 | * obvious way, in the thread that called copyCurrent. That one, | |
330 | * of course, wants to call savedPre (). However, another way to | |
331 | * return is by making a copy of the preThread and then switching | |
332 | * to it. In that case, there is no preThread to return. Making | |
333 | * copyCurrent return a preThread creates nasty bugs where the | |
334 | * return code from the CCall expects to see a preThread result | |
335 | * according to the C return convention, but there isn't one when | |
336 | * switching to a copy. | |
337 | *) | |
338 | val copyCurrent = _prim "Thread_copyCurrent": unit -> unit; | |
339 | val current = _import "GC_getCurrentThread" runtime private: GCState.t -> thread; | |
340 | val finishSignalHandler = _import "GC_finishSignalHandler" runtime private: GCState.t -> unit; | |
341 | val returnToC = _prim "Thread_returnToC": unit -> unit; | |
342 | val saved = _import "GC_getSavedThread" runtime private: GCState.t -> thread; | |
343 | val savedPre = _import "GC_getSavedThread" runtime private: GCState.t -> preThread; | |
344 | val setCallFromCHandler = | |
345 | _import "GC_setCallFromCHandlerThread" runtime private: GCState.t * thread -> unit; | |
346 | val setSignalHandler = | |
347 | _import "GC_setSignalHandlerThread" runtime private: GCState.t * thread -> unit; | |
348 | val setSaved = _import "GC_setSavedThread" runtime private: GCState.t * thread -> unit; | |
349 | val startSignalHandler = _import "GC_startSignalHandler" runtime private: GCState.t -> unit; | |
350 | val switchTo = _prim "Thread_switchTo": thread -> unit; | |
351 | end | |
352 | ||
353 | structure Weak = | |
354 | struct | |
355 | open Weak | |
356 | ||
357 | val canGet = _prim "Weak_canGet": 'a t -> bool; | |
358 | val get = _prim "Weak_get": 'a t -> 'a; | |
359 | val new = _prim "Weak_new": 'a -> 'a t; | |
360 | end | |
361 | ||
362 | structure World = | |
363 | struct | |
364 | val getAmOriginal = _import "GC_getAmOriginal" runtime private: GCState.t -> bool; | |
365 | val setAmOriginal = _import "GC_setAmOriginal" runtime private: GCState.t * bool -> unit; | |
366 | val getSaveStatus = _import "GC_getSaveWorldStatus" runtime private: GCState.t -> bool C_Errno.t; | |
367 | (* save's result status is accesible via getSaveStatus (). | |
368 | * It is not possible to have the type of save as | |
369 | * NullString8.t -> bool C_Errno.t, because there are two | |
370 | * different ways to return from the call to save. One way is | |
371 | * the direct obvious way, in the program instance that called | |
372 | * save. However, another way to return is in the program | |
373 | * instance that loads the world. Making save return a bool | |
374 | * creates nasty bugs where the return code from the CCall | |
375 | * expects to see a bool result according to the C return | |
376 | * convention, but there isn't one when returning in the load | |
377 | * world. | |
378 | *) | |
379 | val save = _prim "World_save": NullString8.t -> unit; | |
380 | end | |
381 | ||
382 | end | |
383 | ||
384 | end |