├── .gitignore ├── .travis.yml ├── CHANGES.md ├── LICENSE.md ├── README.md ├── dune-project ├── fuzz ├── dune ├── fuzz.ml ├── fuzz_int63.ml ├── fuzz_int63.mli └── output │ └── crashes │ └── empty ├── optint.opam └── src ├── dune ├── int63_emul.ml ├── int63_emul.mli ├── int63_native.ml ├── int63_native.mli ├── integer_interface.ml ├── optint.ml ├── optint.mli ├── optint_emul.ml ├── optint_emul.mli ├── optint_native.ml └── optint_native.mli /.gitignore: -------------------------------------------------------------------------------- 1 | *.install 2 | _build 3 | _opam 4 | .merlin 5 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | install: 3 | - wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-opam.sh 4 | script: bash -ex .travis-opam.sh 5 | env: 6 | global: 7 | - PINS="optint.dev:." 8 | matrix: 9 | - PACKAGE="optint" OCAML_VERSION=4.08 TESTS=true 10 | - PACKAGE="optint" OCAML_VERSION=4.09 TESTS=true 11 | - PACKAGE="optint" OCAML_VERSION=4.10 TESTS=true 12 | - PACKAGE="optint" OCAML_VERSION=4.11 TESTS=true 13 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ### v0.3.0 2022-12-16 Paris (France) 2 | 3 | - Add infix operators for bitwise operations (@reynir, #23) 4 | - Add a deprecation about old infix operators 5 | They will be removed at the next minor release 6 | 7 | ### v0.2.0 2022-04-08 Paris (France) 8 | 9 | - Fix the README.md (@sidkshatriya, #19) 10 | - Fix fuzzers (@dinosaure, #20) 11 | - Add a proof to introspect the type of `Optint.t` (@dinosaure, #21) 12 | 13 | ### v0.1.0 2021-03-30 Paris (France) 14 | 15 | - Annotate integer types with `[@@immediate64]` (@CraigFe, #13) 16 | - Move unwrapped module `Int63` to `Optint.Int63` (@CraigFe, #13) 17 | 18 | ### v0.0.5 2021-02-22 Paris (France) 19 | 20 | - Update the README.md (@CraigFe, #9) 21 | - Add a representation of 63-bit integers (@CraigFe, #9) 22 | - Allow to compile fuzzers on 32-bit architectures (@dinosaure, #9) 23 | - Add encode / decode functions for integers (@CraigFe, #9) 24 | - Fix `optint` about sign and cast on all architectures (@dinosaure, #9) 25 | - **breaking changes**, rename and handle properly sign-bit: 26 | `{of,to}_int` become `{of,to}_unsigned_int` 27 | `{of,to}_int32` become `{of,to}_unsigned_int32` 28 | Previous functions handle sign-bit correctly 29 | 30 | ### v0.0.4 2020-03-09 Paris (France) 31 | 32 | - Fix 32bit backend where we miss to fully apply 33 | an `invalid_arg` 34 | - Fix 64bit backend where `Native.unsigned_compare` 35 | and `Nativeint.unsigned_div` exists (OCaml 4.08.0) 36 | 37 | ### v0.0.3 2010-09-12 Paris (France) 38 | 39 | - Avoid partial application of function (#2, @dinosaure) 40 | - Add `[@immediate]` tag (#4, @dinosaure) 41 | - Fix `select.ml` in 32bit (#5, @IndiscriminateCoding) 42 | - Fix typo (#6, @hannesm) 43 | - Add fuzzer (#8, @dinosaure) 44 | - Fix `lsr` and `asr` in 64bit (#8, @cfcs, @dinosaure) 45 | - Optimization on `of_int` function (64bit) (#8, @cfcs, @dinosaure) 46 | - Optimization on `abs` function (64bit) (#8, @cfcs, @dinosaure) 47 | - Fix 32bit architecture, keep bit-sign in the same place (#8, @dinosaure, review @cfcs) 48 | 49 | ### v0.0.2 2018-10-15 Paris (France) 50 | 51 | - _Dunify_ project 52 | - Fix dependencies on `dune` file when we select impl. (@rgrinberg) 53 | 54 | ### v0.0.1 2018-06-28 Paris (France) 55 | 56 | - First version of `optint` 57 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2018 Romain Calascibetta 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy of 6 | this software and associated documentation files (the "Software"), to deal in 7 | the Software without restriction, including without limitation the rights to 8 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of 9 | the Software, and to permit persons to whom the Software is furnished to do so, 10 | subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS 17 | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR 18 | COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER 19 | IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 20 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Optint - Efficient integer types on 64-bit architectures 2 | ======================================================== 3 | 4 | This library provides two new integer types, `Optint.t` and `Optint.Int63.t`, 5 | which guarantee efficient representation on 64-bit architectures and provide a 6 | best-effort boxed representation on 32-bit architectures. 7 | 8 | ## Goal 9 | 10 | The standard `Int32.t` and `Int64.t` types provided by the standard library have 11 | the same heap-allocated representation on all architectures. This consistent 12 | representation has costs in both memory and run-time performance. 13 | 14 | On 64-bit architectures, it's often more efficient to use the native `int` 15 | directly. 16 | This library provides types to do exactly this: 17 | 18 | - `Optint.t`: an integer containing _at least_ 32 bits. On 64-bit, this is an 19 | immediate integer; on 32-bit, it is a boxed 32-bit value. The overflow 20 | behaviour is platform-dependent. 21 | 22 | - `Optint.Int63.t`: an integer containing _exactly_ 63 bits. On 64-bit, this is 23 | an immediate integer; on 32-bit, it is a boxed 64-bit integer that is wrapped 24 | to provide 63-bit two's complement semantics. The two implementations are 25 | observationally equivalent, modulo use of `Marshal` and `Obj`. 26 | 27 | In summary: 28 | 29 | | Integer type | 32-bit representation | 64-bit representation | Semantics | 30 | | -- | -- | -- | -- | 31 | | `Stdlib.Int.t` | 31-bit immediate ✅ | 63-bit immediate ✅ | Always immediate | 32 | | `Stdlib.Nativeint.t` | 32-bit boxed ❌ | 64-bit boxed ❌ | Exactly word size | 33 | | `Stdlib.Int32.t` | 32-bit boxed ❌ | 32-bit boxed ❌ | Exactly 32 bits | 34 | | `Stdlib.Int64.t` | 64-bit boxed ❌ | 64-bit boxed ❌ | Exactly 64 bits | 35 | | `Optint.t` (_new_) | 32-bit boxed ❌ | 63-bit immediate ✅ | _At least_ 32 bits | 36 | | `Optint.Int63.t` (_new_) | 64-bit boxed ❌ | 63-bit immediate ✅ | Exactly 63 bits | 37 | 38 | These new types are safe and well-tested, but their architecture-dependent 39 | implementation makes them unsuitable for use with the `Marshal` module. Use the 40 | provided encode and decode functions instead. 41 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.0) 2 | (name optint) 3 | (version dev) 4 | -------------------------------------------------------------------------------- /fuzz/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name fuzz) 3 | (modules fuzz) 4 | (libraries fmt crowbar optint)) 5 | 6 | (alias 7 | (name runtest) 8 | (deps (:fuzz fuzz.exe)) 9 | (action (run %{fuzz}))) 10 | 11 | (executable 12 | (name fuzz_int63) 13 | (modules fuzz_int63) 14 | (libraries monolith optint)) 15 | 16 | (alias 17 | (name monolith) 18 | (deps (:fuzz fuzz_int63.exe)) 19 | (action (run %{fuzz}))) 20 | -------------------------------------------------------------------------------- /fuzz/fuzz.ml: -------------------------------------------------------------------------------- 1 | let max_intl = 0x3fffffff 2 | 3 | let () = 4 | Crowbar.add_test ~name:"identity with int32" Crowbar.[ int32 ] @@ fun i32 -> 5 | let v = Optint.of_int32 i32 in 6 | let u = Optint.to_int32 v in 7 | Crowbar.check_eq ~pp:Fmt.int32 ~eq:Int32.equal ~cmp:Int32.compare i32 u 8 | 9 | let () = 10 | Crowbar.add_test ~name:"identity with int" Crowbar.[ bool; range max_intl ] @@ fun s i -> 11 | let i = if s then - i else i in 12 | let v = Optint.of_int i in 13 | let u = Optint.to_int v in 14 | Crowbar.check_eq ~pp:Fmt.int ~eq:(=) ~cmp:compare i u 15 | 16 | let binary_operator = 17 | Crowbar.(choose [ const `Add 18 | ; const `Sub 19 | ; const `Mul 20 | ; const `Div 21 | ; const `Rem 22 | ; const `Lor 23 | ; const `Land 24 | ; const `Lxor ]) 25 | let unary_operator = 26 | Crowbar.(choose [ const `Neg 27 | ; const `Succ 28 | ; const `Pred 29 | ; const `Lnot ]) 30 | 31 | type binary = [ `Add | `Sub | `Mul | `Div | `Rem | `Lor | `Land | `Lxor ] 32 | type unary = [ `Neg | `Succ | `Pred | `Lnot ] 33 | 34 | let generate ~of_int = 35 | let edge = Crowbar.map Crowbar.[ bool; range max_intl ] @@ fun sign v -> match sign with 36 | | false -> `V (of_int v) 37 | | true -> `V (of_int (- v)) in 38 | 39 | let edge_binary = Crowbar.map [ edge; edge; binary_operator ] @@ fun a b o -> [ a; b; o ] in 40 | let node_binary = Crowbar.map [ edge; binary_operator ] @@ fun x o -> [ x; o ] in 41 | 42 | let edge_unary = Crowbar.map [ edge; unary_operator ] @@ fun x o -> [ x; o ] in 43 | let node_unary = Crowbar.map [ unary_operator ] @@ fun o -> [ o ] in 44 | 45 | let edge = Crowbar.map [ edge ] @@ fun x -> [ x ] in 46 | let edge = Crowbar.choose [ edge; edge_binary; edge_unary ] in 47 | let node = Crowbar.choose [ node_binary; node_unary ] in 48 | 49 | Crowbar.(map [ edge; list node ] @@ fun x r -> List.concat (x :: r)) 50 | 51 | module type ARITHMETIC = sig 52 | type t 53 | 54 | val add : t -> t -> t 55 | val sub : t -> t -> t 56 | val mul : t -> t -> t 57 | val div : t -> t -> t 58 | val rem : t -> t -> t 59 | val logor : t -> t -> t 60 | val logand : t -> t -> t 61 | val logxor : t -> t -> t 62 | 63 | val abs : t -> t 64 | val neg : t -> t 65 | val succ : t -> t 66 | val pred : t -> t 67 | val lognot : t -> t 68 | end 69 | 70 | type 'v p = [ binary | unary | `V of 'v ] 71 | 72 | let pp_p ~pp_v ppf = function 73 | | `Add -> Fmt.string ppf "+" | `Sub -> Fmt.string ppf "-" | `Mul -> Fmt.string ppf "*" | `Div -> Fmt.string ppf "/" | `Rem -> Fmt.string ppf "%" 74 | | `Lor -> Fmt.string ppf "|" | `Land -> Fmt.string ppf "&" | `Lxor -> Fmt.string ppf "^" 75 | | `Neg -> Fmt.string ppf "neg" | `Succ -> Fmt.string ppf "succ" | `Pred -> Fmt.string ppf "pred" 76 | | `Lnot -> Fmt.string ppf "~" 77 | | `V v -> pp_v ppf v 78 | 79 | let rec binary 80 | : type v. (module ARITHMETIC with type t = v) -> v -> v -> binary -> v p list -> v 81 | = fun (module Arith) a b o r -> 82 | let open Arith in 83 | 84 | match o with 85 | | `Add -> eval (module Arith) (`V (add a b) :: r) 86 | | `Sub -> eval (module Arith) (`V (sub a b) :: r) 87 | | `Mul -> eval (module Arith) (`V (mul a b) :: r) 88 | | `Div -> eval (module Arith) (`V (div a b) :: r) 89 | | `Rem -> eval (module Arith) (`V (rem a b) :: r) 90 | | `Lor -> eval (module Arith) (`V (logor a b) :: r) 91 | | `Land -> eval (module Arith) (`V (logand a b) :: r) 92 | | `Lxor -> eval (module Arith) (`V (logxor a b) :: r) 93 | 94 | and unary 95 | : type v. (module ARITHMETIC with type t = v) -> v -> unary -> v p list -> v 96 | = fun (module Arith) x o r -> 97 | let open Arith in 98 | 99 | match o with 100 | | `Neg -> eval (module Arith) (`V (neg x) :: r) 101 | | `Succ -> eval (module Arith) (`V (succ x) :: r) 102 | | `Pred -> eval (module Arith) (`V (pred x) :: r) 103 | | `Lnot -> eval (module Arith) (`V (lognot x) :: r) 104 | 105 | and eval 106 | : type v. (module ARITHMETIC with type t = v) -> v p list -> v 107 | = fun arith -> function 108 | | (`V a) :: (`V b) :: (#binary as o) :: r -> binary arith a b o r 109 | | (`V x) :: (#unary as o) :: r -> unary arith x o r 110 | | [ `V v ] -> v 111 | | _ -> Crowbar.bad_test () 112 | 113 | let () = 114 | Crowbar.add_test ~name:"computation" Crowbar.[ generate ~of_int:(fun x -> x) ] @@ fun l -> 115 | (* XXX(dinosaure): FIXME even if it's not used. *) 116 | if Sys.word_size = 32 117 | then 118 | let la = List.map 119 | (function `V x -> `V (Optint.of_int x) 120 | | (#binary | #unary) as x -> (x :> Optint.t p)) l in 121 | let lb = List.map 122 | (function `V x -> `V (Int32.of_int x) 123 | | (#binary | #unary) as x -> (x :> int32 p)) l in 124 | 125 | let a = try Some (eval (module Optint) la) with Division_by_zero -> None in 126 | let b = try Some (eval (module Int32) lb) with Division_by_zero -> None in 127 | match a, b with 128 | | None, None -> () 129 | | Some _, None | None, Some _ -> Crowbar.bad_test () 130 | | Some a, Some b -> 131 | if (b > 0x3fffffffl || b < -0x3fffffffl) then Crowbar.bad_test () ; 132 | let a = Optint.to_int a in 133 | let b = Int32.to_int b in 134 | 135 | Crowbar.check_eq ~pp:(Fmt.fmt "%x") ~eq:(=) ~cmp:compare a b 136 | -------------------------------------------------------------------------------- /fuzz/fuzz_int63.ml: -------------------------------------------------------------------------------- 1 | open Monolith 2 | 3 | let int = le Int.max_int 4 | 5 | let int32 = 6 | let gen_random = 7 | let open Int32 in 8 | let bits () = of_int (Gen.bits ()) in 9 | fun () -> logxor (bits ()) (shift_left (bits ()) 30) 10 | in 11 | let pos = easily_constructible gen_random PPrint.OCaml.int32 in 12 | let neg = deconstructible PPrint.OCaml.int32 in 13 | ifpol pos neg 14 | 15 | let float = deconstructible PPrint.OCaml.float 16 | let string = deconstructible PPrint.string 17 | 18 | module type INTEGER = module type of Optint.Int63.Boxed 19 | 20 | module Fuzz_integer_equivalence (Reference : INTEGER) (Candidate : INTEGER) = 21 | struct 22 | module R = Reference 23 | module C = Candidate 24 | 25 | let encoded_string : (string, string) spec = 26 | let check_valid r c = 27 | let exception Incorrect_length of string in 28 | let exception Different of string * string in 29 | if not (String.length c = R.encoded_size) then raise (Incorrect_length c); 30 | if not (String.equal r c) then raise (Different (r, c)) 31 | in 32 | declare_abstract_type 33 | ~check:(fun r -> (check_valid r, document (PPrint.string r))) 34 | () 35 | 36 | module Wrap = struct 37 | let pp f x = 38 | f Format.str_formatter x; 39 | Format.flush_str_formatter () 40 | 41 | let encode f x = 42 | let buf = Bytes.create R.encoded_size in 43 | f buf ~off:0 x; 44 | Bytes.unsafe_to_string buf 45 | 46 | let decode f s = f s ~off:0 47 | end 48 | 49 | let run t fuel = 50 | let endo = t ^> t in 51 | let binop = t ^> t ^> t in 52 | let binop_exn = t ^> t ^!> t in 53 | 54 | declare "zero" t R.zero C.zero; 55 | declare "one" t R.one C.one; 56 | declare "minus_one" t R.minus_one C.minus_one; 57 | declare "max_int" t R.max_int C.max_int; 58 | declare "min_int" t R.min_int C.min_int; 59 | 60 | declare "succ" endo R.succ C.succ; 61 | declare "pred" endo R.pred C.pred; 62 | declare "abs" endo R.abs C.abs; 63 | declare "neg" endo R.neg C.neg; 64 | declare "add" binop R.add C.add; 65 | declare "sub" binop R.sub C.sub; 66 | declare "mul" binop R.mul C.mul; 67 | declare "div" binop_exn R.div C.div; 68 | declare "rem" binop_exn R.rem C.rem; 69 | declare "logand" binop R.logand C.logand; 70 | declare "logor" binop R.logor C.logor; 71 | declare "logxor" binop R.logxor C.logxor; 72 | declare "lognot" endo R.lognot C.lognot; 73 | declare "shift_left" (t ^> int ^> t) R.shift_left C.shift_left; 74 | declare "shift_right" (t ^> int ^> t) R.shift_right C.shift_right; 75 | declare "shift_right_logical" 76 | (t ^> int ^> t) 77 | R.shift_right_logical C.shift_right_logical; 78 | 79 | declare "compare" (t ^> t ^> int) R.compare C.compare; 80 | declare "equal" (t ^> t ^> bool) R.equal C.equal; 81 | 82 | declare "of_int" (int ^> t) R.of_int C.of_int; 83 | declare "to_int" (t ^> int) R.to_int C.to_int; 84 | declare "of_int32" (int32 ^> t) R.of_int32 C.of_int32; 85 | declare "to_int32" (t ^> int32) R.to_int32 C.to_int32; 86 | declare "to_float" (t ^> float) R.to_float C.to_float; 87 | declare "to_string" (t ^> string) R.to_string C.to_string; 88 | 89 | declare "pp" (t ^> string) (Wrap.pp R.pp) (Wrap.pp C.pp); 90 | declare "encoded_size" int R.encoded_size C.encoded_size; 91 | declare "encode" (t ^> encoded_string) (Wrap.encode R.encode) 92 | (Wrap.encode C.encode); 93 | declare "decode" (encoded_string ^> t) (Wrap.decode R.decode) 94 | (Wrap.decode C.decode); 95 | 96 | main fuel 97 | end 98 | 99 | module Reference = Optint.Int63 100 | module Candidate = Optint.Int63.Boxed 101 | module Int63_equiv = Fuzz_integer_equivalence (Reference) (Candidate) 102 | 103 | let () = 104 | let t : (Reference.t, Candidate.t) spec = declare_abstract_type () in 105 | Int63_equiv.run t 5 106 | -------------------------------------------------------------------------------- /fuzz/fuzz_int63.mli: -------------------------------------------------------------------------------- 1 | (* Intentionally empty *) 2 | -------------------------------------------------------------------------------- /fuzz/output/crashes/empty: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mirage/optint/e054d3ad03519a2ce30fe800a07df0460cb1bf8a/fuzz/output/crashes/empty -------------------------------------------------------------------------------- /optint.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: [ "romain.calascibetta@gmail.com" ] 3 | authors: "Romain Calascibetta" 4 | license: "ISC" 5 | homepage: "https://github.com/mirage/optint" 6 | bug-reports: "https://github.com/mirage/optint/issues" 7 | dev-repo: "git+https://github.com/mirage/optint.git" 8 | doc: "https://mirage.github.io/optint/" 9 | synopsis: "Efficient integer types on 64-bit architectures" 10 | description: """ 11 | This library provides two new integer types, `Optint.t` and `Optint.Int63.t`, 12 | which guarantee efficient representation on 64-bit architectures and provide a 13 | best-effort boxed representation on 32-bit architectures. 14 | 15 | Implementation depends on target architecture. 16 | """ 17 | 18 | build: ["dune" "build" "-p" name "-j" jobs] 19 | run-test: [ "dune" "runtest" "-p" name "-j" jobs ] 20 | 21 | depends: [ 22 | "ocaml" {>= "4.07.0"} 23 | "dune" 24 | "crowbar" {with-test & >= "0.2"} 25 | "monolith" {with-test} 26 | "fmt" {with-test} 27 | ] 28 | x-maintenance-intent: [ "(latest)" ] 29 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name optint) 3 | (public_name optint)) 4 | -------------------------------------------------------------------------------- /src/int63_emul.ml: -------------------------------------------------------------------------------- 1 | (* On 32-bit systems, we emulate a 63-bit integer via a boxed 64-bit integer 2 | with its lowest bit set to 0. The remaining 63 bits are left-shifted by one 3 | place. This is analogous to the standard encoding of [int], with the bottom 4 | bit set to 0 rather than 1. 5 | 6 | See {{:https://github.com/janestreet/base/blob/master/src/int63_emul.ml}[Base.Int63_emul]} 7 | for a similar encoding that has subtly different guarantees. This 8 | implementation seeks to be strictly observationally equivalent to the 9 | unemulated one (on 64-bit architectures), at the cost of performance of 10 | certain functions. 11 | *) 12 | 13 | type t = int64 14 | 15 | (* The following all preserve semantics under our chosen encoding. *) 16 | include (Int64 : sig 17 | val add : t -> t -> t 18 | val sub : t -> t -> t 19 | val rem : t -> t -> t 20 | val neg : t -> t 21 | val abs : t -> t 22 | val logand : t -> t -> t 23 | val logor : t -> t -> t 24 | val shift_left : t -> int -> t 25 | val equal : t -> t -> bool 26 | val compare : t -> t -> int 27 | end) 28 | 29 | let invalid_arg fmt = Format.kasprintf invalid_arg fmt 30 | 31 | module Conv : sig 32 | val wrap_exn : int64 -> t (* Raises if the [int64] has its topmost bit set. *) 33 | val wrap_modulo : int64 -> t (* Discards the topmost bit of the [int64]. *) 34 | 35 | val unwrap : t -> int64 (* Lossless, assuming [t] satisfies the encoding. *) 36 | end = struct 37 | let int64_fits_on_int63 = 38 | let min = Int64.(shift_right min_int) 1 in 39 | let max = Int64.(shift_right max_int) 1 in 40 | fun x -> Int64.compare min x <= 0 && Int64.compare x max <= 0 41 | 42 | let wrap_modulo x = Int64.mul x 2L 43 | let wrap_exn x = 44 | if int64_fits_on_int63 x then 45 | Int64.mul x 2L 46 | else 47 | Printf.ksprintf failwith 48 | "Conversion from int64 to int63 failed: %Ld is out of range" x 49 | 50 | let unwrap x = Int64.shift_right x 1 51 | end 52 | 53 | let unset_bottom_bit = 54 | let mask = 0xffff_ffff_ffff_fffEL in 55 | fun x -> Int64.logand x mask 56 | 57 | let min_int = unset_bottom_bit Int64.min_int 58 | let max_int = unset_bottom_bit Int64.max_int 59 | let minus_one = Conv.wrap_exn (-1L) 60 | let zero = Conv.wrap_exn 0L 61 | let one = Conv.wrap_exn 1L 62 | 63 | let succ x = add x one 64 | let pred x = sub x one 65 | 66 | let mul x y = Int64.mul x (Conv.unwrap y) 67 | let div x y = 68 | let r = Int64.div x y in 69 | if Int64.equal r 0x4000_0000_0000_0000L then 70 | (* This case happens when we overflow via [ min_int / 1 ], in which case we 71 | should wrap back to [ min_int ]. *) 72 | min_int 73 | else 74 | Conv.wrap_modulo r 75 | 76 | let lognot x = unset_bottom_bit (Int64.lognot x) 77 | let logxor x y = unset_bottom_bit (Int64.logxor x y) 78 | let shift_right x i = unset_bottom_bit (Int64.shift_right x i) 79 | let shift_right_logical x i = unset_bottom_bit (Int64.shift_right_logical x i) 80 | 81 | let to_int x = Int64.to_int (Conv.unwrap x) 82 | let of_int x = Conv.wrap_exn (Int64.of_int x) 83 | let to_int32 x = Int64.to_int32 (Conv.unwrap x) 84 | let of_int32 x = Conv.wrap_exn (Int64.of_int32 x) 85 | let to_int64 x = Conv.unwrap x 86 | let of_int64 x = Conv.wrap_exn x 87 | let to_float x = Int64.to_float (Conv.unwrap x) 88 | let of_float x = Conv.wrap_exn (Int64.of_float x) 89 | 90 | let to_string x = Int64.to_string (Conv.unwrap x) 91 | let of_string x = Conv.wrap_exn (Int64.of_string x) 92 | let of_string_opt x = try Some (of_string x) with _ -> None 93 | 94 | let pp ppf x = Format.fprintf ppf "%Ld" (Conv.unwrap x) 95 | 96 | let to_unsigned_int x = 97 | let max_int = of_int Stdlib.max_int in 98 | if compare zero x <= 0 && compare x max_int <= 0 99 | then to_int x 100 | else invalid_arg "Int63.to_unsigned_int: %Lx can not fit into a 31 bits unsigned integer" x 101 | 102 | let without_bit_sign (x:int) = if x >= 0 then x else x land (lnot 0x40000000) 103 | 104 | let of_unsigned_int x = 105 | if x < 0 106 | then logor 0x40000000L (of_int (without_bit_sign x)) 107 | else of_int x 108 | 109 | let to_unsigned_int32 x = 110 | let max_int = of_int32 Int32.max_int in 111 | if compare zero x <= 0 && compare x max_int <= 0 112 | then to_int32 x 113 | else invalid_arg "Int63.to_unsigned_int32: %Lx can not fit into a 32 bits unsigned integer" x 114 | 115 | let of_unsigned_int32 x = 116 | if x < 0l 117 | then logor 0x80000000L (of_int32 (Int32.logand x (Int32.lognot 0x80000000l))) 118 | else of_int32 x 119 | 120 | let encoded_size = 8 121 | 122 | external set_64 : bytes -> int -> int64 -> unit = "%caml_bytes_set64u" 123 | external get_64 : string -> int -> int64 = "%caml_string_get64" 124 | external swap64 : int64 -> int64 = "%bswap_int64" 125 | 126 | let encode buf ~off t = 127 | let t = to_int64 t in 128 | let t = if not Sys.big_endian then swap64 t else t in 129 | set_64 buf off t 130 | 131 | let decode buf ~off = 132 | let t = get_64 buf off in 133 | let t = if not Sys.big_endian then swap64 t else t in 134 | of_int64 t 135 | 136 | module Infix = struct 137 | let ( + ) a b = add a b 138 | let ( - ) a b = sub a b 139 | let ( * ) a b = mul a b 140 | let ( % ) a b = rem a b 141 | let ( / ) a b = div a b 142 | let ( land ) a b = logand a b 143 | let ( lor ) a b = logor a b 144 | let ( lsr ) a b = shift_right a b 145 | let ( lsl ) a b = shift_left a b 146 | 147 | let ( && ) = ( land ) 148 | let ( || ) = ( lor ) 149 | let ( >> ) = ( lsr ) 150 | let ( << ) = ( lsl ) 151 | 152 | end 153 | -------------------------------------------------------------------------------- /src/int63_emul.mli: -------------------------------------------------------------------------------- 1 | include Integer_interface.S 2 | -------------------------------------------------------------------------------- /src/int63_native.ml: -------------------------------------------------------------------------------- 1 | type t = int 2 | 3 | let zero = 0 4 | let one = 1 5 | let minus_one = -1 6 | let neg x = -x 7 | let add a b = a + b 8 | let sub a b = a - b 9 | let mul a b = a * b 10 | let div a b = a / b 11 | let rem a b = a mod b 12 | let succ x = succ x 13 | let pred x = pred x 14 | let logand a b = a land b 15 | let logor a b = a lor b 16 | let logxor a b = a lxor b 17 | let lognot x = lnot x 18 | let shift_left a n = a lsl n 19 | let shift_right a n = a asr n 20 | let shift_right_logical a n = a lsr n 21 | let abs x = abs x 22 | let max_int = max_int 23 | let min_int = min_int 24 | 25 | external of_int : t -> t = "%identity" 26 | external to_int : t -> t = "%identity" 27 | 28 | let to_int32 = Stdlib.Int32.of_int 29 | let of_int32 = Stdlib.Int32.to_int 30 | let to_int64 = Stdlib.Int64.of_int 31 | let of_int64 = Stdlib.Int64.to_int 32 | let of_float x = int_of_float x 33 | let to_float x = float_of_int x 34 | let of_string x = int_of_string x 35 | let of_string_opt x = try Some (of_string x) with Failure _ -> None 36 | let to_string x = string_of_int x 37 | let equal : int -> int -> bool = fun a b -> a = b 38 | let compare : int -> int -> int = fun a b -> compare a b 39 | let pp = Format.pp_print_int 40 | 41 | external to_unsigned_int : t -> int = "%identity" 42 | external of_unsigned_int : int -> t = "%identity" 43 | 44 | let invalid_arg fmt = Format.kasprintf invalid_arg fmt 45 | 46 | let to_unsigned_int32 = 47 | let uint32_mask = (0xffff lsl 16) lor 0xffff in 48 | fun x -> 49 | let truncated = x land uint32_mask in 50 | if x <> truncated 51 | then invalid_arg "Int63.to_unsigned_int32: %d can not fit into a 32 bits integer" x 52 | else Int32.of_int truncated 53 | 54 | let of_unsigned_int32 = 55 | let int32_sign_mask = 1 lsl 31 in 56 | let int32_sign_maskl = 0x80000000l in 57 | fun x -> 58 | if x < 0l then 59 | let x = Int32.logand x (Int32.lognot int32_sign_maskl) in 60 | Int32.to_int x lor int32_sign_mask 61 | else Int32.to_int x 62 | 63 | let encoded_size = 8 64 | 65 | external set_64 : bytes -> int -> int64 -> unit = "%caml_bytes_set64u" 66 | external get_64 : string -> int -> int64 = "%caml_string_get64" 67 | external swap64 : int64 -> int64 = "%bswap_int64" 68 | 69 | let encode buf ~off t = 70 | let t = to_int64 t in 71 | let t = if not Sys.big_endian then swap64 t else t in 72 | set_64 buf off t 73 | 74 | let decode buf ~off = 75 | let t = get_64 buf off in 76 | let t = if not Sys.big_endian then swap64 t else t in 77 | of_int64 t 78 | 79 | module Infix = struct 80 | let ( + ) a b = add a b 81 | let ( - ) a b = sub a b 82 | let ( * ) a b = mul a b 83 | let ( % ) a b = rem a b 84 | let ( / ) a b = div a b 85 | let ( land ) a b = logand a b 86 | let ( lor ) a b = logor a b 87 | let ( lsr ) a b = shift_right a b 88 | let ( lsl ) a b = shift_left a b 89 | 90 | let ( && ) = ( land ) 91 | let ( || ) = ( lor ) 92 | let ( >> ) = ( lsr ) 93 | let ( << ) = ( lsl ) 94 | 95 | end 96 | -------------------------------------------------------------------------------- /src/int63_native.mli: -------------------------------------------------------------------------------- 1 | type t = int [@@immediate] 2 | 3 | include Integer_interface.S with type t := t 4 | -------------------------------------------------------------------------------- /src/integer_interface.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | type t 3 | 4 | val zero : t 5 | (** Integer 0. *) 6 | 7 | val one : t 8 | (** Integer 1. *) 9 | 10 | val minus_one : t 11 | (** Integer (-1). *) 12 | 13 | val neg : t -> t 14 | (** Unary negation. *) 15 | 16 | val add : t -> t -> t 17 | (** Addition. *) 18 | 19 | val sub : t -> t -> t 20 | (** Subtraction. *) 21 | 22 | val mul : t -> t -> t 23 | (** Mulitplication. *) 24 | 25 | val div : t -> t -> t 26 | (** Integer division. Raise [Division_by_zero] if the second argument is zero. 27 | This division rounds the real quotient of its arguments towrds zero. *) 28 | 29 | val rem : t -> t -> t 30 | (** Integer remainder. If [y] is not zero, the result of [rem x y] satisfies 31 | the following property: [x = add (mul (div x y) y) (rem x y)]. if [y = 0], 32 | [rem x y] raises [Division_by_zero]. *) 33 | 34 | val succ : t -> t 35 | (** Successor. [succ x] is [add x one]. *) 36 | 37 | val pred : t -> t 38 | (** Predecessor. [pred x] is [sub x one]. *) 39 | 40 | val abs : t -> t 41 | (** Return the absolute value its argument. *) 42 | 43 | val max_int : t 44 | (** The greatest representable integer. *) 45 | 46 | val min_int : t 47 | (** The smallest representable integer. *) 48 | 49 | val logand : t -> t -> t 50 | (** Bitwise logical and. *) 51 | 52 | val logor : t -> t -> t 53 | (** Bitwise logical or. *) 54 | 55 | val logxor : t -> t -> t 56 | (** Bitwise logical exclusive or. *) 57 | 58 | val lognot : t -> t 59 | (** Bitwise logical negation. *) 60 | 61 | val shift_left : t -> int -> t 62 | (** [shift_left x y] shifts [x] to the left by [y] bits. The result is 63 | unspecified if [y < 0] or [y >= (32 || 63)]. *) 64 | 65 | val shift_right : t -> int -> t 66 | (** [shift_right x y] shifts [x] to the right by [y] bits. This is an 67 | arithmetic shift: the sign bit of [x] is replicated and inserted in the 68 | vacated bits. The result is unspecified if [y < 0] or [y >= (32 || 63)]. *) 69 | 70 | val shift_right_logical : t -> int -> t 71 | (** [shift_right_logical x y] shifts [x] to the right by [y] bits. This is a 72 | logical shift: zeroes are inserted in the vacated bits regardless of the 73 | sign of [x] / The result is unspecified if [y < 0] or [y >= (32 || 63)]. *) 74 | 75 | val of_int : int -> t 76 | (** Convert the given integer (type [int] ) to {!t}. It's an unsafe function 77 | whose semantic is different from architecture. *) 78 | 79 | val to_int : t -> int 80 | (** Convert the given {!t} integer to an integer (type [int] ). On 64-bit 81 | platforms, the conversion is exact. On 32-bit platforms, the 32-bit 82 | integer is taken modulo 2 {^ 31}, i.e. the high-order bit is lost during 83 | the conversion. *) 84 | 85 | val of_int32 : int32 -> t 86 | (** Convert the given 32-bit integer (type [int32]) to {!t} integer. It's an 87 | unsafe function whose semantic is different from architecture. *) 88 | 89 | val to_int32 : t -> int32 90 | (** Convert the given {!t} integer to a 32-bit integer. *) 91 | 92 | val of_int64 : int64 -> t 93 | (** Convert the given 64-bit integer (type [int64]) to {!t} integer. *) 94 | 95 | val to_int64 : t -> int64 96 | (** Covert the given {!t} integer to a 64-bit integer. *) 97 | 98 | val of_float : float -> t 99 | (** Convert the given floating-point number to a {!t} integer, discarding the 100 | fractional part (truncate towards 0). The result of the conversion is 101 | undefined if, after truncation, the number is outside the range 102 | {!min_int}, {!max_int}. *) 103 | 104 | val to_float : t -> float 105 | (** Convert the given {!t} integer to a floating-point number. *) 106 | 107 | val of_string : string -> t 108 | (** Convert the given string to a {!t} integer. The string is read in decimal 109 | (by default, or if the string begins with [0u]) or in hexadecimal, octal 110 | or binary if the string begins with [0x], [0o] or [0b] respectively. 111 | 112 | The [0u] prefix reads the input as an unsigned integer in the range 113 | [\[0, 2 * max_int + 1\]]. If the input exceeds {!max_int} it is converted 114 | to the signed integer [min_int + input - max_int - 1]. 115 | 116 | The [_] (underscore) character can appear anywhere in the string is 117 | ignored. Raise [Failure _] if the given string is not a valid 118 | representation of an integer, or if the integer represented exceeds the 119 | range of integer, or if the integer represented exceeds the range of 120 | integers representable in type {!t}. *) 121 | 122 | val of_string_opt : string -> t option 123 | (** Same as [of_string], but return [None] instead of raising. *) 124 | 125 | val to_string : t -> string 126 | (** Return the string representation of its argument, in decimal. *) 127 | 128 | val compare : t -> t -> int 129 | (** The comparison function for {!t} integers, with the same specification as 130 | {!Stdlib.compare}. Along with the type [t], this function [compare] allows 131 | the module [Optint] to be passed as argument to the functors {!Set.Make} 132 | and {!Map.Make}. *) 133 | 134 | val equal : t -> t -> bool 135 | (** The equal function for {!t}. *) 136 | 137 | val pp : Format.formatter -> t -> unit 138 | (** The pretty-printer for {!t}. *) 139 | 140 | (** {2 Encoding functions} 141 | 142 | Efficient fixed-length big-endian encoding functions for {!t} integers: *) 143 | 144 | val encode : bytes -> off:int -> t -> unit 145 | val decode : string -> off:int -> t 146 | 147 | val encoded_size : int 148 | (** The number of bytes in the {{!encode} encoded} form of {!t}. *) 149 | 150 | val to_unsigned_int32 : t -> int32 151 | val of_unsigned_int32 : int32 -> t 152 | val to_unsigned_int : t -> int 153 | val of_unsigned_int : int -> t 154 | 155 | module Infix : sig 156 | val ( + ) : t -> t -> t 157 | val ( - ) : t -> t -> t 158 | val ( * ) : t -> t -> t 159 | val ( % ) : t -> t -> t 160 | val ( / ) : t -> t -> t 161 | val ( land ) : t -> t -> t 162 | val ( lor ) : t -> t -> t 163 | val ( lsr ) : t -> int -> t 164 | val ( lsl ) : t -> int -> t 165 | 166 | val ( && ) : t -> t -> t 167 | [@@ocaml.deprecated "Please use ( land )."] 168 | val ( || ) : t -> t -> t 169 | [@@ocaml.deprecated "Please use ( lor )."] 170 | val ( >> ) : t -> int -> t 171 | [@@ocaml.deprecated "Please use ( lsr )."] 172 | val ( << ) : t -> int -> t 173 | [@@ocaml.deprecated "Please use ( lsl )."] 174 | end 175 | end 176 | -------------------------------------------------------------------------------- /src/optint.ml: -------------------------------------------------------------------------------- 1 | (** Extraction of [Stdlib.Sys.Immediate64] for pre-4.10 compatibility. 2 | [Immediate64] was originally authored by Jeremie Dimino , 3 | and is licensed along with the OCaml compiler system under LGPLv2. See the 4 | {{:https://github.com/ocaml/ocaml/blob/trunk/LICENSE} compiler license} for 5 | details. 6 | 7 | For soundness of the [@@immediate64] annotation, we ensure to use the boxed 8 | representation only when not on 64-bit platforms, but we need to use The 9 | Force to convince the type system of this fact. *) 10 | module Immediate64 = struct 11 | module type Non_immediate = sig 12 | type t 13 | end 14 | 15 | module type Immediate = sig 16 | type t [@@immediate] 17 | end 18 | 19 | module Make (Immediate : Immediate) (Non_immediate : Non_immediate) = struct 20 | type t [@@immediate64] 21 | 22 | type 'a repr = 23 | | Immediate : Immediate.t repr 24 | | Non_immediate : Non_immediate.t repr 25 | 26 | external magic : _ repr -> t repr = "%identity" 27 | 28 | let repr = 29 | if Sys.word_size = 64 then magic Immediate else magic Non_immediate 30 | end 31 | end 32 | 33 | module Conditional = struct 34 | type ('t, 'u, 'v) t = 35 | | True : ('t, 't, _) t (** therefore ['t] = ['u] *) 36 | | False : ('t, _, 't) t (** therefore ['t] = ['v] *) 37 | end 38 | 39 | module Optint = struct 40 | include Immediate64.Make (Optint_native) (Optint_emul) 41 | 42 | module type S = Integer_interface.S with type t := t 43 | 44 | let impl : (module S) = 45 | match repr with 46 | | Immediate -> (module Optint_native : S) 47 | | Non_immediate -> (module Optint_emul : S) 48 | 49 | include (val impl : S) 50 | 51 | let is_immediate : (t, int, int32) Conditional.t = 52 | match repr with 53 | | Immediate -> True 54 | | Non_immediate -> False 55 | end 56 | 57 | module Int63 = struct 58 | include Immediate64.Make (Int63_native) (Int63_emul) 59 | 60 | module type S = Integer_interface.S with type t := t 61 | 62 | let impl : (module S) = 63 | match repr with 64 | | Immediate -> (module Int63_native : S) 65 | | Non_immediate -> (module Int63_emul : S) 66 | 67 | include (val impl : S) 68 | 69 | module Boxed = Int63_emul 70 | 71 | let is_immediate : (t, int, Boxed.t) Conditional.t = 72 | match repr with 73 | | Immediate -> True 74 | | Non_immediate -> False 75 | end 76 | 77 | include Optint 78 | -------------------------------------------------------------------------------- /src/optint.mli: -------------------------------------------------------------------------------- 1 | type t [@@immediate64] 2 | (** The type of integers with {i at least} 32 bits. 3 | For 63-bit integers, see {!Int63}. *) 4 | 5 | include Integer_interface.S with type t := t 6 | (** @inline *) 7 | 8 | (** {1 Other modules} *) 9 | 10 | (** A conditional type equality, used for revealing that a type [t] has one of 11 | two possible implementation types [u] and [v]. *) 12 | module Conditional : sig 13 | type ('t, 'u, 'v) t = 14 | | True : ('t, 't, _) t (** therefore ['t] = ['u] *) 15 | | False : ('t, _, 't) t (** therefore ['t] = ['v] *) 16 | end 17 | 18 | val is_immediate : (t, int, int32) Conditional.t 19 | 20 | (** 63-bit integers. *) 21 | module Int63 : sig 22 | type t [@@immediate64] 23 | (** The type of integers with exactly 63-bits. *) 24 | 25 | include Integer_interface.S with type t := t 26 | (** @inline *) 27 | 28 | module Boxed : Integer_interface.S 29 | (** An implementation of 63-bit integers that always uses a boxed 30 | representation regardless of word size. *) 31 | 32 | (** [is_immediate] reveals the implementation of {!t} on the current 33 | platform, and can be used to build [Int63] operations that behave 34 | differently depending on the underlying representation, such as FFIs. *) 35 | val is_immediate : (t, int, Boxed.t) Conditional.t 36 | end 37 | -------------------------------------------------------------------------------- /src/optint_emul.ml: -------------------------------------------------------------------------------- 1 | include Int32 2 | 3 | external of_int32 : int32 -> t = "%identity" 4 | external of_unsigned_int32 : int32 -> t = "%identity" 5 | external to_int32 : t -> int32 = "%identity" 6 | external to_unsigned_int32 : t -> int32 = "%identity" 7 | 8 | let to_int64 = Int64.of_int32 9 | let of_int64 = Int64.to_int32 10 | 11 | let pp ppf (x:t) = Format.fprintf ppf "%ld" x 12 | 13 | let without_bit_sign (x:int) = if x >= 0 then x else x land (lnot 0x40000000) 14 | 15 | let invalid_arg fmt = Format.kasprintf invalid_arg fmt 16 | 17 | (* XXX(dinosaure): the diff between [to_int] and [to_unsigned_int] 18 | * is about the sign-bit [0x40000000][int]/[0x80000000][int32]. 19 | * 20 | * For [to_int], we ensure for a negative number that we use only 21 | * [0x3fffffff][int32] bits two most significant bits are set to [1]. 22 | * In that case, it safes to cast the [int32] to and [int] (31 bits). 23 | * 24 | * For [to_unsigned_int], we don't want to interpret if the value is 25 | * negative or positive. However, if the number can be interpreted as a 26 | * negative nnumber, due to the two's complement layout, we are sure 27 | * to lost, at least, the most significant bit which is a part of unsigned 28 | * [int32]. So we are able to only accept "positive" numbers. 29 | * 30 | * NOTE: we trust on the two's complement! *) 31 | 32 | let to_int x = 33 | let max_int = of_int Stdlib.max_int in 34 | if compare zero x <= 0 && compare x max_int <= 0 35 | then to_int x (* XXX(dinosaure): positive and can fit into a 31-bit integer. *) 36 | else if compare zero x > 0 && Int32.logand 0xC0000000l x = 0xC0000000l 37 | then let x = Int32.logand x 0x7fffffffl in to_int x 38 | else invalid_arg "Optint.to_int: %lx can not fit into a 31 bits integer" x 39 | 40 | let to_unsigned_int x = 41 | let max_int = of_int Stdlib.max_int in 42 | if compare zero x <= 0 && compare x max_int <= 0 43 | then to_int x 44 | else invalid_arg "Optint.to_unsigned_int: %lx can not fit into a 31 bits unsigned integer" x 45 | 46 | let of_int x = 47 | if x < 0 48 | then logor 0xC0000000l (of_int (without_bit_sign x)) 49 | else of_int x 50 | 51 | let of_unsigned_int x = 52 | if x < 0 53 | then logor 0x40000000l (of_int (without_bit_sign x)) 54 | else of_int x 55 | 56 | let encoded_size = 4 57 | 58 | external set_32 : bytes -> int -> int32 -> unit = "%caml_bytes_set32u" 59 | external get_32 : string -> int -> int32 = "%caml_string_get32" 60 | external swap32 : int32 -> int32 = "%bswap_int32" 61 | 62 | let encode buf ~off t = 63 | let t = to_int32 t in 64 | let t = if not Sys.big_endian then swap32 t else t in 65 | set_32 buf off t 66 | 67 | let decode buf ~off = 68 | let t = get_32 buf off in 69 | let t = if not Sys.big_endian then swap32 t else t in 70 | of_int32 t 71 | 72 | module Infix = struct 73 | let ( + ) a b = add a b 74 | let ( - ) a b = sub a b 75 | let ( * ) a b = mul a b 76 | let ( % ) a b = rem a b 77 | let ( / ) a b = div a b 78 | 79 | let ( land ) a b = logand a b 80 | let ( lor ) a b = logor a b 81 | let ( lsr ) a b = shift_right a b 82 | let ( lsl ) a b = shift_left a b 83 | 84 | let ( && ) = ( land ) 85 | let ( || ) = ( lor ) 86 | let ( >> ) = ( lsr ) 87 | let ( << ) = ( lsl ) 88 | 89 | end 90 | -------------------------------------------------------------------------------- /src/optint_emul.mli: -------------------------------------------------------------------------------- 1 | include Integer_interface.S with type t = int32 2 | -------------------------------------------------------------------------------- /src/optint_native.ml: -------------------------------------------------------------------------------- 1 | type t = int 2 | 3 | let zero = 0 4 | let one = 1 5 | let minus_one = (-1) 6 | let neg x = (-x) 7 | let add a b = a + b 8 | let sub a b = a - b 9 | let mul a b = a * b 10 | 11 | let _unsigned_compare n m = 12 | let open Nativeint in 13 | compare (sub n min_int) (sub m min_int) 14 | 15 | let _unsigned_div n d = 16 | let open Nativeint in 17 | if d < zero then 18 | if _unsigned_compare n d < 0 then zero else one 19 | else 20 | let q = shift_left (div (shift_right_logical n 1) d) 1 in 21 | let r = sub n (mul q d) in 22 | if _unsigned_compare r d >= 0 then succ q else q 23 | 24 | let div a b = Nativeint.to_int (_unsigned_div (Nativeint.of_int a) (Nativeint.of_int b)) 25 | let rem a b = a mod b 26 | let succ x = x + 1 27 | let pred x = x - 1 28 | let abs x = 29 | let mask = x asr Sys.int_size in (* extract sign: -1 if signed, 0 if not signed *) 30 | (x + mask) lxor mask 31 | let max_int = Int32.(to_int max_int) 32 | let min_int = Int32.(to_int min_int) 33 | let logand a b = a land b 34 | let logor a b = a lor b 35 | let logxor a b = a lxor b 36 | let lognot x = lnot x 37 | let shift_left a n = a lsl n 38 | let shift_right a n = a asr n 39 | let shift_right_logical a n = a lsr n 40 | external of_int : int -> t = "%identity" 41 | external of_unsigned_int : int -> t = "%identity" 42 | external to_int : t -> int = "%identity" 43 | external to_unsigned_int : t -> int = "%identity" 44 | let to_int64 = Stdlib.Int64.of_int 45 | let of_int64 = Stdlib.Int64.to_int 46 | let of_float x = int_of_float x 47 | let to_float x = (* allocation *) float_of_int x 48 | let of_string x = int_of_string x 49 | let of_string_opt x = try (* allocation *) Some (of_string x) with Failure _ -> None 50 | let to_string x = string_of_int x 51 | let compare : int -> int -> int = fun a b -> a - b 52 | let equal : int -> int -> bool = fun a b -> a = b 53 | 54 | let invalid_arg fmt = Format.kasprintf invalid_arg fmt 55 | 56 | let uint32_max = (0xffff lsl 16) lor 0xffff 57 | let int32_sign_maskl = 0x80000000l 58 | let int32_sign_mask = 1 lsl 31 59 | let int32_maxl = 0x7fffffffl 60 | let int32_max = 0x7fffffff 61 | 62 | let to_int32 x = 63 | let truncated = x land uint32_max in 64 | if x = truncated then Int32.of_int truncated 65 | else if compare 0 x > 0 && (x lsr 31) = uint32_max 66 | then Int32.(logor int32_sign_maskl (of_int (x land int32_max))) 67 | else invalid_arg "Optint.to_int32: %d can not fit into a 32 bits integer" x 68 | 69 | let to_unsigned_int32 x = 70 | let truncated = x land uint32_max in 71 | if x <> truncated 72 | then invalid_arg "Optint.to_unsigned_int32: %d can not fit into a 32 bits integer" x 73 | else Int32.of_int truncated 74 | 75 | let of_int32 = 76 | let negative_int32_mask = (int32_max lsl 32) lor int32_sign_mask in 77 | fun x -> 78 | if x < 0l 79 | then 80 | let x = Int32.logand x int32_maxl in 81 | negative_int32_mask lor (Int32.to_int x) 82 | else Int32.to_int x 83 | 84 | let of_unsigned_int32 x = 85 | if x < 0l 86 | then 87 | let x = Int32.logand x (Int32.lognot int32_sign_maskl) in 88 | (Int32.to_int x) lor int32_sign_mask 89 | else Int32.to_int x 90 | 91 | let pp ppf (x:t) = Format.fprintf ppf "%d" x 92 | 93 | let encoded_size = 4 94 | 95 | external set_32 : bytes -> int -> int32 -> unit = "%caml_bytes_set32u" 96 | external get_32 : string -> int -> int32 = "%caml_string_get32" 97 | external swap32 : int32 -> int32 = "%bswap_int32" 98 | 99 | let encode buf ~off t = 100 | let t = to_int32 t in 101 | let t = if not Sys.big_endian then swap32 t else t in 102 | set_32 buf off t 103 | 104 | let decode buf ~off = 105 | let t = get_32 buf off in 106 | let t = if not Sys.big_endian then swap32 t else t in 107 | of_int32 t 108 | 109 | module Infix = struct 110 | let ( + ) a b = add a b 111 | let ( - ) a b = sub a b 112 | let ( * ) a b = mul a b 113 | let ( % ) a b = rem a b 114 | let ( / ) a b = div a b 115 | 116 | let ( land ) a b = logand a b 117 | let ( lor ) a b = logor a b 118 | let ( lsr ) a b = shift_right a b 119 | let ( lsl ) a b = shift_left a b 120 | 121 | let ( && ) = ( land ) 122 | let ( || ) = ( lor ) 123 | let ( >> ) = ( lsr ) 124 | let ( << ) = ( lsl ) 125 | 126 | end 127 | -------------------------------------------------------------------------------- /src/optint_native.mli: -------------------------------------------------------------------------------- 1 | type t = int [@@immediate] 2 | 3 | include Integer_interface.S with type t := t 4 | --------------------------------------------------------------------------------