mlton/atoms/word-x.fun

   1 (* Copyright (C) 2009,2014 Matthew Fluet.
   2  * Copyright (C) 2004-2007 Henry Cejtin, Matthew Fluet, Suresh
   3  *    Jagannathan, and Stephen Weeks.
   4  *
   5  * MLton is released under a BSD-style license.
   6  * See the file MLton-LICENSE for details.
   7  *)
   8
   9 functor WordX (S: WORD_X_STRUCTS): WORD_X =
  10 struct
  11
  12 open S
  13
  14 val modulus: WordSize.t -> IntInf.t =
  15    fn s => IntInf.<< (1, Bits.toWord (WordSize.bits s))
  16
  17 local
  18    datatype t = T of {size: WordSize.t,
  19                       value: IntInf.t}
  20 in
  21    type t = t
  22    fun make (i: IntInf.t, s: WordSize.t) =
  23       T {size = s,
  24          value = i mod modulus s}
  25    fun dest (T r) = r
  26 end
  27
  28 local
  29    fun make f = f o dest
  30 in
  31    val size = make #size
  32    val value = make #value
  33 end
  34
  35 val toIntInf = value
  36
  37 fun toIntInfX w =
  38    let
  39       val v = value w
  40       val m = modulus (size w)
  41    in
  42       if v >= m div 2
  43          then v - m
  44       else v
  45    end
  46
  47 val toInt = IntInf.toInt o toIntInf
  48
  49 fun toString w = concat ["0x", IntInf.format (toIntInf w, StringCvt.HEX)]
  50
  51 val layout = Layout.str o toString
  52
  53 fun zero s = make (0, s)
  54
  55 val hash = IntInf.hash o toIntInf
  56
  57 local
  58    val make: (IntInf.t * Word.t -> IntInf.t) -> t * t -> t =
  59       fn f => fn (w, w') =>
  60       let
  61          val s = size w
  62          val v' = value w'
  63       in
  64          if v' >= Bits.toIntInf (WordSize.bits s)
  65             then zero s
  66          else make (f (value w, Word.fromIntInf v'), s)
  67       end
  68 in
  69    val lshift = make IntInf.<<
  70    val >> = make IntInf.~>> (* OK because we know the value is positive. *)
  71 end
  72
  73 fun equals (w, w') = WordSize.equals (size w, size w') andalso value w = value w'
  74
  75 fun fromChar (c: Char.t) = make (Int.toIntInf (Char.toInt c), WordSize.byte)
  76
  77 val fromIntInf = make
  78
  79 fun isAllOnes w = value w = modulus (size w) - 1
  80
  81 fun isOne w = 1 = value w
  82
  83 fun isZero w = 0 = value w
  84
  85 fun isNegOne w = ~1 = toIntInfX w
  86
  87 local
  88    fun make f (s, sg) = fromIntInf (f (s, sg), s)
  89 in
  90    val max = make WordSize.max
  91    val min = make WordSize.min
  92 end
  93
  94 fun allOnes s = max (s, {signed = false})
  95
  96 local
  97    fun make f (w, sg) = equals (w, f (size w, sg))
  98 in
  99    val isMax = make max
 100    val isMin = make min
 101 end
 102
 103 fun notb w = make (IntInf.notb (value w), size w)
 104
 105 fun one s = make (1, s)
 106
 107 fun toIntInfSg (w, {signed}) =
 108    if signed then toIntInfX w else toIntInf w
 109
 110 fun resize (w, s) = make (toIntInf w, s)
 111
 112 fun resizeX (w, s) = make (toIntInfX w, s)
 113
 114 fun toChar (w: t): char = Char.fromInt (Int.fromIntInf (value w))
 115
 116 fun ~>> (w, w') =
 117    let
 118       val shift = value w'
 119       val s = size w
 120       val b = WordSize.bits s
 121       val shift = if shift > Bits.toIntInf b
 122                      then Bits.toWord b
 123                   else Word.fromIntInf shift
 124    in
 125       make (IntInf.~>> (toIntInfX w, shift), s)
 126    end
 127
 128 fun rshift (w, w', {signed}) =
 129    if signed then ~>> (w, w') else >> (w, w')
 130
 131 fun swap (i: IntInf.t, {hi: word, lo: word}) =
 132    let
 133       open IntInf
 134    in
 135       orb (~>> (i, lo), << (i mod << (1, lo), hi))
 136    end
 137
 138 fun rol (w, w') =
 139    let
 140       val s = size w
 141       val b = WordSize.bits s
 142       val shift = Word.fromIntInf (value w' mod Bits.toIntInf b)
 143    in
 144       make (swap (value w, {hi = shift, lo = Bits.toWord b - shift}), s)
 145    end
 146
 147 fun ror (w, w') =
 148    let
 149       val s = size w
 150       val b = WordSize.bits s
 151       val shift = Word.fromIntInf (value w' mod Bits.toIntInf b)
 152    in
 153       make (swap (value w, {hi = Bits.toWord b - shift, lo = shift}), s)
 154    end
 155
 156 local
 157    val make: ((IntInf.t * IntInf.t -> IntInf.t) * string) -> t * t -> t =
 158       fn (f,name) => fn (w, w') =>
 159       if WordSize.equals (size w, size w')
 160          then make (f (value w, value w'), size w)
 161       else Error.bug (concat ["WordX.", name])
 162 in
 163    val add = make (IntInf.+, "add")
 164    val sub = make (IntInf.-, "sub")
 165    val andb = make (IntInf.andb, "andb")
 166    val orb = make (IntInf.orb, "orb")
 167    val xorb = make (IntInf.xorb, "xorb")
 168 end
 169
 170 fun neg w = make (~ (toIntInfX w), size w)
 171
 172 local
 173    val make: ((IntInf.t * IntInf.t -> IntInf.t) * string) -> t * t * {signed: bool}-> t =
 174       fn (f,name) => fn (w, w', s) =>
 175       if WordSize.equals (size w, size w')
 176          then make (f (toIntInfSg (w, s), toIntInfSg (w', s)), size w)
 177       else Error.bug (concat ["WordX.", name])
 178 in
 179    val op div = make (IntInf.div, "div")
 180    val op mod = make (IntInf.mod, "mod")
 181    val mul = make (IntInf.*, "mul")
 182    val quot = make (IntInf.quot, "quot")
 183    val rem = make (IntInf.rem, "rem")
 184 end
 185
 186 local
 187    val make: ((IntInf.t * IntInf.t -> 'a) * string) -> t * t * {signed: bool} -> 'a =
 188       fn (f,name) => fn (w, w', sg) =>
 189       if WordSize.equals (size w, size w')
 190          then f (toIntInfSg (w, sg), toIntInfSg (w', sg))
 191       else Error.bug (concat ["WordX.", name])
 192 in
 193    val compare = make (IntInf.compare, "compare")
 194    val lt = make (IntInf.<, "lt")
 195    val le = make (IntInf.<=, "le")
 196    val gt = make (IntInf.>, "gt")
 197    val ge = make (IntInf.>=, "ge")
 198 end
 199
 200 fun layoutSg {signed} = Layout.record [("signed", Bool.layout signed)]
 201
 202 val lt = Trace.trace3 ("WordX.lt", layout, layout, layoutSg, Bool.layout) lt
 203
 204 end