[H5r-commits] r89 - R src tests
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Jan 10 00:16:31 CET 2013
Author: extemporaneousb
Date: 2013-01-10 00:16:31 +0100 (Thu, 10 Jan 2013)
New Revision: 89
Modified:
R/h5R.R
src/h5_debug.c
src/h5_wrap.c
tests/testMemory.R
Log:
Added some internal code for memory issues. Hopefully, this code doesn't make the package less portable, but there seems to be a need for returning unused memory to the kernel in Linux - see the tests/testMemory.R for a longer description of the problem.
Modified: R/h5R.R
===================================================================
--- R/h5R.R 2012-10-03 18:53:44 UTC (rev 88)
+++ R/h5R.R 2013-01-09 23:16:31 UTC (rev 89)
@@ -116,6 +116,14 @@
return(! is.null(h5Dataset at .data))
}
+.openObjects <- function(h5File) {
+ .myCall("h5R_get_object_count", .ePtr(h5File))
+}
+
+.mallocTrim <- function() {
+ .myCall("h5R_malloc_trim")
+}
+
setMethod("getH5Group", c("H5Container", "character"), function(h5Obj, groupName) {
if (is.null(x <- .myCall("h5R_get_group", .ePtr(h5Obj), groupName)))
stop(paste("Group:", groupName, "cannot be opened."))
@@ -499,6 +507,7 @@
}
read1DSlabs <- function(h5Dataset, offsets, dims) {
+ print("calling read1DSlabs")
.myCall("h5R_read_1d_slabs", .ePtr(h5Dataset), as.integer(offsets - 1), as.integer(dims))
}
Modified: src/h5_debug.c
===================================================================
--- src/h5_debug.c 2012-10-03 18:53:44 UTC (rev 88)
+++ src/h5_debug.c 2013-01-09 23:16:31 UTC (rev 89)
@@ -5,14 +5,17 @@
#include <Rinternals.h>
#include <R.h>
+#define myfree(p) (free(p))
+#define myalloc(s) (malloc(s))
+
void h5R_allocate_finalizer(SEXP eptr) {
char* vector = R_ExternalPtrAddr(eptr);
- Free(vector);
+ myfree(vector);
R_ClearExternalPtr(eptr);
}
SEXP h5R_allocate_meg() {
- char* vector = (char*) Calloc(1048576, char);
+ char* vector = (char*) myalloc(1048576);
for (int j = 0; j < 1048576; j++) {
vector[j] = 'c';
}
@@ -24,7 +27,7 @@
}
SEXP h5R_allocate_k() {
- char* vector = (char*) Calloc(1024, char);
+ char* vector = (char*) myalloc(1024);
for (int j = 0; j < 1024; j++) {
vector[j] = 'c';
}
@@ -36,7 +39,7 @@
}
SEXP h5R_allocate_gig() {
- char* vector = (char*) Calloc(1073741824, char);
+ char* vector = (char*) myalloc(1073741824);
for (int j = 0; j < 1073741824; j++) {
vector[j] = 'c';
}
Modified: src/h5_wrap.c
===================================================================
--- src/h5_wrap.c 2012-10-03 18:53:44 UTC (rev 88)
+++ src/h5_wrap.c 2013-01-09 23:16:31 UTC (rev 89)
@@ -4,149 +4,177 @@
#include <hdf5.h>
#include <Rinternals.h>
#include <R.h>
+#include <malloc.h>
-#define DEBUG 1
+#define DEBUG 0
+#define MEMORYDEBUG 0
+
#define HID(argname) (((h5_holder*) R_ExternalPtrAddr(argname))->id)
#define NM(argname) (CHAR(STRING_ELT(argname, 0)))
#define SUCCESS ScalarLogical(1)
#define FAILURE ScalarLogical(0)
typedef struct h5_holder {
- int is_file;
- hid_t id;
+ int is_file;
+ hid_t id;
} h5_holder;
+SEXP h5R_malloc_trim() {
+#ifdef __GLIBC__
+ return ScalarInteger(malloc_trim(0));
+#else
+ return ScalarInteger(-1);
+#endif
+}
+
void h5R_finalizer(SEXP h5_obj) {
- h5_holder* h = (h5_holder*) R_ExternalPtrAddr(h5_obj);
- if (! h) {
- return;
- }
- if (h->is_file == 1) {
- H5Fflush(HID(h5_obj), H5F_SCOPE_GLOBAL);
- H5Fclose(HID(h5_obj));
- } else {
- switch (H5Iget_type(HID(h5_obj))) {
- case H5I_DATASET:
- H5Dclose(HID(h5_obj));
- break;
- case H5I_ATTR:
- H5Aclose(HID(h5_obj));
- break;
- case H5I_GROUP:
- H5Gclose(HID(h5_obj));
- break;
- default:
- break;
+ h5_holder* h = (h5_holder*) R_ExternalPtrAddr(h5_obj);
+ if (! h) {
+ return;
}
- }
- Free(h);
- R_ClearExternalPtr(h5_obj);
+ if (h->is_file == 1) {
+ if (MEMORYDEBUG) Rprintf("Flushing and closing file.\n");
+ H5Fflush(HID(h5_obj), H5F_SCOPE_GLOBAL);
+ H5Fclose(HID(h5_obj));
+ } else {
+ switch (H5Iget_type(HID(h5_obj))) {
+ case H5I_DATASET:
+ if (MEMORYDEBUG) Rprintf("Closing dataset.\n");
+ H5Dclose(HID(h5_obj));
+ break;
+ case H5I_ATTR:
+ if (MEMORYDEBUG) Rprintf("Closing attribute.\n");
+ H5Aclose(HID(h5_obj));
+ break;
+ case H5I_GROUP:
+ if (MEMORYDEBUG) Rprintf("Closing group.\n");
+ H5Gclose(HID(h5_obj));
+ break;
+ default:
+ break;
+ }
+ }
+ Free(h);
+ R_ClearExternalPtr(h5_obj);
+
+ // This call is seemingly a noop.
+ H5garbage_collect();
+
+ // Not sure if calling this here will be sufficient.
+ h5R_malloc_trim();
}
SEXP _h5R_make_holder (hid_t id, int is_file) {
- if (id < 0) {
- return R_NilValue;
- }
- h5_holder* holder = (h5_holder*) Calloc(1, h5_holder);
- holder->id = id;
- holder->is_file = is_file;
- SEXP e_ptr = R_MakeExternalPtr(holder, R_NilValue, R_NilValue);
- PROTECT(e_ptr);
- R_RegisterCFinalizerEx(e_ptr, h5R_finalizer, TRUE);
- UNPROTECT(1);
- return e_ptr;
+ if (id < 0) {
+ return R_NilValue;
+ }
+ h5_holder* holder = (h5_holder*) Calloc(1, h5_holder);
+ holder->id = id;
+ holder->is_file = is_file;
+ SEXP e_ptr = R_MakeExternalPtr(holder, R_NilValue, R_NilValue);
+ PROTECT(e_ptr);
+ R_RegisterCFinalizerEx(e_ptr, h5R_finalizer, TRUE);
+ UNPROTECT(1);
+ return e_ptr;
}
SEXP h5R_flush(SEXP h5_file) {
- H5Fflush(HID(h5_file), H5F_SCOPE_GLOBAL);
- return SUCCESS;
+ H5Fflush(HID(h5_file), H5F_SCOPE_GLOBAL);
+ return SUCCESS;
}
SEXP h5R_open(SEXP filename, SEXP mode) {
- int _mode_ = (INTEGER(mode)[0] == 1) ? H5F_ACC_RDWR : H5F_ACC_RDONLY;
- return _h5R_make_holder(H5Fopen(NM(filename), _mode_, H5P_DEFAULT), 1);
+ int _mode_ = (INTEGER(mode)[0] == 1) ? H5F_ACC_RDWR : H5F_ACC_RDONLY;
+ return _h5R_make_holder(H5Fopen(NM(filename), _mode_, H5P_DEFAULT), 1);
}
SEXP h5R_create(SEXP filename) {
- return _h5R_make_holder(H5Fcreate(NM(filename), H5F_ACC_EXCL, H5P_DEFAULT, H5P_DEFAULT), 1);
+ return _h5R_make_holder(H5Fcreate(NM(filename), H5F_ACC_EXCL, H5P_DEFAULT, H5P_DEFAULT), 1);
}
SEXP h5R_get_group(SEXP h5_obj, SEXP group_name) {
- return _h5R_make_holder(H5Gopen2(HID(h5_obj), NM(group_name), H5P_DEFAULT), 0);
+ return _h5R_make_holder(H5Gopen2(HID(h5_obj), NM(group_name), H5P_DEFAULT), 0);
}
SEXP h5R_create_group(SEXP h5_obj, SEXP group_name) {
- return _h5R_make_holder(H5Gcreate2(HID(h5_obj), NM(group_name), H5P_DEFAULT, H5P_DEFAULT, H5P_DEFAULT), 0);
+ return _h5R_make_holder(H5Gcreate2(HID(h5_obj), NM(group_name), H5P_DEFAULT, H5P_DEFAULT, H5P_DEFAULT), 0);
}
SEXP h5R_get_dataset(SEXP h5_obj, SEXP dataset_name) {
- return _h5R_make_holder(H5Dopen2(HID(h5_obj), NM(dataset_name), H5P_DEFAULT), 0);
+ return _h5R_make_holder(H5Dopen2(HID(h5_obj), NM(dataset_name), H5P_DEFAULT), 0);
}
SEXP h5R_get_attr(SEXP h5_obj, SEXP attr_name) {
- return _h5R_make_holder(H5Aopen(HID(h5_obj), NM(attr_name), H5P_DEFAULT), 0);
+ return _h5R_make_holder(H5Aopen(HID(h5_obj), NM(attr_name), H5P_DEFAULT), 0);
}
+SEXP h5R_garbage_collect() {
+ return ScalarInteger(H5garbage_collect());
+}
+
+// callers of this function need to clean up using: H5Sclose.
hid_t _h5R_get_space(SEXP h5_obj) {
- hid_t space = -1;
-
- switch (H5Iget_type(HID(h5_obj))) {
- case H5I_DATASET:
- space = H5Dget_space(HID(h5_obj));
- break;
- case H5I_ATTR:
- space = H5Aget_space(HID(h5_obj));
- break;
- default:
- error("Unknown object in %s.\n", __func__);
- }
- return space;
+ hid_t space = -1;
+ switch (H5Iget_type(HID(h5_obj))) {
+ case H5I_DATASET:
+ space = H5Dget_space(HID(h5_obj));
+ break;
+ case H5I_ATTR:
+ space = H5Aget_space(HID(h5_obj));
+ break;
+ default:
+ error("Unknown object type in %s.\n", __func__);
+ }
+ return space;
}
+// callers of this function need to clean up using: H5Tclose.
hid_t _h5R_get_type(SEXP h5_obj) {
- hid_t dtype = -1;
-
- switch (H5Iget_type(HID(h5_obj))) {
- case H5I_DATASET:
- dtype = H5Dget_type(HID(h5_obj));
- break;
- case H5I_ATTR:
- dtype = H5Aget_type(HID(h5_obj));
- break;
- default:
- error("Unknown object in %s.\n", __func__);
- }
- return dtype;
+ hid_t dtype = -1;
+ switch (H5Iget_type(HID(h5_obj))) {
+ case H5I_DATASET:
+ dtype = H5Dget_type(HID(h5_obj));
+ break;
+ case H5I_ATTR:
+ dtype = H5Aget_type(HID(h5_obj));
+ break;
+ default:
+ error("Unknown object type in %s.\n", __func__);
+ }
+ return dtype;
}
int _h5R_get_size (SEXP h5_obj) {
- int s = -1;
-
- switch (H5Iget_type(HID(h5_obj))) {
- case H5I_DATASET:
- s = H5Tget_size(H5Dget_type(HID(h5_obj)));
- break;
- case H5I_ATTR:
- s = H5Tget_size(H5Aget_type(HID(h5_obj)));
- break;
- default:
- error("Unknown object in %s.\n", __func__);
- }
- return s;
+ int s = -1;
+ hid_t t = -1;
+ switch (H5Iget_type(HID(h5_obj))) {
+ case H5I_DATASET:
+ t = H5Dget_type(HID(h5_obj));
+ s = H5Tget_size(t);
+ break;
+ case H5I_ATTR:
+ t = H5Aget_type(HID(h5_obj));
+ s = H5Tget_size(t);
+ break;
+ default:
+ error("Unknown object type in %s.\n", __func__);
+ }
+ H5Tclose(t);
+ return s;
}
int _h5R_is_vlen (SEXP h5_obj) {
- hid_t hdty = _h5R_get_type(h5_obj);
- int rval = H5Tis_variable_str(hdty);
- H5Tclose(hdty);
- return rval;
+ hid_t hdty = _h5R_get_type(h5_obj);
+ int rval = H5Tis_variable_str(hdty);
+ H5Tclose(hdty);
+ return rval;
}
int _h5R_get_ndims(SEXP h5_obj) {
- hid_t space = _h5R_get_space(h5_obj);
- int ndims = H5Sget_simple_extent_ndims(space);
- H5Sclose(space);
- return ((ndims < 0) ? 1 : ndims);
+ hid_t space = _h5R_get_space(h5_obj);
+ int ndims = H5Sget_simple_extent_ndims(space);
+ H5Sclose(space);
+ return ((ndims < 0) ? 1 : ndims);
}
int _h5R_get_nelts(SEXP h5_obj) {
@@ -190,6 +218,10 @@
return res;
}
+SEXP h5R_get_object_count(SEXP h5_file) {
+ return ScalarInteger(H5Fget_obj_count(HID(h5_file), H5F_OBJ_ALL));
+}
+
/** ******************************************************************************
*
* Read API
Modified: tests/testMemory.R
===================================================================
--- tests/testMemory.R 2012-10-03 18:53:44 UTC (rev 88)
+++ tests/testMemory.R 2013-01-09 23:16:31 UTC (rev 89)
@@ -9,38 +9,59 @@
## corresponds to me not cleaning something up in HDF5 because
## Valgrind says I'm fine.
##
-## require(h5r)
+## Essentially, this code reproduces the spirit of this post:
+## https://stat.ethz.ch/pipermail/r-devel/2011-September/062025.html
+## Which is related to this false bug:
+## https://bugs.r-project.org/bugzilla3/show_bug.cgi?id=14611
+## the thrust is that with these small allocations you don't allow the
+## Kernel to reclaim memory because the memory becomes "fragmented" -
+## it is not 100% certain to me that R is faultless on this score. I'm
+## finding the forced call of malloc_trim to be necessary in order to
+## actually return the memory to the OS.
+require(h5r)
-## showPS <- function() system(paste('ps -eo pid,vsz,%mem | grep', Sys.getpid()))
-## gcl <- function() { lapply(1:10, gc, verbose = F)[[10]] }
+showPS <- function() system(paste('ps -eo pid,vsz,%mem | grep', Sys.getpid()))
+gcl <- function() { lapply(1:10, gc, verbose = F)[[10]] }
-## showPS()
-## m <- .Call("h5R_allocate_gig")
-## rm(m)
-## gcl()
-## showPS()
+gc()
-## m <- sapply(1:1000, function(a) {
-## .Call("h5R_allocate_meg")
-## })
-## rm(m)
-## gcl()
-## showPS()
+showPS()
+m <- .Call("h5R_allocate_gig")
+b <- 'bar' # from the post, "blocking the memory"
+rm(m)
+gcl()
+showPS()
+h5r:::.mallocTrim()
+showPS()
-## m <- sapply(1:100000, function(a) {
-## .Call("h5R_allocate_k")
-## })
-## rm(m)
-## gcl()
-## showPS()
+m <- sapply(1:1000, function(a) {
+ .Call("h5R_allocate_meg")
+})
+b <- 'bar' # from the post, "blocking the memory"
+rm(m)
+gcl()
+showPS()
+h5r:::.mallocTrim()
+showPS()
-## m <- sapply(1:1000000, function(a) {
-## .Call("h5R_allocate_k")
-## })
-## rm(m)
-## gcl()
-## showPS()
+m <- sapply(1:100000, function(a) {
+ .Call("h5R_allocate_k")
+})
+b <- 'bar' # from the post, "blocking the memory"
+rm(m)
+gcl()
+showPS()
+h5r:::.mallocTrim()
+showPS()
-
+m <- sapply(1:1000000, function(a) {
+ .Call("h5R_allocate_k")
+})
+b <- 'bar' # from the post, "blocking the memory"
+rm(m)
+gcl()
+showPS()
+h5r:::.mallocTrim()
+showPS()
More information about the H5r-commits
mailing list