From 38eec3fe01a490ec2f5cf3903742af89e800e193 Mon Sep 17 00:00:00 2001 From: rich Date: Thu, 11 Dec 2003 17:41:52 +0000 Subject: [PATCH] Memory allocation fixes. --- .depend | 12 ++--- Makefile.config | 4 +- examples/google.ml | 5 +- examples/loadpage.ml | 5 +- examples/parsedate.ml | 5 +- examples/test.ml | 5 +- perl.ml | 18 +------ perl.mli | 66 +------------------------ perl_c.c | 132 ++++++++++++++++++++++---------------------------- 9 files changed, 72 insertions(+), 180 deletions(-) diff --git a/.depend b/.depend index fd4e05e..eaac37d 100644 --- a/.depend +++ b/.depend @@ -1,16 +1,16 @@ perl.cmo: perl.cmi perl.cmx: perl.cmi -examples/google.cmo: perl.cmi wrappers/pl_Net_Google.cmo -examples/google.cmx: perl.cmx wrappers/pl_Net_Google.cmx -examples/loadpage.cmo: perl.cmi wrappers/pl_HTML_Element.cmo \ +examples/google.cmo: wrappers/pl_Net_Google.cmo +examples/google.cmx: wrappers/pl_Net_Google.cmx +examples/loadpage.cmo: wrappers/pl_HTML_Element.cmo \ wrappers/pl_HTML_TreeBuilder.cmo wrappers/pl_HTTP_Request.cmo \ wrappers/pl_LWP_UserAgent.cmo -examples/loadpage.cmx: perl.cmx wrappers/pl_HTML_Element.cmx \ +examples/loadpage.cmx: wrappers/pl_HTML_Element.cmx \ wrappers/pl_HTML_TreeBuilder.cmx wrappers/pl_HTTP_Request.cmx \ wrappers/pl_LWP_UserAgent.cmx -examples/parsedate.cmo: perl.cmi wrappers/pl_Date_Format.cmo \ +examples/parsedate.cmo: wrappers/pl_Date_Format.cmo \ wrappers/pl_Date_Parse.cmo -examples/parsedate.cmx: perl.cmx wrappers/pl_Date_Format.cmx \ +examples/parsedate.cmx: wrappers/pl_Date_Format.cmx \ wrappers/pl_Date_Parse.cmx examples/test.cmo: perl.cmi examples/test.cmx: perl.cmx diff --git a/Makefile.config b/Makefile.config index 637ca6c..23a7aaf 100644 --- a/Makefile.config +++ b/Makefile.config @@ -1,5 +1,5 @@ # perl4caml configuration -*- Makefile -*- -# $Id: Makefile.config,v 1.12 2003-11-19 16:28:22 rich Exp $ +# $Id: Makefile.config,v 1.13 2003-12-11 17:41:52 rich Exp $ # PERLINCDIR # Directory containing the Perl include files, eg. . @@ -20,4 +20,4 @@ EXTRA_CFLAGS := # PACKAGE and VERSION PACKAGE := perl4caml -VERSION := 0.3.7 +VERSION := 0.3.9 diff --git a/examples/google.ml b/examples/google.ml index d21d27f..d6c3640 100644 --- a/examples/google.ml +++ b/examples/google.ml @@ -1,7 +1,7 @@ (* Example program which uses Net::Google to query Google. * You will need to have a Google API key in ~/.googlekey for this to work. * Copyright (C) 2003 Merjis Ltd. - * $Id: google.ml,v 1.3 2003-10-16 11:03:52 rich Exp $ + * $Id: google.ml,v 1.4 2003-12-11 17:41:52 rich Exp $ *) open Printf @@ -30,8 +30,5 @@ let () = printf "* %s\n \n\n" response#title response#url ) search#results; - (* Destroy the Perl interpreter. *) - Perl.destroy (Perl.current_interpreter ()); - (* Perform a full collection - good way to find GC/allocation bugs. *) Gc.full_major () diff --git a/examples/loadpage.ml b/examples/loadpage.ml index dfb4afd..6f8db96 100644 --- a/examples/loadpage.ml +++ b/examples/loadpage.ml @@ -1,7 +1,7 @@ (* Example program which uses LWP::UserAgent and HTML::TreeBuilder to * download an HTTP page and parse it. * Copyright (C) 2003 Merjis Ltd. - * $Id: loadpage.ml,v 1.4 2003-10-16 11:03:52 rich Exp $ + * $Id: loadpage.ml,v 1.5 2003-12-11 17:41:52 rich Exp $ *) open Printf @@ -56,8 +56,5 @@ let () = in print tree; - (* Destroy the Perl interpreter. *) - Perl.destroy (Perl.current_interpreter ()); - (* Perform a full collection - good way to find GC/allocation bugs. *) Gc.full_major () diff --git a/examples/parsedate.ml b/examples/parsedate.ml index 7a05cfd..5df04e1 100644 --- a/examples/parsedate.ml +++ b/examples/parsedate.ml @@ -1,6 +1,6 @@ (* Example program which uses Date::Parse. * Copyright (C) 2003 Merjis Ltd. - * $Id: parsedate.ml,v 1.1 2003-11-19 16:28:22 rich Exp $ + * $Id: parsedate.ml,v 1.2 2003-12-11 17:41:52 rich Exp $ *) open Printf @@ -24,8 +24,5 @@ let () = ) strings ); - (* Destroy the Perl interpreter. *) - Perl.destroy (Perl.current_interpreter ()); - (* Perform a full collection - good way to find GC/allocation bugs. *) Gc.full_major () diff --git a/examples/test.ml b/examples/test.ml index 6ab869b..05d6042 100644 --- a/examples/test.ml +++ b/examples/test.ml @@ -1,6 +1,6 @@ (* Simple test of the API. * Copyright (C) 2003 Merjis Ltd. - * $Id: test.ml,v 1.5 2003-10-16 11:03:52 rich Exp $ + * $Id: test.ml,v 1.6 2003-12-11 17:41:52 rich Exp $ *) open Printf @@ -48,8 +48,5 @@ let () = let sv = Perl.call_method obj "get_foo" [] in printf "TestClass.foo is %d\n" (Perl.int_of_sv sv); flush stdout; - (* Destroy the interpreter. *) - Perl.destroy (Perl.current_interpreter ()); - (* Perform a full collection - good way to find GC/allocation bugs. *) Gc.full_major () diff --git a/perl.ml b/perl.ml index 6110c20..a193446 100644 --- a/perl.ml +++ b/perl.ml @@ -1,19 +1,14 @@ (* Interface to Perl from OCaml. * Copyright (C) 2003 Merjis Ltd. - * $Id: perl.ml,v 1.10 2003-10-26 12:57:11 rich Exp $ + * $Id: perl.ml,v 1.11 2003-12-11 17:41:52 rich Exp $ *) -type t - type sv type av type hv exception Perl_failure of string -external create : ?args:string array -> unit -> t - = "perl4caml_create" - (* Initialization. This must happen first, otherwise other parts of the * program will segfault because of a missing interpreter. *) @@ -21,19 +16,8 @@ external c_init : unit -> unit = "perl4caml_init" let () = Callback.register_exception "perl4caml_perl_failure" (Perl_failure ""); c_init (); (* Initialise C code. *) - (* Create the default interpreter. *) - create ~args:[| ""; "-w"; "-e"; "0" |] (); () -external current_interpreter : unit -> t - = "perl4caml_current_interpreter" - -external destroy : t -> unit - = "perl4caml_destroy" - -external set_context : t -> unit - = "perl4caml_set_context" - external int_of_sv : sv -> int = "perl4caml_int_of_sv" external sv_of_int : int -> sv = "perl4caml_sv_of_int" external float_of_sv : sv -> float = "perl4caml_float_of_sv" diff --git a/perl.mli b/perl.mli index 831d69b..a9f0555 100644 --- a/perl.mli +++ b/perl.mli @@ -2,12 +2,9 @@ * * Copyright (C) 2003 Merjis Ltd. * - * $Id: perl.mli,v 1.10 2003-10-26 11:22:38 rich Exp $ + * $Id: perl.mli,v 1.11 2003-12-11 17:41:52 rich Exp $ *) -type t -(** Perl interpreter (abstract type). *) - type sv (** Perl scalar value. *) @@ -20,67 +17,6 @@ type hv exception Perl_failure of string (** [die] in Perl code is translated automatically into this exception. *) -val current_interpreter : unit -> t -(** The [Perl] module has a notion of the "current" interpreter. Throws - * [Not_found] if there is no current interpreter. - * - * When a program starts up, if it has been linked with [perl_init.cmo] - * (which is should be), an interpreter is created for you. Normally - * this should be all you need to know about interpreters, unless you - * want to be really good and call - * [Perl.destroy (Perl.current_interpreter ())] at the end of your - * program to do proper cleanup. - * - * You can also, under certain circumstances, create other interpreters, - * although this is experiemental and definitely not recommended. - * - * If Perl was compiled with [-Dusemultiplicity] then you can create - * mutliple interpreters at the same time and switch between them by - * calling {!Perl.set_context}. - * - * Otherwise you may destroy the current interpreter and create another - * one (provided that at no time you have two "live" interpreters), - * by calling {!Perl.destroy} followed by {!Perl.create}. -*) - -val destroy : t -> unit -(** Destroy the Perl interpreter, performing any necessary cleanup. - * - * You should call [Perl.destroy (Perl.current_interpreter ())] at - * the end of your program, otherwise Perl won't properly clean up - * (running [END] blocks, destroying objects and the like). - * - * Note that a Perl interpreter is created for you by default when you - * use perl4caml. - * - * The current interpreter can be found by calling - * {!Perl.current_interpreter}. - *) - -val create : ?args:string array -> unit -> t -(** Create a new Perl interpreter. (Note that a Perl interpreter is created - * for you by default so you don't need to call this). - * - * The optional [?args] parameter is the command line passed to the - * interpreter, and controls things like whether warnings are enabled - * ([-w]) and which file(s) are parsed. The first element in the - * array is the executable name (you can just set this to [""]). - * - * Perl won't allow you to create multiple interpreters at the same time - * unless Perl itself was compiled with [-Dusemultiplicity]. However you - * can create, then destroy, then create another and so on. - * - * The newly created interpreter is set as the "current interpreter". - *) - -val set_context : t -> unit -(** IF Perl was compiled with [-Dusemultiplicity] and IF you are using - * multiple interpreters at the same time, then you must call this to - * set the implied "current" interpreter. - * - * Most users will never need to call this function. - *) - val int_of_sv : sv -> int (** Convert a Perl [SV] into an integer. Note that OCaml [int]s aren't * large enough to store the full 32 (or 64) bits from a Perl integer, diff --git a/perl_c.c b/perl_c.c index dc5b93b..772bae2 100644 --- a/perl_c.c +++ b/perl_c.c @@ -1,6 +1,6 @@ /* Interface to Perl from OCaml. * Copyright (C) 2003 Merjis Ltd. - * $Id: perl_c.c,v 1.12 2003-11-19 16:28:22 rich Exp $ + * $Id: perl_c.c,v 1.13 2003-12-11 17:41:52 rich Exp $ */ #include @@ -11,6 +11,7 @@ #include #include +#include #include #include #include @@ -33,37 +34,29 @@ static PerlInterpreter *my_perl; /* Wrap up an arbitrary void pointer in an opaque OCaml object. */ static value Val_voidptr (void *ptr); +/* Wrap up an SV, AV or HV in a custom OCaml object which will decrement + * the reference count on finalization. + */ +static value Val_xv (SV *sv); + /* Get the concrete value from an optional field. */ static value unoption (value option, value deflt); /* Unwrap an arbitrary void pointer from an opaque OCaml object. */ #define Voidptr_val(type,rv) ((type *) Field ((rv), 0)) +/* Unwrap a custom block. */ +#define Xv_val(rv) (*((void **)Data_custom_val(rv))) + /* Hide Perl types in opaque OCaml objects. */ #define Val_perl(pl) (Val_voidptr ((pl))) #define Perl_val(plv) (Voidptr_val (PerlInterpreter, (plv))) -#define Val_sv(sv) (Val_voidptr ((sv))) -#define Sv_val(svv) (Voidptr_val (SV, (svv))) -#define Val_av(av) (Val_voidptr ((av))) -#define Av_val(avv) (Voidptr_val (AV, (avv))) -#define Val_hv(hv) (Val_voidptr ((hv))) -#define Hv_val(hvv) (Voidptr_val (HV, (hvv))) - -CAMLprim value -perl4caml_init (value unit) -{ - CAMLparam1 (unit); - PERL_SYS_INIT3 (NULL, NULL, NULL); - CAMLreturn (Val_unit); -} - -CAMLprim value -perl4caml_current_interpreter (value unit) -{ - CAMLparam1 (unit); - if (my_perl == 0) raise_not_found (); - CAMLreturn (Val_perl (my_perl)); -} +#define Val_sv(sv) (Val_xv ((sv))) +#define Sv_val(svv) ((SV *) Xv_val (svv)) +#define Val_av(av) (Val_xv ((SV *)(av))) +#define Av_val(avv) ((AV *) Xv_val (avv)) +#define Val_hv(hv) (Val_xv ((SV *)(hv))) +#define Hv_val(hvv) ((HV *) Xv_val (hvv)) static void xs_init (pTHX) @@ -75,61 +68,19 @@ xs_init (pTHX) } CAMLprim value -perl4caml_create (value optargs, value unit) +perl4caml_init (value unit) { - CAMLparam2 (optargs, unit); - CAMLlocal1 (args); - int argc, i; - char **argv; - static char *no_args[] = { "", "-w", "-e", "0" }; - - /* Arguments given? */ - if (optargs == Val_int (0)) /* "None" */ - { - argc = 4; - argv = no_args; - } - else /* "Some args" where args is a string array. */ - { - args = Field (optargs, 0); - argc = Wosize_val (args); - argv = alloca (argc * sizeof (char *)); - for (i = 0; i < argc; ++i) argv[i] = String_val (Field (args, i)); - } + CAMLparam1 (unit); + int argc = 4; + static char *argv[] = { "", "-w", "-e", "0" }; + PERL_SYS_INIT3 (NULL, NULL, NULL); my_perl = perl_alloc (); perl_construct (my_perl); PL_exit_flags |= PERL_EXIT_DESTRUCT_END; perl_parse (my_perl, xs_init, argc, argv, NULL); /*perl_run (my_perl);*/ - CAMLreturn (Val_perl (my_perl)); -} - -CAMLprim value -perl4caml_destroy (value plv) -{ - CAMLparam1 (plv); - PerlInterpreter *pl = Perl_val (plv); - - perl_destruct (pl); - perl_free (pl); - - /* Current interpreter? */ - if (my_perl == pl) my_perl = 0; - - CAMLreturn (Val_unit); -} - -CAMLprim value -perl4caml_set_context (value plv) -{ - CAMLparam1 (plv); - PerlInterpreter *pl = Perl_val (plv); - - PERL_SET_CONTEXT (pl); - my_perl = pl; - CAMLreturn (Val_unit); } @@ -701,10 +652,13 @@ perl4caml_call_array (value optsv, value optfnname, value arglist) */ list = Val_int (0); for (i = 0; i < count; ++i) { + SV *sv; + cons = alloc (2, 0); Field (cons, 1) = list; list = cons; - Field (cons, 0) = Val_sv (newSVsv (POPs)); + sv = newSVsv (POPs); + Field (cons, 0) = Val_sv (sv); } /* Restore the stack. */ @@ -875,10 +829,13 @@ perl4caml_call_method_array (value ref, value name, value arglist) */ list = Val_int (0); for (i = 0; i < count; ++i) { + SV *sv; + cons = alloc (2, 0); Field (cons, 1) = list; list = cons; - Field (cons, 0) = Val_sv (newSVsv (POPs)); + sv = newSVsv (POPs); + Field (cons, 0) = Val_sv (sv); } /* Restore the stack. */ @@ -1080,9 +1037,36 @@ perl4caml_call_class_method_void (value classname, value name, value arglist) static value Val_voidptr (void *ptr) { - value rv = alloc (1, Abstract_tag); /* XXX Is this correct? */ + CAMLparam0 (); + CAMLlocal1 (rv); + rv = alloc (1, Abstract_tag); Field(rv, 0) = (value) ptr; - return rv; + CAMLreturn (rv); +} + +static void +xv_finalize (value v) +{ + SvREFCNT_dec ((SV *) Xv_val (v)); +} + +static struct custom_operations xv_custom_operations = { + "xv_custom_operations", + xv_finalize, + custom_compare_default, + custom_hash_default, + custom_serialize_default, + custom_deserialize_default +}; + +static value +Val_xv (SV *sv) +{ + CAMLparam0 (); + CAMLlocal1 (rv); + rv = alloc_custom (&xv_custom_operations, sizeof (void *), 0, 1); + Xv_val (rv) = sv; + CAMLreturn (rv); } static value -- 1.8.3.1