From: kim Date: Sat, 3 Dec 2011 21:52:20 +0000 (+0000) Subject: Fix C++/OCaml wrappers. X-Git-Url: http://git.nguyen.vg/gitweb/?a=commitdiff_plain;h=813b239795aac1844eb233dab7f8f98d8dba845e;hp=ba65a1b770d860132fbb04be4ca931b983dcb915;p=SXSI%2Fxpathcomp.git Fix C++/OCaml wrappers. - sxsi_alloc_custom() Allocate an OCaml_custom block holding a C++ value of type X Values of type X where X is a pointer type *must* be allocated with new. delete will be called when the custom_block is finalized by the garbage collector - Obj_val(value v) Extract a C++ value of type X from a custom Block v git-svn-id: svn+ssh://idea.nguyen.vg/svn/sxsi/trunk/xpathcomp@1181 3cdefd35-fc62-479d-8e8d-bae585ffb9ca --- diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 98a7403..bbe7fc0 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -6,7 +6,6 @@ open Format let print_list l = eprintf "%![%s]%!\n" (String.concat ", " l) -(*let cxx_flags = S (List.map ( fun x -> A x) cxx_flags)*) let _A x = A x let _S ?(extra=N) l = S (List.map (fun e -> (S [extra; _A e] )) l) ;; @@ -38,20 +37,18 @@ module Depends = struct open Scanf let scan_include ml = - let ic = try open_in ml with - _ -> open_in (include_full_path / ml) - in - let includes = ref [] in - let () = + let ic = open_in ml and includes = ref [] in + begin try while true do let s = input_line ic in if String.length s > 0 then - try sscanf s " INCLUDE \"%s@\"" ((=::) includes) + try + sscanf s " INCLUDE \"%s@\"" (fun s -> includes =:: include_path /s) with Scan_failure _ -> () done with End_of_file -> close_in ic - in + end; !includes let ocaml ml = @@ -60,55 +57,38 @@ let ocaml ml = List.fold_left (fun a i -> (loop i) @ a) includes includes in let includes = loop ml in - dep [ "file:" ^ ml ] - (List.map (fun s -> include_path / s) includes) + dep [ "file:" ^ ml ] includes -let parse_depends file depfile = +let parse_depends depfile = let ichan = open_in depfile in let iscan = Scanning.from_channel ichan in let includes = ref [] in - begin - bscanf iscan " %s@: " ignore; - bscanf iscan " %s " ignore; - try - while true do - try - let s = bscanf iscan " %s " (fun s -> s) in - if s = "" then raise End_of_file; - if s <> "\\" then includes =::s - with - Scan_failure _ -> () - done - with - End_of_file -> close_in ichan - end; - !includes - -let uniq l = - let rec loop l acc = - match l with - | [] -> acc - | [ e ] -> e::acc - | e1 :: ((e2 :: _) as ll) -> - loop ll (if e1 = e2 then acc else e1 :: acc) - in - loop (List.sort compare l) [] + bscanf iscan " %_s@: %s " ignore; + try + while true do + bscanf iscan " %s " ( + function "" -> raise End_of_file + | "\\" -> () + | s -> includes =::s) + done; [] + with + _ -> close_in ichan;!includes let cxx cpp = - let depfile = ( cpp ^ ".depends") in + let depfile = !Options.build_dir /" __cxx_depends.tmp" in let cmd = Cmd (S[ A cxx_cmd ; S !cxx_flags; cxx_include_flags ; A"-MM"; A "-MF"; P depfile; P cpp]) in let () = Command.execute ~quiet:true ~pretend:false cmd in - let includes = parse_depends cpp depfile in - let includes' = uniq (List.filter (Pathname.is_relative) includes) in + let includes = parse_depends depfile in + let includes' = (List.filter (Pathname.is_relative) includes) in dep [ "compile"; "file:" ^ cpp ] includes' end -let cxx_compile env build = - let src = env "%.cpp" and obj = env "%.o" in - let tags = (tags_of_pathname src) ++ "compile" ++ "c++" in - Cmd(S[T tags; A cxx_cmd; A "-o" ; P obj; A "-c"; S !cxx_flags; cxx_include_flags; P src]) +let cxx_compile env _build = + let cpp = env "%.cpp" and obj = env "%.o" in + let tags = (tags_of_pathname cpp) ++ "compile" ++ "c++" in + Cmd(S[T tags; A cxx_cmd; A "-o" ; P obj; A "-c"; S !cxx_flags; cxx_include_flags; P cpp]) (* Native compile and link action *) @@ -161,8 +141,8 @@ let () = dispatch begin | After_rules -> dep [ "link" ] cstub_lib; - rule "compile cpp -> o" ~prod:"%.o" ~deps:[ "%.cpp" ] cxx_compile; + rule "c++: cpp & depends -> o" ~prod:"%.o" ~deps:[ "%.cpp" ] cxx_compile; let syntax_flags = S ([ A "-syntax"; A "camlp4o"; S (ppopt [A "-printer" ; A"Camlp4OCamlAstDumper"]); S (ppopt !pp_macro_options) ]) diff --git a/src/OCamlDriver.cpp b/src/OCamlDriver.cpp index 8eb3a22..bb007a8 100644 --- a/src/OCamlDriver.cpp +++ b/src/OCamlDriver.cpp @@ -23,17 +23,13 @@ #include "Utils.h" #include "common_stub.hpp" -extern "C" { -#include -} - #define CAMLRAISEMSG(msg) (sxsi_raise_msg((char*) (msg))) -#define XMLTREE(x) (Obj_val(x)) +#define XMLTREE(x) (Obj_val(x)) -#define HSET(x) (Obj_val(x)) +#define HSET(x) (Obj_val(x)) -#define XMLTREEBUILDER(x) (Obj_val(x)) +#define XMLTREEBUILDER(x) (Obj_val(x)) #define TREENODEVAL(i) ((treeNode) (Int_val(i))) @@ -56,8 +52,9 @@ extern "C" value caml_xml_tree_builder_create(value unit) { CAMLparam1(unit); CAMLlocal1(result); - result = sxsi_alloc_custom(); - Obj_val(result) = new XMLTreeBuilder(); + result = sxsi_alloc_custom(); + Obj_val(result) = new XMLTreeBuilder(); + CAMLreturn(result); } @@ -102,8 +99,8 @@ extern "C" value caml_xml_tree_builder_close_document(value vbuilder) XMLTree * tree = XMLTREEBUILDER(vbuilder)->CloseDocument(); if (tree == NULL) CAMLRAISEMSG("CloseDocument"); - result = sxsi_alloc_custom(); - Obj_val(result) = tree; + result = sxsi_alloc_custom(); + Obj_val(result) = tree; CAMLreturn (result); } @@ -155,12 +152,16 @@ extern "C" value caml_xml_tree_save(value tree,value fd, value name){ extern "C" value caml_xml_tree_load(value fd, value name, value load_tc,value sf){ CAMLparam4(fd, name, load_tc, sf); - CAMLlocal1(result); + CAMLlocal2(result,tmp); XMLTree * tree; try { + tree = XMLTree::Load(Int_val(fd),Bool_val(load_tc),Int_val(sf), String_val(name)); - result = sxsi_alloc_custom(); - Obj_val(result) = tree; + result = sxsi_alloc_custom(); + + Obj_val(result) = tree; + tmp = sxsi_alloc_custom(); + Obj_val(tmp) = 3l; CAMLreturn(result); } catch (const std::exception& e){ CAMLRAISEMSG(e.what()); } @@ -416,8 +417,8 @@ NoAlloc extern "C" value caml_unordered_set_length(value hset){ extern "C" value caml_unordered_set_alloc(value unit){ CAMLparam1(unit); CAMLlocal1(hset); - hset = sxsi_alloc_custom(); - Obj_val(hset) = new TagIdSet(); + hset = sxsi_alloc_custom(); + Obj_val(hset) = new TagIdSet(); CAMLreturn (hset); } diff --git a/src/common_stub.cpp b/src/common_stub.cpp index 6f56d33..dde97fa 100644 --- a/src/common_stub.cpp +++ b/src/common_stub.cpp @@ -63,7 +63,7 @@ value alloc_custom_(char* name) if (it == type_map->end()) result = Val_unit; else - result = caml_alloc_custom(it->second.first, it->second.second, 1, 2); + result = caml_alloc_custom(it->second.first, it->second.second, 1, 1); CAMLreturn(result); } diff --git a/src/common_stub.hpp b/src/common_stub.hpp index bfacdac..5655a30 100644 --- a/src/common_stub.hpp +++ b/src/common_stub.hpp @@ -3,7 +3,7 @@ extern "C" { #define CAML_NAME_SPACE -#include + #include #include #include @@ -11,48 +11,50 @@ extern "C" { #include #include #include -#include + } -#include #include + void register_custom_(char* name, size_t size, void (*finalize)(value v)); value alloc_custom_(char* name); +template X& Obj_val(value v) +{ + return * (X*) Data_custom_val(v); +} + +template void sxsi_finalize_obj(X) { +} + +template void sxsi_finalize_obj(X* x){ + delete x; +} template void sxsi_finalize_custom(value v) { - X * obj = * ((X **) Data_custom_val(v)); - std::cerr << "Finalizing object: " << typeid(X).name() << std::endl; - std::cerr.flush(); - delete obj; + sxsi_finalize_obj(Obj_val(v)); } template value sxsi_alloc_custom() { char * name = const_cast(typeid(X).name()); + value v = alloc_custom_(name); if (v == Val_unit) { - register_custom_(name, sizeof(X*), sxsi_finalize_custom); + register_custom_(name, sizeof(X), sxsi_finalize_custom); v = alloc_custom_(name); }; return v; } -template X*& Obj_val(value v) -{ - //Cannot use Data_custom_val here, it is not a correct lvalue. :-( - return (X*&) Field(v,1); -} - void sxsi_raise_msg(char * msg); -extern "C" { -value sxsi_cpp_init(value unit); -} +extern "C" value sxsi_cpp_init(value unit); + #endif diff --git a/src/main.ml b/src/main.ml index 76e321d..1981fc2 100644 --- a/src/main.ml +++ b/src/main.ml @@ -45,6 +45,8 @@ let main v query_string output = time ~msg:"Compiling query" (Compile.compile) query in if !Options.verbose then Ata.print Format.err_formatter auto; + Gc.full_major(); + Gc.compact(); Gc.set (tuned_gc); let runtime = match !Options.bottom_up, bu_info with @@ -117,6 +119,7 @@ in (*Printexc.record_backtrace true; *) main document !Options.query !Options.output_file; if !Options.verbose then Printf.eprintf "Maximum resident set size: %s\n" (read_procmem()); + Gc.full_major(); Profile.summary Format.err_formatter with | Ulexer.Loc.Exc_located ((x,y),e) -> diff --git a/src/tree.ml b/src/tree.ml index a8a3a96..b801780 100644 --- a/src/tree.ml +++ b/src/tree.ml @@ -591,7 +591,6 @@ let load ?(sample=64) ?(load_text=true) str = let c, s, d, f = time ~msg:"Loading tag table"(load_table) () in ignore(Unix.lseek fd (pos_in in_c) Unix.SEEK_SET); let xml_tree = tree_load fd str load_text sample in - Printf.eprintf "Root is: %i\n" (Obj.magic (tree_root xml_tree)); let () = Tag.init (Obj.magic xml_tree) in let attributes = Ptset.Int.add Tag.attribute d.(Tag.attribute) in let elements = Ptset.Int.add Tag.document_node