1(* 2 Title: Standard Basis Library: BoolArray and BoolVector Structures 3 Author: David Matthews 4 Copyright David Matthews 1999, 2005, 2016 5 6 This library is free software; you can redistribute it and/or 7 modify it under the terms of the GNU Lesser General Public 8 License version 2.1 as published by the Free Software Foundation. 9 10 This library is distributed in the hope that it will be useful, 11 but WITHOUT ANY WARRANTY; without even the implied warranty of 12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 Lesser General Public License for more details. 14 15 You should have received a copy of the GNU Lesser General Public 16 License along with this library; if not, write to the Free Software 17 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 18*) 19local 20 open LibrarySupport 21 22 (* TODO: Use a single word for vectors of size <= number of bits in a word. *) 23 (* We use int here for the length rather than word because the number of bits 24 could be more than the maximum value of Word.word. *) 25 datatype vector = Vector of int * Bootstrap.byteVector (* This has a byte-wise equality. *) 26 and array = Array of int * Bootstrap.byteArray (* This has pointer equality. *) 27 28 val wordSize : word = LibrarySupport.wordSize 29 30 (* Casts between int and word. *) 31 val intAsWord: int -> word = RunCall.unsafeCast 32 and wordAsInt: word -> int = RunCall.unsafeCast 33 34 val bitsPerWord = wordSize * 0w8 35 36 (* Limit the size to Array.maxLen to avoid arithmetic overflow. *) 37 val maxLen = Array.maxLen 38 39 local 40 val F_mutable_bytes = 0wx41 41 in 42 (* Allocate memory for a vector or an array. *) 43 fun alloc (bits: int) = 44 let 45 val words : word = 46 if bits < 0 orelse bits > maxLen 47 then raise General.Size 48 else (Word.fromInt bits + (bitsPerWord - 0w1)) div bitsPerWord 49 val vec = RunCall.allocateByteMemory(words, F_mutable_bytes) 50 val bytes = words * wordSize 51 fun fill n = 52 if n = bytes 53 then () 54 else (RunCall.storeByte(vec, n, 0w0); fill(n+0w1)) 55 (* We will only set the bits that we actually use. Unused bytes will be uninitialised. 56 The equality function we're using tests all the bytes so we need to initialise them. *) 57 in 58 if bytes = 0w0 then () else fill(bytes - wordSize); 59 vec 60 end 61 end 62 63 val andb = Word.andb and orb = Word.orb and notb = Word.notb 64 and << = Word.<< and >> = Word.>>; 65 66 infix 9 sub 67 infix 7 andb 68 infix 6 orb 69 infix 5 << >> 70 71 72 (* Create a vector/array from a list. Used as the basis of 73 Array.fromList and Vector.fromList. *) 74 fun fromList' (l : bool list) = 75 let 76 val length = List.length l 77 (* Make a array initialised to zero. *) 78 val vec = alloc length 79 80 (* Accumulate the list elements into bytes and store 81 them in the vector. *) 82 fun init (byteno, acc, bit, []) = 83 if bit = 0w1 then () else RunCall.storeByte(vec, byteno, acc) 84 | init (byteno, acc, bit, a :: b) = 85 let 86 val byte = if a then bit orb acc else acc 87 in 88 if bit = 0wx80 89 then 90 ( 91 RunCall.storeByte(vec, byteno, byte); 92 init(byteno+0w1, 0w0, 0w1, b) 93 ) 94 else init(byteno, byte, bit << 0w1, b) 95 end 96 in 97 init(0w0, 0w0, 0w1, l); 98 (length, vec) 99 end 100 101 fun tabulate' (length: int, f : int->bool) = 102 let 103 val vec = 104 if length >= 0 then alloc length else raise General.Size; 105 106 (* Accumulate the bits into bytes and store into the array. *) 107 fun init i byteNo bit acc = 108 if i < length 109 then 110 let 111 val byte = if f i then bit orb acc else acc 112 in 113 if bit = 0wx80 114 then ( RunCall.storeByte(vec, byteNo, byte) ; init (i+1) (byteNo+0w1) 0w1 0w0 ) 115 else init (i+1) byteNo (bit << 0w1) byte 116 end 117 else if acc = 0w0 118 then () 119 else (* Put in the last byte. *) 120 RunCall.storeByte(vec, byteNo, acc) 121 in 122 init 0 0w0 0w1 0w0; 123 (length, vec) 124 end 125 126 (* Internal function which subscripts the vector assuming that 127 the index has already been checked for validity. *) 128 fun uncheckedSub (v, i: int): bool = 129 let 130 val iW = Word.fromInt i 131 val byte = RunCall.loadByte(v, iW >> 0w3) 132 val mask = 0w1 << (iW andb 0w7) 133 in 134 byte andb mask <> 0w0 135 end 136 137 (* Move a set of bits from one vector of bytes to another. The bits 138 may not be on the same byte alignment. Does not examine the 139 destination so if dest_off is not byte aligned any bits required in 140 the first byte must be passed in as src_in. Returns any bits which 141 do not exactly fit into a byte. *) 142 (* TODO: This only handles the case where the source starts at the beginning 143 of the vector. It is easy to modify it for the case where the source 144 offset is a multiple of 8 but more difficult to handle the other cases. *) 145 fun move_bits(src: Bootstrap.byteVector, dest: Bootstrap.byteVector, dest_off, len, last_bits) = 146 let 147 val dest_byte = intAsWord(Int.quot(dest_off, 8)) (* Byte offset *) 148 val dest_bit = intAsWord dest_off - dest_byte*0w8 (* Bit offset *) 149 150 fun do_move last byte len : word = 151 if len >= 8 152 then let 153 (* Get the next byte and shift it up *) 154 val newbyte = last orb (RunCall.loadByteFromImmutable(src, byte) << dest_bit) 155 in 156 (* Store the low-order 8 bits into the destination. *) 157 RunCall.storeByte(dest, dest_byte+byte, newbyte); 158 (* Shift the accumulator down by 8 bits and get ready for 159 the next byte. *) 160 do_move (newbyte >> 0w8) (byte+0w1) (len-8) 161 end 162 else if len <= 0 163 then last 164 else (* 0 < len < 8 *) 165 let 166 (* Get the next byte and shift it up *) 167 val nextsrc = RunCall.loadByteFromImmutable(src, byte); 168 val newbyte: word = last orb (nextsrc << dest_bit) 169 (* This assumes that any extra bits of the source are 170 zero. *) 171 in 172 if len + Word.toInt dest_bit >= 8 173 then 174 ( 175 (* Store the low-order 8 bits into the destination. *) 176 RunCall.storeByte(dest, dest_byte+byte, newbyte); 177 (* Shift the accumulator down by 8 bits and get ready for 178 the next byte. *) 179 do_move (newbyte >> 0w8) (byte+0w1) (len-8) 180 ) 181 else newbyte 182 end 183 in 184 (* TODO: If dest_bit is zero we can simply move the bytes. If len 185 is not a multiple of 8 we may have to return the low-order bits. *) 186 do_move last_bits 0w0 len 187 end 188 189in 190 structure BoolVector: MONO_VECTOR = 191 struct 192 type vector = vector 193 type elem = bool 194 val maxLen = maxLen 195 196 fun length(Vector(l, _)) = l 197 198 fun op sub (Vector(l, v), i: int): bool = 199 if i < 0 orelse i >= l then raise General.Subscript 200 else uncheckedSub(v, i) 201 202 (* Create a vector from a list. Must lock the vector before 203 returning it. *) 204 fun fromList (l : elem list) : vector = 205 let 206 val (length, vec) = fromList' l 207 in 208 RunCall.clearMutableBit vec; 209 Vector(length, vec) 210 end 211 212 fun tabulate (length: int, f : int->elem): vector = 213 let 214 val (length, vec) = tabulate' (length, f) 215 in 216 RunCall.clearMutableBit vec; 217 Vector(length, vec) 218 end 219 220(* fun map f (Vector(len, vec)) = 221 let 222 val new_vec = alloc len (* Destination vector. *) 223 fun mapbyte b i acc max = 224 if i = max then acc 225 else if f ((b andb i) <> 0w0) 226 then mapbyte b (i<<0w1) (acc orb i) max 227 else mapbyte b (i<<0w1) acc max 228 fun copy b l = 229 if l <= 0 then () 230 else let 231 val byte = System_loadb(vec, b) 232 val res = 233 (* Map each byte to get the result. Must not 234 apply the function beyond the last bit. *) 235 if l >= 8 then mapbyte byte 0w1 0w0 0wx100 236 else mapbyte byte 0w1 0w0 (0w1 << Word.fromInt l) 237 in 238 RunCall.storeByte(new_vec, b, res); 239 copy (b+0w1) (l-8) 240 end 241 in 242 copy 0w0 len; 243 RunCall.clearMutableBit new_vec; 244 Vector(len, new_vec) 245 end*) 246 247 fun mapi f (Vector(len, vec)) = 248 let 249 val new_vec = alloc len (* Destination vector. *) 250 fun mapbyte b i acc max l = 251 if i = max then acc 252 else if f (len-l, ((b andb i) <> 0w0)) 253 then mapbyte b (i<<0w1) (acc orb i) max (l-1) 254 else mapbyte b (i<<0w1) acc max (l-1) 255 fun copy b l = 256 if l <= 0 then () 257 else let 258 val byte = RunCall.loadByteFromImmutable(vec, b) 259 val res = 260 (* Map each byte to get the result. Must not 261 apply the function beyond the last bit. *) 262 if l >= 8 then mapbyte byte 0w1 0w0 0wx100 l 263 else mapbyte byte 0w1 0w0 (0w1 << Word.fromInt l) l 264 in 265 RunCall.storeByte(new_vec, b, res); 266 copy (b+0w1) (l-8) 267 end 268 in 269 copy 0w0 len; 270 RunCall.clearMutableBit new_vec; 271 Vector(len, new_vec) 272 end 273 274 (* To save duplicating almost the same code just define map in terms of mapi. *) 275 fun map f v = mapi (fn (_, x) => f x) v 276 277 (* Return a copy of the vector with a particular entry replaced *) 278 fun update (v as Vector(len, _), i, c) = 279 if i < 0 orelse i >= len 280 then raise Subscript 281 else mapi (fn (j, s) => if j = i then c else s) v 282 283 fun concat l = 284 let 285 (* Calculate the total length *) 286 fun total [] i = i 287 | total (Vector(len, _)::t) i = total t (i+len) 288 289 val total_len = total l 0 290 in 291 let 292 (* Allocate a new vector. *) 293 val new_vec = alloc total_len 294 (* Copy all the source vectors into the destination. *) 295 fun copy_list (Vector(src_len, src_vec)::t) dest_off bits = 296 let 297 val next = move_bits(src_vec, new_vec, 298 dest_off, src_len, bits) 299 in 300 copy_list t (dest_off+src_len) next 301 end 302 | copy_list [] dest_off bits = 303 (* At the end of the lists store any extra in the last byte. *) 304 if bits = 0w0 then () 305 else RunCall.storeByte(new_vec, intAsWord(Int.quot(dest_off, 8)), bits) 306 in 307 copy_list l 0 0w0; 308 RunCall.clearMutableBit new_vec; 309 Vector(total_len, new_vec) 310 end 311 end 312 313 (* Create the other functions. *) 314 structure VectorOps = 315 VectorOperations( 316 struct 317 type vector = vector and elem = elem 318 fun length(Vector(l, _)) = intAsWord l 319 fun unsafeSub (Vector(_, v), i) = uncheckedSub(v, wordAsInt i) 320 fun unsafeSet _ = raise Fail "Should not be called" 321 end); 322 323 open VectorOps; 324 325 326 local 327 (* Install the pretty printer for BoolVector.vector *) 328 fun pretty(depth: FixedInt.int) _ (x: vector) = 329 let 330 open PolyML 331 val last = length x - 1 332 fun put_elem (index, w, (l, d)) = 333 if d = 0 then ([PrettyString "...]"], d+1) 334 else if d < 0 then ([], d+1) 335 else 336 ( 337 PrettyString(if w then "true" else "false") :: 338 (if index <> last then PrettyString "," :: PrettyBreak(1, 0) :: l else l), 339 d+1 340 ) 341 in 342 PrettyBlock(3, false, [], 343 PrettyString "fromList[" :: 344 (if depth <= 0 then [PrettyString "...]"] 345 else #1 (foldri put_elem ([PrettyString "]"], depth - FixedInt.fromInt last) x) ) 346 ) 347 end 348 in 349 val () = PolyML.addPrettyPrinter pretty 350 end 351 352 end 353 354 structure BoolArray: MONO_ARRAY = 355 struct 356 type array = array 357 type elem = bool 358 type vector = vector 359 val maxLen = maxLen; 360 361 fun length(Array(l, _)) = l 362 363 (* Internal function for updating a bit assuming the bounds 364 checks have already been done. *) 365 fun uncheckedUpdate(v, i, new): unit = 366 let 367 val iW = Word.fromInt i 368 val byteOffsetW = iW >> 0w3 369 val byte = RunCall.loadByte(v, byteOffsetW); 370 val mask = 0w1 << (iW andb 0w7) 371 val newByte = 372 if new then byte orb mask 373 else byte andb (notb mask) 374 in 375 RunCall.storeByte(v, byteOffsetW, newByte) 376 end 377 378 fun array (len, ini) = 379 let 380 (* Create the uninitialised array. *) 381 val vec = alloc len 382 (* Set the bytes to all zeros or all ones. Generally this will set 383 more bits than we need but that doesn't matter. *) 384 val initByte = if ini then 0wxff else 0wx00 385 val bytes = (Word.fromInt len + 0w7) >> 0w3 386 (* TODO: This should be set by a built-in. *) 387 fun setBytes b = 388 if b >= bytes then () 389 else (RunCall.storeByte(vec, b, initByte); setBytes (b+0w1)) 390 val () = setBytes 0w0 391 in 392 Array(len, vec) 393 end 394 395 fun op sub (Array(l, v), i: int): elem = 396 if i < 0 orelse i >= l then raise General.Subscript 397 else uncheckedSub(v, i) 398 399 (* Exported update function. *) 400 fun update (Array (l, v), i: int, new) : unit = 401 if i < 0 orelse i >= l 402 then raise General.Subscript 403 else uncheckedUpdate(v, i, new) 404 405 (* Create an array from a list. *) 406 fun fromList (l : elem list) : array = Array(fromList' l) 407 408 fun tabulate (length: int , f : int->elem): array = 409 Array(tabulate'(length, f)) 410 411 fun vector(Array(len, vec)): vector = 412 (* TODO: We may be able to handle special cases where the 413 source and destination are aligned on the same bit offset. 414 For the moment just take the simple approach. *) 415 BoolVector.tabulate(len, fn j => uncheckedSub(vec, j)) 416 417 (* Copy one array into another. The arrays could be the same but in that case di must be zero. *) 418 fun copy {src=Array (slen, s), dst=Array (dlen, d), di: int} = 419 if di < 0 orelse di+slen > dlen 420 then raise General.Subscript 421 else (* TODO: Handle multiple bits where possible by using 422 move_bits or a variant. *) 423 let 424 fun copyBits n = 425 if n >= slen then () 426 else 427 (uncheckedUpdate(d, di+n, uncheckedSub(s, n)); 428 copyBits(n+1)) 429 in 430 copyBits 0 431 end 432 433(* fun copy {src as Array (slen, s), dst as Array (dlen, d), di: int} = 434 let 435 in 436 if di < 0 orelse di+slen > dlen 437 then raise General.Subscript 438 else if si < di 439 then (* Moving up - Start from the end *) 440 (* TODO: Handle multiple bits where possible by using 441 move_bits or a variant. *) 442 let 443 fun copyBits n = 444 if n < 0 then () 445 else 446 (uncheckedUpdate(d, di+n, uncheckedSub(s, si+n)); 447 copyBits(n-1)) 448 in 449 copyBits (slen-1) 450 end 451 else (* Moving down. *) 452 let 453 fun copyBits n = 454 if n >= slice_len then () 455 else 456 (uncheckedUpdate(d, di+n, uncheckedSub(s, si+n)); 457 copyBits(n+1)) 458 in 459 copyBits 0 460 end 461 end 462*) 463 (* Copy a vector into an array. *) 464 fun copyVec {src=Vector(slen, s), dst=Array (dlen, d), di: int} = 465 let 466 fun copyBits n = 467 if n >= slen then () 468 else 469 (uncheckedUpdate(d, di+n, uncheckedSub(s, n)); 470 copyBits(n+1)) 471 in 472 if di < 0 orelse di+slen > dlen 473 then raise General.Subscript 474 else copyBits 0 475 end 476 477 (* Create the other functions. *) 478 structure VectorOps = 479 VectorOperations( 480 struct 481 type vector = array and elem = elem 482 fun length(Array(l, _)) = intAsWord l 483 fun unsafeSub (Array(_, v), i) = uncheckedSub(v, wordAsInt i) 484 fun unsafeSet (Array(_, v), i, new) = uncheckedUpdate(v, wordAsInt i, new) 485 end); 486 487 open VectorOps; 488 489 local 490 (* Install the pretty printer for BoolArray.array *) 491 (* We may have to do this outside the structure if we 492 have opaque signature matching. *) 493 fun pretty(depth: FixedInt.int) _ (x: array) = 494 let 495 open PolyML 496 val last = length x - 1 497 fun put_elem (index, w, (l, d)) = 498 if d = 0 then ([PrettyString "...]"], d+1) 499 else if d < 0 then ([], d+1) 500 else 501 ( 502 PrettyString(if w then "true" else "false") :: 503 (if index <> last then PrettyString "," :: PrettyBreak(1, 0) :: l else l), 504 d+1 505 ) 506 in 507 PrettyBlock(3, false, [], 508 PrettyString "fromList[" :: 509 (if depth <= 0 then [PrettyString "...]"] 510 else #1 (foldri put_elem ([PrettyString "]"], depth - FixedInt.fromInt last) x) ) 511 ) 512 end 513 in 514 val () = PolyML.addPrettyPrinter pretty 515 end 516 end 517end; 518