summaryrefslogtreecommitdiff
path: root/libguile/objcodes.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/objcodes.c')
-rw-r--r--libguile/objcodes.c165
1 files changed, 79 insertions, 86 deletions
diff --git a/libguile/objcodes.c b/libguile/objcodes.c
index 10782d443..7ef47b66c 100644
--- a/libguile/objcodes.c
+++ b/libguile/objcodes.c
@@ -55,6 +55,7 @@
#include "programs.h"
#include "objcodes.h"
+/* nb, the length of the header should be a multiple of 8 bytes */
#define OBJCODE_COOKIE "GOOF-0.5"
@@ -65,32 +66,20 @@
scm_t_bits scm_tc16_objcode;
static SCM
-make_objcode (size_t size)
-#define FUNC_NAME "make_objcode"
-{
- struct scm_objcode *p = scm_gc_malloc (sizeof (struct scm_objcode),
- "objcode");
- p->size = size;
- p->base = scm_gc_malloc (size, "objcode-base");
- p->fd = -1;
- SCM_RETURN_NEWSMOB (scm_tc16_objcode, p);
-}
-#undef FUNC_NAME
-
-static SCM
make_objcode_by_mmap (int fd)
#define FUNC_NAME "make_objcode_by_mmap"
{
int ret;
char *addr;
struct stat st;
- struct scm_objcode *p;
+ SCM sret = SCM_BOOL_F;
+ struct scm_objcode *data;
ret = fstat (fd, &st);
if (ret < 0)
SCM_SYSERROR;
- if (st.st_size <= strlen (OBJCODE_COOKIE))
+ if (st.st_size <= sizeof (struct scm_objcode) + strlen (OBJCODE_COOKIE))
scm_misc_error (FUNC_NAME, "object file too small (~a bytes)",
SCM_LIST1 (SCM_I_MAKINUM (st.st_size)));
@@ -101,38 +90,56 @@ make_objcode_by_mmap (int fd)
if (memcmp (addr, OBJCODE_COOKIE, strlen (OBJCODE_COOKIE)))
SCM_SYSERROR;
- p = scm_gc_malloc (sizeof (struct scm_objcode), "objcode");
- p->size = st.st_size;
- p->base = addr;
- p->fd = fd;
- SCM_RETURN_NEWSMOB (scm_tc16_objcode, p);
+ data = (struct scm_objcode*)(addr + strlen (OBJCODE_COOKIE));
+
+ if (data->len != (st.st_size - sizeof (*data) - strlen (OBJCODE_COOKIE)))
+ scm_misc_error (FUNC_NAME, "bad length header (~a, ~a)",
+ SCM_LIST2 (scm_from_size_t (st.st_size),
+ scm_from_uint32 (data->len)));
+
+ SCM_NEWSMOB3 (sret, scm_tc16_objcode, addr + strlen (OBJCODE_COOKIE),
+ SCM_PACK (SCM_BOOL_F), fd);
+ SCM_SET_SMOB_FLAGS (sret, SCM_F_OBJCODE_IS_MMAP);
+
+ /* FIXME: we leak ourselves and the file descriptor. but then again so does
+ dlopen(). */
+ return scm_permanent_object (sret);
}
#undef FUNC_NAME
-static scm_sizet
-objcode_free (SCM obj)
-#define FUNC_NAME "objcode_free"
+SCM
+scm_c_make_objcode_slice (SCM parent, scm_t_uint8 *ptr)
+#define FUNC_NAME "make-objcode-slice"
{
- size_t size = sizeof (struct scm_objcode);
- struct scm_objcode *p = SCM_OBJCODE_DATA (obj);
-
- if (p->fd >= 0)
- {
- int rv;
- rv = munmap (p->base, p->size);
- if (rv < 0) SCM_SYSERROR;
- rv = close (p->fd);
- if (rv < 0) SCM_SYSERROR;
- }
- else
- scm_gc_free (p->base, p->size, "objcode-base");
-
- scm_gc_free (p, size, "objcode");
-
- return 0;
+ struct scm_objcode *data, *parent_data;
+ SCM ret;
+
+ SCM_VALIDATE_OBJCODE (1, parent);
+ parent_data = SCM_OBJCODE_DATA (parent);
+
+ if (ptr < parent_data->base
+ || ptr >= (parent_data->base + parent_data->len
+ - sizeof (struct scm_objcode)))
+ scm_misc_error (FUNC_NAME, "offset out of bounds (~a vs ~a)",
+ SCM_LIST2 (scm_from_ulong ((ulong)ptr),
+ scm_from_uint32 (parent_data->len)));
+
+ data = (struct scm_objcode*)ptr;
+ if (data->base + data->len > parent_data->base + parent_data->len)
+ abort ();
+
+ SCM_NEWSMOB2 (ret, scm_tc16_objcode, data, parent);
+ SCM_SET_SMOB_FLAGS (ret, SCM_F_OBJCODE_IS_SLICE);
+ return ret;
}
#undef FUNC_NAME
+static SCM
+objcode_mark (SCM obj)
+{
+ return SCM_SMOB_OBJECT_2 (obj);
+}
+
/*
* Scheme interface
@@ -147,38 +154,32 @@ SCM_DEFINE (scm_objcode_p, "objcode?", 1, 0, 0,
}
#undef FUNC_NAME
-SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 3, 0, 0,
- (SCM bytecode, SCM nlocs, SCM nexts),
+SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 1, 0, 0,
+ (SCM bytecode),
"")
#define FUNC_NAME s_scm_bytecode_to_objcode
{
size_t size;
ssize_t increment;
scm_t_array_handle handle;
- char *base;
const scm_t_uint8 *c_bytecode;
+ struct scm_objcode *data;
SCM objcode;
- if (scm_u8vector_p (bytecode) != SCM_BOOL_T)
+ if (scm_is_false (scm_u8vector_p (bytecode)))
scm_wrong_type_arg (FUNC_NAME, 1, bytecode);
- SCM_VALIDATE_NUMBER (2, nlocs);
- SCM_VALIDATE_NUMBER (3, nexts);
c_bytecode = scm_u8vector_elements (bytecode, &handle, &size, &increment);
- assert (increment == 1);
-
- /* Account for the 10 byte-long header. */
- size += 10;
- objcode = make_objcode (size);
- base = SCM_OBJCODE_BASE (objcode);
-
- memcpy (base, OBJCODE_COOKIE, 8);
- base[8] = scm_to_uint8 (nlocs);
- base[9] = scm_to_uint8 (nexts);
-
- memcpy (base + 10, c_bytecode, size - 10);
-
+ data = (struct scm_objcode*)c_bytecode;
+ SCM_NEWSMOB2 (objcode, scm_tc16_objcode, data, bytecode);
scm_array_handle_release (&handle);
+ assert (increment == 1);
+ SCM_ASSERT_RANGE (0, bytecode, size < 1<<31);
+ SCM_ASSERT_RANGE (0, bytecode, size >= sizeof(*data));
+ SCM_SET_SMOB_FLAGS (objcode, SCM_F_OBJCODE_IS_U8VECTOR);
+
+ /* foolishly, we assume that as long as bytecode is around, that c_bytecode
+ will be of the same length; perhaps a bad assumption? */
return objcode;
}
@@ -209,43 +210,32 @@ SCM_DEFINE (scm_objcode_to_u8vector, "objcode->u8vector", 1, 0, 0,
#define FUNC_NAME s_scm_objcode_to_u8vector
{
scm_t_uint8 *u8vector;
- size_t size;
+ scm_t_uint32 len;
SCM_VALIDATE_OBJCODE (1, objcode);
- size = SCM_OBJCODE_SIZE (objcode);
+ len = SCM_OBJCODE_DATA (objcode)->len + sizeof(struct scm_objcode);
/* FIXME: Is `gc_malloc' ok here? */
- u8vector = scm_gc_malloc (size, "objcode-u8vector");
- memcpy (u8vector, SCM_OBJCODE_BASE (objcode), size);
+ u8vector = scm_gc_malloc (len, "objcode-u8vector");
+ memcpy (u8vector, SCM_OBJCODE_DATA (objcode), len);
- return scm_take_u8vector (u8vector, size);
+ return scm_take_u8vector (u8vector, len);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_objcode_to_program, "objcode->program", 1, 1, 0,
- (SCM objcode, SCM external),
+SCM_DEFINE (scm_write_objcode, "write-objcode", 2, 0, 0,
+ (SCM objcode, SCM port),
"")
-#define FUNC_NAME s_scm_objcode_to_program
+#define FUNC_NAME s_scm_write_objcode
{
- SCM prog;
- size_t size;
- char *base;
- struct scm_program *p;
-
SCM_VALIDATE_OBJCODE (1, objcode);
- if (SCM_UNBNDP (external))
- external = SCM_EOL;
- else
- SCM_VALIDATE_LIST (2, external);
-
- base = SCM_OBJCODE_BASE (objcode);
- size = SCM_OBJCODE_SIZE (objcode);
- prog = scm_c_make_program (base + 10, size - 10, SCM_BOOL_F, objcode);
- p = SCM_PROGRAM_DATA (prog);
- p->nlocs = base[8];
- p->nexts = base[9];
- p->external = external;
- return prog;
+ SCM_VALIDATE_OUTPUT_PORT (2, port);
+
+ scm_c_write (port, OBJCODE_COOKIE, strlen (OBJCODE_COOKIE));
+ scm_c_write (port, SCM_OBJCODE_DATA (objcode),
+ SCM_OBJCODE_LEN (objcode) + sizeof (struct scm_objcode));
+
+ return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -254,7 +244,7 @@ void
scm_bootstrap_objcodes (void)
{
scm_tc16_objcode = scm_make_smob_type ("objcode", 0);
- scm_set_smob_free (scm_tc16_objcode, objcode_free);
+ scm_set_smob_mark (scm_tc16_objcode, objcode_mark);
}
void
@@ -265,6 +255,9 @@ scm_init_objcodes (void)
#ifndef SCM_MAGIC_SNARFER
#include "objcodes.x"
#endif
+
+ scm_c_define ("word-size", scm_from_size_t (sizeof(SCM)));
+ scm_c_define ("byte-order", scm_from_uint16 (__BYTE_ORDER));
}
/*