basis-library/primitive/prim-mlton.sml

   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