Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

269 lines (214 sloc) 8.479 kb
(*
Copyright © 2011 MLstate
This file is part of OPA.
OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.
OPA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.
You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
(* depends *)
module Array = Base.Array
module Lazy = Base.Lazy
module List = Base.List
(* alias *)
module Complex = Flat_Runtime.Complex
module Field = Flat_Runtime.Field
module Simple = Flat_Runtime.Simple
module VTable = Flat_Runtime.VTable
exception RuntimeError of string
(* -- *)
let rec compare_cpx c1 c2 =
let c1 = ( Obj.magic c1 : Complex.t ) in
let c2 = ( Obj.magic c2 : Complex.t ) in
let v1 = VTable.export (Complex.get_vtable c1) in
let v2 = VTable.export (Complex.get_vtable c2) in
let r = Array.compare Field.compare v1 v2 in
if r <> 0 then r else
let len = Array.length v1 in
let rec aux i =
if i >= len then 0 else
let r = compare
(Complex.get_value i c1)
(Complex.get_value i c2)
in
if r <> 0 then r else aux (succ i)
in aux 0
and compare r1 r2 =
let is_r1_cpx = Flat_Runtime.is_record (Obj.repr r1) in
if is_r1_cpx
then
let is_r2_cpx = Flat_Runtime.is_record (Obj.repr r2) in
if is_r2_cpx then compare_cpx r1 r2
else
Pervasives.compare r1 r2
else
Pervasives.compare r1 r2
type ty_record = Flat_Runtime.record
(* we can't write [type 'a ty_info = 'a info] otherwise we get
"inconsistent assumption blah blah blah i'm stupid" from ocaml. So let's
define the /exact same/ type as it is waiting for and use some magic *)
type 'a ty_info = 'a constraint 'a = [> ]
let empty_record = Flat_Runtime.empty
let has_lazy_data r =
Obj.obj (Complex.get_info r) <> None
let get_lazy_data_opt r = Obj.magic (Flat_Runtime.get_record_info r)
let embed_lazy_data r o =
Complex.update_info r (Obj.repr o)
let inject_lazy_data r o =
(* check with Louis: we may corrupt shared representation *)
if Flat_Runtime.is_simple r then () else
Complex.inject_info r (Obj.repr o)
let at_exit, do_exit, get_exit =
let at_exit_fun = ref (fun () -> ()) in
let once f = (* Because we don't want to execute twice with our do_exit and ocaml's at_exit *)
let don = ref false in fun x -> if !don then () else (don := true; f x) in
let at_exit_first = (* Because our at_exit keeps only one function (overriding previous ones) *)
let don = ref false in fun f ->
Pervasives.at_exit (fun () -> if !don then () else (don := true; f ()))
in
(fun f -> let f = once f in at_exit_fun := f; at_exit_first f),
(fun i -> !at_exit_fun (); exit i),
(fun () -> !at_exit_fun)
type field = Field.t
let compare_field = Field.compare
type field_index = int
type fields_indexes = VTable.t
type patterns_indexes = fields_indexes array
type 'a rt_record = 'a
external rt_to_ty_record : 'a rt_record -> ty_record = "%identity"
external ty_to_rt_record : ty_record -> 'a rt_record = "%identity"
let fields_indexes (x:field array) =
let x = Array.map Field.name x in
Array.fast_sort (Obj.magic Field.compare) x;
(VTable.register x: fields_indexes)
let field_index (x:fields_indexes) (f:field) =
let x = VTable.export x in
let rec aux i =
if x.(i) == f then (i:field_index)
else aux (i+1)
in aux 0
let dot_with_field_index rt_record (field_index:field_index) = Complex.get_value field_index (rt_to_ty_record rt_record)
(* rely on shared vtable hypothesis *)
let patterns_indexes (x:fields_indexes array) = x
let gt = -1
let lt = -2
let compare_structure pattern_index r1 r2 =
let r1 = rt_to_ty_record r1 in
let r2 = rt_to_ty_record r2 in
(* keep synchronised with opatop version until the comment in opatop indicate otherwise *)
(* rely on shared vtable hypothesis *)
let rec common_search v1 i=
if pattern_index.(i) == v1 then i
else if i!=0 then common_search v1 (i-1)
else
raise (RuntimeError "serverLib.compare_structure.common : pattern_index is not compatible with record")
in
let rec diff_search v1 v2 i=
let fields = pattern_index.(i) in
if fields == v1 then gt
else if fields == v2 then lt
else if i != 0 then
diff_search v1 v2 (i-1)
else
raise (RuntimeError "serverLib.compare_structure.diff : pattern_index is not compatible with record")
in
let v1 = Flat_Runtime.Complex.get_vtable r1 in
let v2 = Flat_Runtime.Complex.get_vtable r2 in
let n = Array.length pattern_index in
if v1 == v2 then common_search v1 (n-1)
else diff_search v1 v2 (n-1)
let fold_record folder record acc =
let record = (( Obj.magic record ) : ty_record) in
if Flat_Runtime.is_empty record then
acc
else
let vtable = VTable.export (Complex.get_vtable record) in
Array.fold_left_i
(fun acc field index ->
folder field (Complex.get_value index record) acc
) acc vtable
let fold_2_record folder record1 record2 acc =
let record1 = (( Obj.magic record1 ) : ty_record) in
let record2 = (( Obj.magic record2 ) : ty_record) in
if Flat_Runtime.is_empty record1 then
acc
else
let vtable = VTable.export (Complex.get_vtable record1) in
Array.fold_left_i
(fun acc field index ->
folder field
(Complex.get_value index record1)
(Complex.get_value index record2)
acc
) acc vtable
type record_constructor = (Field.t * Obj.t) list
let empty_record_constructor = []
let add_field rc field value = (field, Obj.repr(value))::rc
let make_record rc =
let cmp (f1,_) (f2,_) = Field.compare f1 f2 in
let sorted = List.sort cmp rc in
let sorted = List.uniq ~cmp sorted in
Obj.magic (Flat_Runtime.init_from_list sorted)
(* TODO: check who does use it *)
let make_simple_record s = Obj.magic (Simple.register (Obj.magic s))
let name_of_field = Field.name_of_field
let field_of_name = Field.field_of_name
let static_name_of_field = Field.name
let static_field_of_name = Field.register
(* Extension for explicit projection *)
let unsafe_dot record field = Flat_Runtime.dot field record
let dot record field = Flat_Runtime.dot_opt field record
let is_present record field = Option.is_some (Flat_Runtime.dot_opt field record)
(* Projections on constants *)
type ty_char = char
type ty_float = float (* youpi *)
type ty_int = int
type ty_null = unit
type ty_string = string
external wrap_char : char -> ty_char = "%identity"
external unwrap_char : ty_char -> char = "%identity"
external wrap_float : float -> ty_float = "%identity"
external unwrap_float : ty_float -> float = "%identity"
external wrap_int : int -> ty_int = "%identity"
external unwrap_int : ty_int -> int = "%identity"
external wrap_string : string -> ty_string = "%identity"
external unwrap_string : ty_string -> string = "%identity"
let void = empty_record
let null = ()
type ty_void = ty_record
type ty_bool = ty_record
type 'a ty_option = ty_record
let wrap_bool = Flat_Runtime.wrap_bool
let unwrap_bool = Flat_Runtime.unwrap_bool
let true_ = Flat_Runtime.true_
let false_ = Flat_Runtime.false_
let wrap_option = Flat_Runtime.wrap_option
let unwrap_option = Flat_Runtime.unwrap_option
let none = Flat_Runtime.none
let some = Flat_Runtime.some
(* support for marshaling *)
let deep_force_eval a = Obj.obj (Lazy.deep_force (Obj.repr a))
let rec sharing_refresh alpha =
if Flat_Runtime.is_record (Obj.repr alpha)
then (
let ma = (Obj.magic alpha : Flat_Runtime.flat_record) in
let contents_len = (Array.length ma) - Flat_Runtime.val_shift in
if contents_len = 0 then Obj.magic empty_record
else (
for i = Flat_Runtime.val_shift to pred (Array.length ma) do
Array.set ma i (Obj.magic (sharing_refresh (Obj.magic (Array.get ma i)))) ;
done ;
if contents_len = 1 && Array.get ma Flat_Runtime.val_shift == Flat_Runtime.shared_void
then Obj.magic (Simple.register (Array.get (Obj.magic (Array.get ma 0)) 0))
else
let () = Array.set ma 0 (Obj.repr (VTable.register (Obj.magic (Array.get ma 0)))) in
Obj.magic (Complex.init_from_evaluated ma)
)
)
else
alpha
Jump to Line
Something went wrong with that request. Please try again.