lib/cml/core-cml/thread-id.sml

   1 (* thread.sml
   2  * 2004 Matthew Fluet (mfluet@acm.org)
   3  *  Ported to MLton threads.
   4  *)
   5
   6 (* thread.sml
   7  *
   8  * COPYRIGHT (c) 1995 AT&T Bell Laboratories.
   9  * COPYRIGHT (c) 1989-1991 John H. Reppy
  10  *)
  11
  12 structure ThreadID : THREAD_ID_EXTRA =
  13    struct
  14       structure Assert = LocalAssert(val assert = false)
  15
  16       structure R = RepTypes
  17
  18
  19       datatype thread_id = datatype R.thread_id
  20       datatype thread_id' = datatype thread_id
  21
  22       fun sameTid (TID{id=a, ...}, TID{id=b, ...}) = a = b
  23       fun compareTid (TID{id=a, ...}, TID{id=b, ...}) = Int.compare (a, b)
  24       fun hashTid (TID{id, ...}) = Word.fromInt id
  25
  26       fun tidToString (TID{id, ...}) =
  27          concat["[", StringCvt.padLeft #"0" 6 (Int.toString id), "]"]
  28
  29       fun exnHandler (_ : exn) = ()
  30       val defaultExnHandler = ref exnHandler
  31
  32       fun new' n =
  33          TID {id = n,
  34               alert = ref false,
  35               done_comm = ref false,
  36               exnHandler = ref (!defaultExnHandler),
  37               props = ref [],
  38               dead = CVar.new ()}
  39
  40       local
  41          val tidCounter = ref 0
  42       in
  43          fun new () =
  44             let
  45                val _ = Assert.assertAtomic' ("ThreadID.newTid", NONE)
  46                val n = !tidCounter
  47                val _ = tidCounter := n + 1
  48             in
  49                new' n
  50             end
  51
  52          fun reset () = tidCounter := 0
  53       end
  54
  55       fun bogus s =
  56          let val n = CharVector.foldr (fn (c, n) => 2 * n - Char.ord c) 0 s
  57          in new' n
  58          end
  59
  60       fun mark (TID{done_comm, ...}) =
  61          (Assert.assertAtomic' ("ThreadID.mark", NONE)
  62           ; done_comm := true)
  63       fun unmark (TID{done_comm, ...}) =
  64          (Assert.assertAtomic' ("ThreadID.unmark", NONE)
  65           ; done_comm := false)
  66       fun isMarked (TID{done_comm, ...}) = !done_comm
  67    end