Commits

da...@grayskies.net  committed 01c93f2

initial import

  • Participants

Comments (0)

Files changed (4)

+.cmx
+.o
+.a
+.swp
+.cmi
+aio
+module Decimal = struct
+  type t 
+
+  external of_string : string -> t = "caml_gmp_mpz_set_str"
+  external of_int    : int -> t = "caml_gmp_mpz_set_d"
+  external to_string : t -> string = "caml_gmp_mpz_get_str"
+  external add       : t -> t -> t = "caml_gmp_mpz_add"
+  external sub       : t -> t -> t = "caml_gmp_mpz_sub"
+  external mul       : t -> t -> t = "caml_gmp_mpz_mul"
+  external div       : t -> t -> t = "caml_gmp_mpz_div"
+  external pow       : t -> t -> t = "caml_gmp_mpz_pow"
+  external neg       : t -> t = "caml_gmp_mpz_neg"
+  external abs       : t -> t = "caml_gmp_mpz_abs"
+  external compare   : t -> t -> int = "caml_gmp_mpz_cmp"
+
+  let zero = of_int 0
+  let one  = of_int 1
+
+  module Infix = struct
+    let ( + ) = add
+    let ( - ) = sub
+    let ( * ) = mul
+    let ( / ) = div
+    let ( ** ) = pow
+  end
+end
+
+module Rational = struct
+  type t
+
+  module Pool = struct
+    external current_size : unit -> int = "caml_gmp_mpq_current_pool_size"
+  end
+
+  (* CR dpowers: only good for ints and fractional form *)
+  external of_rational_string : string -> t = "caml_gmp_mpq_set_str"
+  external of_parts           : Decimal.t -> Decimal.t -> t = "caml_gmp_mpq_of_parts"
+  external to_string          : t -> string = "caml_gmp_mpq_get_str"
+  external to_float_string    : t -> string = "caml_gmp_to_float_string"
+  external add                : t -> t -> t = "caml_gmp_mpq_add"
+  external sub                : t -> t -> t = "caml_gmp_mpq_sub"
+  external mul                : t -> t -> t = "caml_gmp_mpq_mul"
+  external div                : t -> t -> t = "caml_gmp_mpq_div"
+  external neg                : t -> t = "caml_gmp_mpq_neg"
+  external abs                : t -> t = "caml_gmp_mpq_abs"
+  external inv                : t -> t = "caml_gmp_mpq_abs"
+  external compare            : t -> t -> int = "caml_gmp_mpq_cmp"
+  external equal              : t -> t -> bool = "caml_gmp_mpq_equal"
+
+  let zero = of_rational_string "0"
+  let one  = of_rational_string "1"
+
+  module Infix = struct
+    let ( +. ) = add
+    let ( -. ) = sub
+    let ( *. ) = mul
+    let ( /. ) = div
+  end
+
+  (* CR dpowers: check for / and make it more robust in general *)
+  let of_string s =
+    Printf.printf "a\n%!";
+    let decimal_position = 
+      try
+        Some (String.index s '.')
+      with
+      | Not_found -> None
+    in
+    Printf.printf "b\n%!";
+    let int_portion = 
+      match decimal_position with
+      | None -> Decimal.of_string s
+      | Some i -> Decimal.of_string (String.sub s 0 i)
+    in
+    Printf.printf "%s\n%!" (Decimal.to_string int_portion);
+    Printf.printf "c\n%!";
+    let frac_length, frac_portion =
+      match decimal_position with
+      | None -> 0, Decimal.zero
+      | Some i -> 
+          let frac_length = (String.length s) - (i + 1) in
+          (frac_length, 
+           Decimal.of_string (String.sub s (i + 1) frac_length))
+    in
+    Printf.printf "d\n%!";
+    let den = 
+      if frac_length = 0 then Decimal.one
+      else Decimal.pow (Decimal.of_int 10) (Decimal.of_int frac_length) in
+    let num = Decimal.add (Decimal.mul int_portion den) frac_portion in
+    Printf.printf "%s/%s\n%!" (Decimal.to_string num) (Decimal.to_string den);
+    of_parts num den
+end
+
+open Rational
+open Infix
+let () =
+  begin
+    let one_third = of_rational_string "1/3" in
+    let v = ref zero in
+    for i = 1 to 10_000_000 do
+      v := !v +. one *. one_third
+    done;
+    Printf.printf "%s\n" (to_float_string !v)
+  end
+  (*begin
+    let one_third = 1.0 /. 3.0 in
+    let v = ref 0.0 in
+    for i = 1 to 10_000_000 do
+      v := !v +. 1.0 *. one_third
+    done;
+    Printf.printf "%.20g\n" !v
+  end*)

File gmp_mpq_stubs.c

+#include <stdio.h>
+#include <string.h>
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/custom.h>
+#include <caml/fail.h>
+#include <caml/callback.h>
+
+#include <gmp.h>
+
+#define Mpz_val(v) (*(mpz_t **) Data_custom_val(v))
+#define Mpq_val(v) (*(mpq_t **) Data_custom_val(v))
+
+/* create a memory pool of mpq values because initializing them is expensive */
+const float gmp_mpq_pool_threshold = 0.8;
+int gmp_mpq_pool_size = 0;
+int gmp_mpq_pool_next_free = 0;
+mpq_t **gmp_mpq_pool = NULL;
+
+mpq_t *gmp_mpq_pool_malloc()
+{
+  mpq_t *ret;
+
+  if (gmp_mpq_pool_next_free != gmp_mpq_pool_size) {
+    ret = gmp_mpq_pool[gmp_mpq_pool_next_free];
+    gmp_mpq_pool_next_free++;
+    return (ret);
+  }
+  else {
+    if (gmp_mpq_pool_size == 0) 
+      gmp_mpq_pool_size = 1;
+    else 
+      gmp_mpq_pool_size = gmp_mpq_pool_size * 2;
+    gmp_mpq_pool = reallocf(gmp_mpq_pool, sizeof(mpq_t *) * gmp_mpq_pool_size);
+    for (int i = gmp_mpq_pool_next_free; i < gmp_mpq_pool_size; i++) {
+      gmp_mpq_pool[i] = malloc(sizeof(mpq_t));
+      mpq_init(*(gmp_mpq_pool[i]));
+    };
+    return (gmp_mpq_pool_malloc());
+  }
+}
+
+void gmp_mpq_pool_free(mpq_t *v)
+{
+  int new_pool_size = gmp_mpq_pool_size - (gmp_mpq_pool_size * gmp_mpq_pool_threshold);
+
+  gmp_mpq_pool_next_free--;
+  gmp_mpq_pool[gmp_mpq_pool_next_free] = v;
+
+  if (gmp_mpq_pool_next_free < new_pool_size) {
+    for (int i = new_pool_size; i < gmp_mpq_pool_size; i++) {
+      mpq_clear(*gmp_mpq_pool[i]);
+      free(gmp_mpq_pool[i]);
+    };
+    gmp_mpq_pool_size = new_pool_size;
+    gmp_mpq_pool = reallocf(gmp_mpq_pool, (sizeof(mpq_t *) * new_pool_size));
+  }
+}
+
+value caml_gmp_mpq_current_pool_size(value unit)
+{
+  CAMLparam1(unit);
+
+  CAMLlocal1(ret);
+  ret = caml_copy_double(gmp_mpq_pool_size);
+  CAMLreturn(ret);
+}
+
+void caml_gmp_mpq_clear(value t)
+{
+  mpq_t *val = Mpq_val(t);
+
+  gmp_mpq_pool_free (val);
+}
+
+int caml_gmp_mpq_cmp_raw(value t1, value t2)
+{
+  return (mpq_cmp (*(Mpq_val(t1)), *(Mpq_val(t2))));
+}
+
+long caml_gmp_mpq_hash(value t)
+{
+  mpq_t *v = Mpq_val(t);
+  mpz_t i;
+  long res;
+
+  mpz_init (i);
+  mpz_add (i, mpq_numref(*v), mpq_denref(*v));
+  mpz_get_si (i);
+  mpz_clear (i);
+  return (res);
+}
+
+static struct custom_operations caml_gmp_mpq_custom_ops = {
+  "caml_gmp_mpq",
+  caml_gmp_mpq_clear,
+  caml_gmp_mpq_cmp_raw,
+  caml_gmp_mpq_hash,
+  /* CR dpowers: allow marshal to work on this type someday */
+  custom_serialize_default,
+  custom_deserialize_default
+};
+
+value caml_gmp_mpq_init(value unit)
+{
+  CAMLparam1 (unit);
+  mpq_t *val = gmp_mpq_pool_malloc();
+
+  CAMLlocal1(t);
+  t = caml_alloc_custom(&caml_gmp_mpq_custom_ops, sizeof(val), 0, 1);
+  Mpq_val(t) = val;
+
+  CAMLreturn(t);
+}
+
+value caml_gmp_mpq_cmp(value t1, value t2)
+{
+  CAMLparam2(t1, t2);
+
+  CAMLlocal1(ret);
+  ret = Val_int(caml_gmp_mpq_cmp_raw(t1, t2));
+  CAMLreturn(ret);
+}
+
+value caml_gmp_mpq_equal(value t1, value t2)
+{
+  CAMLparam2(t1, t2);
+
+  CAMLlocal1(ret);
+  ret = Val_bool(mpq_equal(*(Mpq_val(t1)), *(Mpq_val(t2))));
+  CAMLreturn(ret);
+}
+
+value caml_gmp_mpq_set_str(value str_val)
+{
+  CAMLparam1(str_val);
+
+  value t = caml_gmp_mpq_init(Val_unit);
+  mpq_set_str(*(Mpq_val(t)), String_val(str_val), 10);
+  mpq_canonicalize(*(Mpq_val(t)));
+  CAMLreturn(t);
+}
+
+value caml_gmp_mpq_get_str(value t)
+{
+  CAMLparam1(t);
+
+  CAMLlocal1(ret);
+  char *str;
+
+  str = mpq_get_str (NULL, 10, *(Mpq_val(t)));
+  ret = caml_copy_string (str);
+  free (str);
+  CAMLreturn(ret);
+}
+
+value caml_gmp_mpq_add(value t1, value t2)
+{
+  CAMLparam2(t1, t2);
+
+  value ret = caml_gmp_mpq_init (Val_unit);
+  mpq_add (*(Mpq_val(ret)), *(Mpq_val(t1)), *(Mpq_val(t2)));
+  CAMLreturn(ret);
+}
+
+value caml_gmp_mpq_mul(value t1, value t2)
+{
+  CAMLparam2(t1, t2);
+
+  value ret = caml_gmp_mpq_init (Val_unit);
+  mpq_mul (*(Mpq_val(ret)), *(Mpq_val(t1)), *(Mpq_val(t2)));
+  CAMLreturn(ret);
+}
+
+value caml_gmp_mpq_sub(value t1, value t2)
+{
+  CAMLparam2(t1, t2);
+
+  value ret = caml_gmp_mpq_init (Val_unit);
+  mpq_sub (*(Mpq_val(ret)), *(Mpq_val(t1)), *(Mpq_val(t2)));
+  CAMLreturn(ret);
+}
+
+value caml_gmp_mpq_div(value t1, value t2)
+{
+  CAMLparam2(t1, t2);
+
+  value ret = caml_gmp_mpq_init (Val_unit);
+  mpq_div (*(Mpq_val(ret)), *(Mpq_val(t1)), *(Mpq_val(t2)));
+  CAMLreturn(ret);
+}
+
+value caml_gmp_mpq_neg(value t)
+{
+  CAMLparam1(t);
+
+  value ret = caml_gmp_mpq_init (Val_unit);
+  mpq_neg (*(Mpq_val(ret)), *(Mpq_val(t)));
+  CAMLreturn(ret);
+}
+
+value caml_gmp_mpq_abs(value t)
+{
+  CAMLparam1(t);
+
+  value ret = caml_gmp_mpq_init (Val_unit);
+  mpq_abs (*(Mpq_val(ret)), *(Mpq_val(t)));
+  CAMLreturn(ret);
+}
+
+value caml_gmp_mpq_inv(value t)
+{
+  CAMLparam1(t);
+
+  value ret = caml_gmp_mpq_init (Val_unit);
+  mpq_inv (*(Mpq_val(ret)), *(Mpq_val(t)));
+  CAMLreturn(ret);
+}
+
+value caml_gmp_mpq_of_parts(value num_val, value den_val)
+{
+  CAMLparam2(num_val, den_val);
+
+  value ret = caml_gmp_mpq_init (Val_unit);
+  mpq_t *v   = Mpq_val(ret);
+  
+  mpq_set_num (*v, *(Mpz_val(num_val)));
+  mpq_set_den (*v, *(Mpz_val(den_val)));
+  mpq_canonicalize (*v);
+  CAMLreturn(ret);
+}
+
+value caml_gmp_to_float_string(value t)
+{
+  CAMLparam1(t);
+
+  CAMLlocal1(ret);
+
+  const int bufsize = 50;
+  char buf[bufsize];
+  mpf_t f;
+  mpf_init (f);
+  mpf_set_q (f, *(Mpq_val(t)));
+
+  gmp_snprintf (buf, bufsize, "%.20Fg", f);
+  mpf_clear (f);
+  ret = caml_copy_string (buf);
+
+  CAMLreturn(ret);
+}
+#!/bin/bash
+
+ocamlopt -c aio_stubs.c
+ocamlopt -ccopt -lrt -o aio aio_stubs.o aio.ml