<commit_before>(* TODO: better array support, perhaps based on bigarrays integration *)

module C =
struct
  exception IncompleteType
  exception Unsupported of string

  module Raw = Ffi_raw
  module RawTypes = Ffi_raw.Types

  type 'a structure_type = {
    tag: string;
    bufspec: Raw.bufferspec;
    mutable ctype: 'a Raw.structure RawTypes.ctype option
  }

  type 'a union_type = {
    utag: string;
    mutable ucomplete: bool;
    mutable usize: int;
    mutable ualignment: int;
  }

  type 'a structure = { managed : Raw.managed_buffer;
                        raw_ptr' : Raw.immediate_pointer;
                        stype : 'a structure_type }

  type _ typ =
      Void : unit typ
    | Primitive : 'a RawTypes.ctype -> 'a typ
    | Pointer : 'a typ -> 'a ptr typ
    | Struct : 'a structure_type -> 'a structure typ
    | Union : 'a union_type -> 'a union typ
    | Array : 'a typ * int -> 'a array typ
    | FunctionPointer : ('a -> 'b) fn -> ('a -> 'b) typ
  and _ fn =
    | Returns : 'a typ -> 'a fn
    | Function : 'a typ * 'b fn -> ('a -> 'b) fn
  and 'a ptr = { reftype : 'a typ;
                 raw_ptr : Raw.immediate_pointer;
                 pmanaged : Raw.managed_buffer option;
                 pbyte_offset : int }
  and 'a array = { astart: 'a ptr;
                   alength : int }
  and 'a union = { union : 'a union ptr }

  let rec sizeof : 'a. 'a typ -> int
    = fun (type a) (t : a typ) -> match t with
        Void                      -> raise IncompleteType
      | Primitive p               -> RawTypes.sizeof p
      | Struct { ctype = None }   -> raise IncompleteType
      | Struct { ctype = Some p } -> RawTypes.sizeof p
      | Union { ucomplete=false } -> raise IncompleteType
      | Union { usize }           -> usize
      | Array (t, i)              -> i * sizeof t
      | Pointer _                 -> RawTypes.(sizeof pointer)
      | FunctionPointer _         -> RawTypes.(sizeof pointer)

  let rec alignment : 'a. 'a typ -> int
    = fun (type a) (t : a typ) -> match t with
        Void                      -> raise IncompleteType
      | Primitive p               -> RawTypes.alignment p
      | Struct { ctype = None }   -> raise IncompleteType
      | Struct { ctype = Some p } -> RawTypes.alignment p
      | Union { ucomplete=false } -> raise IncompleteType
      | Union { ualignment }      -> ualignment
      | Array (t, i)              -> alignment t
      | Pointer _                 -> RawTypes.(alignment pointer)
      | FunctionPointer _         -> RawTypes.(alignment pointer)

  (* TODO: we could dispense with these type and the accompanying
     interpretations.  It'd probably make things more efficient, for
     various reasons (elimination of tags, elimination of recursion,
     exposing opportunities for optimization), but might make things
     terribly higher-order. *)
  type _ ccallspec =
      Call : ('b -> 'a) * 'b RawTypes.ctype -> 'a ccallspec
    | WriteArg : (Raw.immediate_pointer -> 'a -> unit) * 'b ccallspec -> ('a -> 'b) ccallspec

  type _ callbackspec =
      Return : ('a -> 'b) * 'b RawTypes.ctype -> 'a callbackspec
    | ReadArg : (Raw.immediate_pointer -> 'a) * 'b callbackspec -> ('a -> 'b) callbackspec

  type _ reader = Reader : ('b -> 'a) * 'b RawTypes.ctype -> 'a reader
  type _ writer = Writer : ('a -> 'b) * 'b RawTypes.ctype -> 'a writer

  let id x = x

  (*
    call addr callspec return (fun buffer ->
    write arg_1 buffer v_1
    write arg_2 buffer v_2
    ...
    write arg_n buffer v_n)
  *)
  let rec invoke : 'a.'a ccallspec -> (Raw.immediate_pointer -> unit) list -> Raw.bufferspec -> Raw.immediate_pointer -> 'a
    = fun (type a) (fn : a ccallspec) -> match fn with
      | Call (f, ftype) ->
        fun writers callspec addr ->
          f (Raw.call addr callspec
               (fun buf -> List.iter (fun w -> w buf) writers)
               (Raw.read ~offset:0 ftype))
      | WriteArg (write, ccallspec) ->
        let next = invoke ccallspec in
        fun writers callspec addr v ->
          next ((fun buffer -> write buffer v) :: writers) callspec addr

  let rec box_function : 'a. 'a callbackspec -> 'a -> Raw.boxedfn
    = fun (type a) (fn : a callbackspec) -> match fn with
      | Return (transform, ftype) ->
        fun f -> Raw.Done (fun buffer -> 
          Raw.write ~offset:0 ftype buffer (transform f))
      | ReadArg (read, rest) ->
        let box = box_function rest in
        fun f -> Raw.Fn (fun buffer -> 
          box (f (read buffer)))

  let create_function_pointer : 'a. Raw.bufferspec -> 'a callbackspec -> 'a -> Raw.immediate_pointer
    = fun e c f -> 
      Raw.make_function_pointer e (box_function c f)

  let rec build_callspec : 'a. 'a fn -> Raw.bufferspec -> 'a callbackspec =
    fun (type a) fn callspec -> match (fn : a fn) with
      | Returns ty ->
        let Writer (to_prim, ctype) = writer ty in
        let _ = Raw.prep_callspec callspec ctype in
        Return (to_prim, ctype)
      | Function (Void, f) ->
        let rest = build_callspec f callspec in
        ReadArg ((fun _ -> ()), rest)
      | Function (p, f) ->
        let Reader (from_prim, ctype) = reader p in
        let _ = Raw.add_argument callspec ctype in
        let rest = build_callspec f callspec in
        ReadArg ((fun buf -> from_prim (Raw.read ~offset:0 ctype buf)), rest)

  (* Describes how to read an argument, e.g. from a return buffer *)
  and reader : 'a. 'a typ -> 'a reader =
    fun (type a) (t : a typ) -> match t with
      | Void ->
        (Reader (id, RawTypes.void) : a reader)
      | Primitive p ->
        Reader (id, p)
      | Array (reftype, alength) ->
        let Reader (f, t) = reader (Pointer reftype) in
        Reader ((fun p -> {astart = f p; alength}), t)
      | Struct {ctype=None} ->
        raise IncompleteType
      | Struct ({ctype=Some p} as stype) ->
        Reader ((fun managed -> {managed; stype; raw_ptr' = Raw.managed_secret managed}), p)
      | Union _ ->
        raise (Unsupported "Passing or returning union by value")
      | Pointer reftype ->
        Reader ((fun raw_ptr ->
          {pbyte_offset=0; reftype; raw_ptr; pmanaged=None}), RawTypes.pointer)
      | FunctionPointer f ->
        Reader (function_builder f, RawTypes.pointer)

  and writer : 'a. 'a typ -> 'a writer =
    fun (type a) (t : a typ) -> match t with
      | Void ->
        (Writer (id, RawTypes.void) : a writer)
      | Primitive p ->
        Writer (id, p)
      | Array (reftype, alength) ->
        let Writer (f, t) = writer (Pointer reftype) in
        Writer ((fun {astart} -> f astart), t)
      | Struct {ctype=None} ->
        raise IncompleteType
      | Struct {ctype=Some p} ->
        Writer ((fun {managed} -> managed), p)
      | Union _ ->
        raise (Unsupported "Passing or returning union by value")
      | Pointer reftype ->
        Writer ((fun {raw_ptr; pbyte_offset} -> Raw.pointer_plus raw_ptr pbyte_offset),
                RawTypes.pointer)
      | FunctionPointer fn ->
        let cs' = Raw.allocate_callspec () in
        let cs = build_callspec fn cs' in
        Writer (create_function_pointer cs' cs, RawTypes.pointer)

  (*
    callspec = allocate_callspec ()
    arg_1 = add_argument callspec argtype
    arg_2 = add_argument callspec argtype
    ...
    arg_n = add_argument callspec argtype
    return = prep_callspec callspec rettype
  *)
  and build_ccallspec : 'a. 'a fn -> Raw.bufferspec -> 'a ccallspec
    = fun (type a) (fn : a fn) callspec -> match fn with
      | Returns t ->
        let Reader (from_prim, ctype) = reader t in
        let () = Raw.prep_callspec callspec ctype in
        (Call (from_prim, ctype) : a ccallspec)
      | Function (Void, f) ->
        let rest = build_ccallspec f callspec in
        WriteArg ((fun _ _ -> ()), rest)
      | Function (p, f) ->
        let Writer (to_prim, ctype) = writer p in
        let offset = Raw.add_argument callspec ctype in
        let rest = build_ccallspec f callspec in
        WriteArg ((fun buf x -> Raw.write ~offset ctype buf (to_prim x)), rest)

  and function_builder : 'a. 'a fn -> RawTypes.voidp -> 'a
    = fun fn ->
      let c = Raw.allocate_callspec () in
      let e = build_ccallspec fn c in
      invoke e [] c<commit_msg>Tweak to improve staging.<commit_after>(* TODO: better array support, perhaps based on bigarrays integration *)

module C =
struct
  exception IncompleteType
  exception Unsupported of string

  module Raw = Ffi_raw
  module RawTypes = Ffi_raw.Types

  type 'a structure_type = {
    tag: string;
    bufspec: Raw.bufferspec;
    mutable ctype: 'a Raw.structure RawTypes.ctype option
  }

  type 'a union_type = {
    utag: string;
    mutable ucomplete: bool;
    mutable usize: int;
    mutable ualignment: int;
  }

  type 'a structure = { managed : Raw.managed_buffer;
                        raw_ptr' : Raw.immediate_pointer;
                        stype : 'a structure_type }

  type _ typ =
      Void : unit typ
    | Primitive : 'a RawTypes.ctype -> 'a typ
    | Pointer : 'a typ -> 'a ptr typ
    | Struct : 'a structure_type -> 'a structure typ
    | Union : 'a union_type -> 'a union typ
    | Array : 'a typ * int -> 'a array typ
    | FunctionPointer : ('a -> 'b) fn -> ('a -> 'b) typ
  and _ fn =
    | Returns : 'a typ -> 'a fn
    | Function : 'a typ * 'b fn -> ('a -> 'b) fn
  and 'a ptr = { reftype : 'a typ;
                 raw_ptr : Raw.immediate_pointer;
                 pmanaged : Raw.managed_buffer option;
                 pbyte_offset : int }
  and 'a array = { astart: 'a ptr;
                   alength : int }
  and 'a union = { union : 'a union ptr }

  let rec sizeof : 'a. 'a typ -> int
    = fun (type a) (t : a typ) -> match t with
        Void                      -> raise IncompleteType
      | Primitive p               -> RawTypes.sizeof p
      | Struct { ctype = None }   -> raise IncompleteType
      | Struct { ctype = Some p } -> RawTypes.sizeof p
      | Union { ucomplete=false } -> raise IncompleteType
      | Union { usize }           -> usize
      | Array (t, i)              -> i * sizeof t
      | Pointer _                 -> RawTypes.(sizeof pointer)
      | FunctionPointer _         -> RawTypes.(sizeof pointer)

  let rec alignment : 'a. 'a typ -> int
    = fun (type a) (t : a typ) -> match t with
        Void                      -> raise IncompleteType
      | Primitive p               -> RawTypes.alignment p
      | Struct { ctype = None }   -> raise IncompleteType
      | Struct { ctype = Some p } -> RawTypes.alignment p
      | Union { ucomplete=false } -> raise IncompleteType
      | Union { ualignment }      -> ualignment
      | Array (t, i)              -> alignment t
      | Pointer _                 -> RawTypes.(alignment pointer)
      | FunctionPointer _         -> RawTypes.(alignment pointer)

  (* TODO: we could dispense with these type and the accompanying
     interpretations.  It'd probably make things more efficient, for
     various reasons (elimination of tags, elimination of recursion,
     exposing opportunities for optimization), but might make things
     terribly higher-order. *)
  type _ ccallspec =
      Call : ('b -> 'a) * 'b RawTypes.ctype -> 'a ccallspec
    | WriteArg : (Raw.immediate_pointer -> 'a -> unit) * 'b ccallspec -> ('a -> 'b) ccallspec

  type _ callbackspec =
      Return : ('a -> 'b) * 'b RawTypes.ctype -> 'a callbackspec
    | ReadArg : (Raw.immediate_pointer -> 'a) * 'b callbackspec -> ('a -> 'b) callbackspec

  type _ reader = Reader : ('b -> 'a) * 'b RawTypes.ctype -> 'a reader
  type _ writer = Writer : ('a -> 'b) * 'b RawTypes.ctype -> 'a writer

  let id x = x

  (*
    call addr callspec return (fun buffer ->
    write arg_1 buffer v_1
    write arg_2 buffer v_2
    ...
    write arg_n buffer v_n)
  *)
  let rec invoke : 'a.'a ccallspec -> (Raw.immediate_pointer -> unit) list -> Raw.bufferspec -> Raw.immediate_pointer -> 'a
    = fun (type a) (fn : a ccallspec) -> match fn with
      | Call (f, ftype) ->
        fun writers callspec addr ->
          f (Raw.call addr callspec
               (fun buf -> List.iter (fun w -> w buf) writers)
               (Raw.read ~offset:0 ftype))
      | WriteArg (write, ccallspec) ->
        let next = invoke ccallspec in
        fun writers callspec addr v ->
          next ((fun buffer -> write buffer v) :: writers) callspec addr

  let rec box_function : 'a. 'a callbackspec -> 'a -> Raw.boxedfn
    = fun (type a) (fn : a callbackspec) -> match fn with
      | Return (transform, ftype) ->
        fun f -> Raw.Done (fun buffer -> 
          Raw.write ~offset:0 ftype buffer (transform f))
      | ReadArg (read, rest) ->
        let box = box_function rest in
        fun f -> Raw.Fn (fun buffer -> 
          box (f (read buffer)))

  let rec build_callspec : 'a. 'a fn -> Raw.bufferspec -> 'a callbackspec =
    fun (type a) fn callspec -> match (fn : a fn) with
      | Returns ty ->
        let Writer (to_prim, ctype) = writer ty in
        let _ = Raw.prep_callspec callspec ctype in
        Return (to_prim, ctype)
      | Function (Void, f) ->
        let rest = build_callspec f callspec in
        ReadArg ((fun _ -> ()), rest)
      | Function (p, f) ->
        let Reader (from_prim, ctype) = reader p in
        let _ = Raw.add_argument callspec ctype in
        let rest = build_callspec f callspec in
        ReadArg ((fun buf -> from_prim (Raw.read ~offset:0 ctype buf)), rest)

  (* Describes how to read an argument, e.g. from a return buffer *)
  and reader : 'a. 'a typ -> 'a reader =
    fun (type a) (t : a typ) -> match t with
      | Void ->
        (Reader (id, RawTypes.void) : a reader)
      | Primitive p ->
        Reader (id, p)
      | Array (reftype, alength) ->
        let Reader (f, t) = reader (Pointer reftype) in
        Reader ((fun p -> {astart = f p; alength}), t)
      | Struct {ctype=None} ->
        raise IncompleteType
      | Struct ({ctype=Some p} as stype) ->
        Reader ((fun managed -> {managed; stype; raw_ptr' = Raw.managed_secret managed}), p)
      | Union _ ->
        raise (Unsupported "Passing or returning union by value")
      | Pointer reftype ->
        Reader ((fun raw_ptr ->
          {pbyte_offset=0; reftype; raw_ptr; pmanaged=None}), RawTypes.pointer)
      | FunctionPointer f ->
        Reader (function_builder f, RawTypes.pointer)

  and writer : 'a. 'a typ -> 'a writer =
    fun (type a) (t : a typ) -> match t with
      | Void ->
        (Writer (id, RawTypes.void) : a writer)
      | Primitive p ->
        Writer (id, p)
      | Array (reftype, alength) ->
        let Writer (f, t) = writer (Pointer reftype) in
        Writer ((fun {astart} -> f astart), t)
      | Struct {ctype=None} ->
        raise IncompleteType
      | Struct {ctype=Some p} ->
        Writer ((fun {managed} -> managed), p)
      | Union _ ->
        raise (Unsupported "Passing or returning union by value")
      | Pointer reftype ->
        Writer ((fun {raw_ptr; pbyte_offset} -> Raw.pointer_plus raw_ptr pbyte_offset),
                RawTypes.pointer)
      | FunctionPointer fn ->
        let cs' = Raw.allocate_callspec () in
        let cs = build_callspec fn cs' in
        let box = box_function cs in
        Writer ((fun f -> Raw.make_function_pointer cs' (box f)),
                RawTypes.pointer)

  (*
    callspec = allocate_callspec ()
    arg_1 = add_argument callspec argtype
    arg_2 = add_argument callspec argtype
    ...
    arg_n = add_argument callspec argtype
    return = prep_callspec callspec rettype
  *)
  and build_ccallspec : 'a. 'a fn -> Raw.bufferspec -> 'a ccallspec
    = fun (type a) (fn : a fn) callspec -> match fn with
      | Returns t ->
        let Reader (from_prim, ctype) = reader t in
        let () = Raw.prep_callspec callspec ctype in
        (Call (from_prim, ctype) : a ccallspec)
      | Function (Void, f) ->
        let rest = build_ccallspec f callspec in
        WriteArg ((fun _ _ -> ()), rest)
      | Function (p, f) ->
        let Writer (to_prim, ctype) = writer p in
        let offset = Raw.add_argument callspec ctype in
        let rest = build_ccallspec f callspec in
        WriteArg ((fun buf x -> Raw.write ~offset ctype buf (to_prim x)), rest)

  and function_builder : 'a. 'a fn -> RawTypes.voidp -> 'a
    = fun fn ->
      let c = Raw.allocate_callspec () in
      let e = build_ccallspec fn c in
      invoke e [] c
{'fraction_non_alphanumeric': 0.11517813567593949, 'fraction_numerical': 0.0012201073694485115, 'mean_word_length': 2.0034811286185414, 'pattern_counts': {'":': 0, '<': 3, '<?xml version=': 0, '>': 240, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '6216817', 'n_tokens_mistral': 5115, 'n_tokens_neox': 4986, 'n_words': 1761}