lib/stubs/mlton-stubs/mlton.sml

   1 (* Copyright (C) 2013 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 functor MkIO (S : sig
  11                      type instream
  12                      type outstream
  13                      val openOut: string -> outstream
  14                   end) =
  15    struct
  16       open S
  17
  18       fun inFd _ = raise Fail "IO.inFd"
  19       fun mkstemps {prefix, suffix} =
  20          let
  21             val name = concat [prefix, MLtonRandom.alphaNumString 6, suffix]
  22          in
  23             (* Make sure the temporary file name doesn't already exist. *)
  24             if OS.FileSys.access (name, [])
  25                 then mkstemps {prefix = prefix, suffix = suffix}
  26                 else (name, openOut name)
  27          end
  28       fun mkstemp s = mkstemps {prefix = s, suffix = ""}
  29       fun newIn _ = raise Fail "IO.newIn"
  30       fun newOut _ = raise Fail "IO.newOut"
  31       fun outFd _ = raise Fail "IO.outFd"
  32       fun setIn _ = raise Fail "IO.setIn"
  33       fun tempPrefix _ = raise Fail "IO.tempPrefix"
  34    end
  35
  36 functor MkWord(W : WORD) : MLTON_WORD =
  37    struct
  38       open W
  39       type t = word
  40
  41       val wordSize = Word.fromInt wordSize
  42
  43       val bswap = fn _ => raise Fail "Word.bswap"
  44       fun rol (w: word, w': Word.word): word =
  45          let
  46             val w' = Word.mod (w', wordSize)
  47          in
  48             orb (>> (w, Word.- (wordSize, w')),
  49                  << (w, w'))
  50          end
  51       fun ror (w: word, w': Word.word): word =
  52          let
  53             val w' = Word.mod (w', wordSize)
  54          in
  55             orb (>> (w, w'),
  56                  << (w, Word.- (wordSize, w')))
  57          end
  58
  59    end
  60
  61 (* This file is just a dummy provided in place of the structure that MLton
  62  * supplies so that we can compile under SML/NJ.
  63  *)
  64 structure MLton: MLTON =
  65    struct
  66       val debug = false
  67       val eq = fn _ => raise Fail "eq"
  68       val equal = fn _ => raise Fail "equal"
  69       val hash = fn _ => raise Fail "hash"
  70       val isMLton = MLton.isMLton
  71       val safe = true
  72       val share = fn _ => raise Fail "share"
  73       val shareAll = fn _ => raise Fail "shareAll"
  74       val size = MLton.size
  75
  76       structure Array =
  77          struct
  78             open Array
  79
  80             fun unfoldi (n, a, f) =
  81                let
  82                   val r = ref a
  83                   val a =
  84                      tabulate (n, fn i =>
  85                                let
  86                                   val (b, a') = f (i, !r)
  87                                   val _ = r := a'
  88                                in
  89                                   b
  90                                end)
  91                in
  92                   (a, !r)
  93                end
  94          end
  95
  96       structure BinIO = MkIO (BinIO)
  97
  98       structure Exn =
  99          struct
 100             val addExnMessager = fn _ => raise Fail "Exn.addExnMessager"
 101             val history = MLton.Exn.history
 102
 103             val defaultTopLevelHandler = fn _ => raise Fail "Exn.defaultTopLevelHandler"
 104             val getTopLevelHandler = fn _ => raise Fail "Exn.getTopLevelHandler"
 105             val setTopLevelHandler = fn _ => raise Fail "Exn.setTopLevelHandler"
 106             val topLevelHandler = fn _ => raise Fail "Exn.topLevelHandler"
 107          end
 108
 109       structure Finalizable =
 110          struct
 111             type 'a t = 'a
 112
 113             fun addFinalizer _ = ()
 114             fun finalizeBefore _ = ()
 115             fun new x = x
 116             fun touch _ = ()
 117             fun withValue (x, f) = f x
 118          end
 119
 120       structure GC =
 121          struct
 122             val collect = MLton.GC.collect
 123             val pack = MLton.GC.pack
 124             val setMessages = MLton.GC.setMessages
 125             fun setSummary _ = ()
 126             fun unpack _ = ()
 127
 128             structure Statistics =
 129                struct
 130                   val bytesAllocated = fn _ => raise Fail "GC.Statistics.bytesAllocated"
 131                   val lastBytesLive = fn _ => raise Fail "GC.Statistics.lastBytesLive"
 132                   val numCopyingGCs = fn _ => raise Fail "GC.Statistics.numCopyingGCs"
 133                   val numMarkCompactGCs = fn _ => raise Fail "GC.Statistics.numMarkCompactGCs"
 134                   val numMinorGCs = fn _ => raise Fail "GC.Statistics.numMinorGCs"
 135                   val maxBytesLive = fn _ => raise Fail "GC.Statistics.maxBytesLive"
 136                end
 137          end
 138
 139       structure Itimer =
 140          struct
 141             datatype t = Prof | Real | Virtual
 142
 143             fun signal _ = Posix.Signal.alrm
 144             fun set _ = raise Fail "Itimer.set"
 145          end
 146
 147       structure Platform =
 148          struct
 149             fun peek (l, f) = List.find f l
 150             fun omap (opt, f) = Option.map f opt
 151
 152             structure String =
 153                struct
 154                   open String
 155
 156                   val toLower = CharVector.map Char.toLower
 157                end
 158
 159             structure Arch =
 160                struct
 161                   datatype t = Alpha | AMD64 | ARM | ARM64 | HPPA | IA64 | m68k |
 162                                MIPS | PowerPC | PowerPC64 | S390 | Sparc | X86
 163
 164                   val all = [(Alpha, "Alpha"),
 165                              (AMD64, "AMD64"),
 166                              (ARM, "ARM"),
 167                              (ARM64, "ARM64"),
 168                              (HPPA, "HPPA"),
 169                              (IA64, "IA64"),
 170                              (m68k, "m68k"),
 171                              (MIPS, "MIPS"),
 172                              (PowerPC, "PowerPC"),
 173                              (PowerPC64, "PowerPC64"),
 174                              (S390, "S390"),
 175                              (Sparc, "Sparc"),
 176                              (X86, "X86")]
 177
 178                   fun fromString s =
 179                      let
 180                         val s = String.toLower s
 181                      in
 182                         omap (peek (all, fn (_, s') => s = String.toLower s'),
 183                               #1)
 184                      end
 185
 186                   fun toString a = #2 (valOf (peek (all, fn (a', _) => a = a')))
 187
 188                   val host: t =
 189                      case fromString (MLton.Platform.Arch.toString MLton.Platform.Arch.host) of
 190                         NONE => raise Fail "MLton.Platform.Arch.host: strange arch"
 191                       | SOME host => host
 192                end
 193
 194             structure OS =
 195                struct
 196                   datatype t =
 197                      AIX
 198                    | Cygwin
 199                    | Darwin
 200                    | FreeBSD
 201                    | HPUX
 202                    | Hurd
 203                    | Linux
 204                    | MinGW
 205                    | NetBSD
 206                    | OpenBSD
 207                    | Solaris
 208
 209                   val all = [(AIX, "AIX"),
 210                              (Cygwin, "Cygwin"),
 211                              (Darwin, "Darwin"),
 212                              (FreeBSD, "FreeBSD"),
 213                              (HPUX, "HPUX"),
 214                              (Hurd, "Hurd"),
 215                              (Linux, "Linux"),
 216                              (MinGW, "MinGW"),
 217                              (NetBSD, "NetBSD"),
 218                              (OpenBSD, "OpenBSD"),
 219                              (Solaris, "Solaris")]
 220
 221                   fun fromString s =
 222                      let
 223                         val s = String.toLower s
 224                      in
 225                         omap (peek (all, fn (_, s') => s = String.toLower s'),
 226                               #1)
 227                      end
 228
 229                   fun toString a = #2 (valOf (peek (all, fn (a', _) => a = a')))
 230
 231                   val host: t =
 232                      case fromString (MLton.Platform.OS.toString MLton.Platform.OS.host) of
 233                         NONE => raise Fail "MLton.Platform.OS.host: strange os"
 234                       | SOME os => os
 235                end
 236          end
 237
 238       structure ProcEnv =
 239          struct
 240             type gid = Posix.ProcEnv.gid
 241
 242             fun setenv _ = raise Fail "setenv"
 243             fun setgroups _ = raise Fail "setgroups"
 244          end
 245
 246       structure Process =
 247          struct
 248             type ('stdin, 'stdout, 'stderr) t = unit
 249             type input = unit
 250             type output = unit
 251             type none = unit
 252             type chain = unit
 253             type any = unit
 254
 255             exception MisuseOfForget
 256             exception DoublyRedirected
 257
 258             structure Child =
 259                struct
 260                   type ('use, 'dir) t = unit
 261
 262                   val binIn = fn _ => raise Fail "Child.binIn"
 263                   val binOut = fn _ => raise Fail "Child.binOut"
 264                   val fd = fn _ => raise Fail "Child.fd"
 265                   val remember = fn _ => raise Fail "Child.remember"
 266                   val textIn = fn _ => raise Fail "Child.textIn"
 267                   val textOut = fn _ => raise Fail "Child.textOut"
 268                end
 269
 270             structure Param =
 271                struct
 272                   type ('use, 'dir) t = unit
 273
 274                   val child = fn _ => raise Fail "Param.child"
 275                   val fd = fn _ => raise Fail "Param.fd"
 276                   val file = fn _ => raise Fail "Param.file"
 277                   val forget = fn _ => raise Fail "Param.forget"
 278                   val null = ()
 279                   val pipe = ()
 280                   val self = ()
 281                end
 282
 283             val create = fn _ => raise Fail "Process.create"
 284             val getStderr = fn _ => raise Fail "Process.getStderr"
 285             val getStdin  = fn _ => raise Fail "Process.getStdin"
 286             val getStdout = fn _ => raise Fail "Process.getStdout"
 287             val kill = fn _ => raise Fail "Process.kill"
 288             val reap = fn _ => raise Fail "Process.reap"
 289
 290             type pid = Posix.Process.pid
 291
 292             val atExit = OS.Process.atExit
 293
 294             fun exit n =
 295                let
 296                   open OS.Process
 297                in
 298                   exit (if n = 0 then success else failure)
 299                end
 300
 301             fun spawne {path, args, env} =
 302                case Posix.Process.fork () of
 303                   NONE => Posix.Process.exece (path, args, env)
 304                 | SOME pid => pid
 305
 306             fun spawn {path, args} =
 307                spawne {path = path, args = args, env = Posix.ProcEnv.environ ()}
 308
 309             fun spawnp {file, args} =
 310                case Posix.Process.fork () of
 311                   NONE => Posix.Process.execp (file, args)
 312                 | SOME pid => pid
 313          end
 314
 315       structure Profile =
 316          struct
 317             structure Data =
 318                struct
 319                   type t = unit
 320
 321                   val equals = fn _ => raise Fail "Profile.Data.equals"
 322                   val free = fn _ => raise Fail "Profile.Data.free"
 323                   val malloc = fn _ => raise Fail "Profile.Data.malloc"
 324                   val write = fn _ => raise Fail "Profile.Data.write"
 325                end
 326             val isOn = false
 327             val withData = fn _ => raise Fail "Profile.withData"
 328          end
 329
 330       structure Random = MLtonRandom
 331
 332       structure Rusage =
 333          struct
 334            type t = {stime: Time.time, utime: Time.time}
 335
 336            fun measureGC _ = ()
 337
 338            (* Fake it with Posix.ProcEnv.times
 339             * and Timer.totalCPUTimer and Timer.checkCPUTimes.
 340             *)
 341            fun rusage () =
 342               let
 343                  val zero = {utime = Time.zeroTime, stime = Time.zeroTime}
 344               in
 345                  let
 346                     val {gc = {usr = gcutime, sys = gcstime}, ...} =
 347                        Timer.checkCPUTimes (Timer.totalCPUTimer ())
 348                     val {utime, stime, cutime, cstime, ...} =
 349                        Posix.ProcEnv.times ()
 350                  in
 351                     {self = {utime = utime, stime = stime},
 352                      children = {utime = cutime, stime = cstime},
 353                      gc = {utime = gcutime, stime = gcstime}}
 354                  end handle Time => {children = zero, gc = zero, self = zero}
 355                  (* The handle Time is there because of a bug in SML/NJ that
 356                   * causes a Time exception to be raised on machines with a
 357                   * large uptime (enough that the number of clock ticks is
 358                   * >= 2^31).
 359                   *)
 360               end
 361          end
 362
 363       structure Signal =
 364          struct
 365             open Posix.Signal
 366
 367             type t = signal
 368
 369             val prof = alrm
 370             val vtalrm = alrm
 371
 372             structure Handler =
 373                struct
 374                   type t = unit
 375
 376                   val default = ()
 377                   val handler = fn _ => ()
 378                   val ignore = ()
 379                   val isDefault = fn _ => raise Fail "Signal.Handler.isDefault"
 380                   val isIgnore = fn _ => raise Fail "Signal.Handler.isIgnore"
 381                   fun simple _ = ()
 382                end
 383
 384             structure Mask =
 385                struct
 386                   type t = unit
 387
 388                   val all = ()
 389                   fun allBut _ = ()
 390                   fun block _ = raise Fail "Signal.Mask.block"
 391                   fun getBlocked _ = ()
 392                   fun isMember _ = raise Fail "Signal.Mask.isMember"
 393                   val none = ()
 394                   fun setBlocked _ = raise Fail "Signal.Mask.setBlocked"
 395                   fun some _ = ()
 396                   fun unblock _ = raise Fail "Signal.Mask.unblock"
 397                end
 398
 399             fun getHandler _ = raise Fail "Signal.getHandler"
 400             fun handled _ = raise Fail "Signal.handled"
 401             val restart = ref true
 402             fun setHandler _ = raise Fail "Signal.setHandler"
 403             fun suspend _ = raise Fail "Signal.suspend"
 404          end
 405
 406       structure TextIO = MkIO (TextIO)
 407
 408       structure Thread = MLtonThread
 409
 410       structure Vector =
 411          struct
 412             open Vector
 413
 414             fun create n =
 415                let
 416                   val r = ref (Array.fromList [])
 417                   val subLim = ref 0
 418                   fun sub i =
 419                      if 0 <= i andalso i < !subLim
 420                         then Array.sub (!r, i)
 421                      else raise Subscript
 422                   val updateLim = ref 0
 423                   fun update (i, x) =
 424                      if 0 <= i andalso i < !updateLim
 425                         then if i = !updateLim andalso i < n
 426                                 then (r := (Array.tabulate (i + 1, fn j =>
 427                                                             if i = j
 428                                                                then x
 429                                                             else Array.sub (!r, j)));
 430                                       subLim := i + 1;
 431                                       updateLim := i + 1)
 432                              else raise Subscript
 433                      else
 434                         Array.update (!r, i, x)
 435                   val gotIt = ref false
 436                   fun done () =
 437                      if !gotIt then
 438                         raise Fail "already got vector"
 439                      else
 440                         if n = !updateLim then
 441                            (gotIt := true;
 442                             updateLim := 0;
 443                             Array.vector (!r))
 444                         else
 445                            raise Fail "vector not full"
 446                in
 447                   {done = done,
 448                    sub = sub,
 449                    update = update}
 450                end
 451
 452             fun unfoldi (n, a, f) =
 453                let
 454                   val r = ref a
 455                   val v =
 456                      tabulate (n, fn i =>
 457                                let
 458                                   val (b, a') = f (i, !r)
 459                                   val _ = r := a'
 460                                in
 461                                   b
 462                                end)
 463                in
 464                   (v, !r)
 465                end
 466          end
 467
 468       structure Weak =
 469          struct
 470             type 'a t = 'a
 471
 472             val get = SOME
 473             fun new x = x
 474          end
 475
 476       structure World =
 477          struct
 478             datatype status = Clone | Original
 479             fun load _ = raise Fail "World.load"
 480             fun save _ = raise Fail "World.save"
 481             fun saveThread _ = raise Fail "World.saveThread"
 482          end
 483
 484       structure Word = MkWord(Word)
 485       structure Word8 = MkWord(Word8)
 486    end