summaryrefslogtreecommitdiff
path: root/libguile/objcodes.c
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2009-03-22 15:28:35 +0100
committerLudovic Courtès <ludo@gnu.org>2009-03-22 15:28:35 +0100
commitd9e59f894e1b41958203ddda7f21f4817cfcfe37 (patch)
treef0d6b0b38ed000aabf327dba4e281c37c60f92a5 /libguile/objcodes.c
parentf307fbcec2cbaaa95b8c861395133b519c7519cf (diff)
parent80540f391498ebb0f955db2fafb6a36ed03b7886 (diff)
downloadguile-d9e59f894e1b41958203ddda7f21f4817cfcfe37.tar.gz
Merge branch 'master' into boehm-demers-weiser-gc
Conflicts: libguile/continuations.c libguile/gc-freelist.c libguile/gc-mark.c libguile/symbols.c libguile/threads.c module/ice-9/boot-9.scm
Diffstat (limited to 'libguile/objcodes.c')
-rw-r--r--libguile/objcodes.c296
1 files changed, 296 insertions, 0 deletions
diff --git a/libguile/objcodes.c b/libguile/objcodes.c
new file mode 100644
index 000000000..3e30b2d60
--- /dev/null
+++ b/libguile/objcodes.c
@@ -0,0 +1,296 @@
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program 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 General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice. */
+
+#if HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <string.h>
+#include <fcntl.h>
+#include <unistd.h>
+#include <sys/mman.h>
+#include <sys/stat.h>
+#include <sys/types.h>
+#include <assert.h>
+
+#include "vm-bootstrap.h"
+#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"
+
+
+/*
+ * Objcode type
+ */
+
+scm_t_bits scm_tc16_objcode;
+
+static SCM
+make_objcode_by_mmap (int fd)
+#define FUNC_NAME "make_objcode_by_mmap"
+{
+ int ret;
+ char *addr;
+ struct stat st;
+ SCM sret = SCM_BOOL_F;
+ struct scm_objcode *data;
+
+ ret = fstat (fd, &st);
+ if (ret < 0)
+ SCM_SYSERROR;
+
+ 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)));
+
+ addr = mmap (0, st.st_size, PROT_READ, MAP_SHARED, fd, 0);
+ if (addr == MAP_FAILED)
+ SCM_SYSERROR;
+
+ if (memcmp (addr, OBJCODE_COOKIE, strlen (OBJCODE_COOKIE)))
+ SCM_SYSERROR;
+
+ data = (struct scm_objcode*)(addr + strlen (OBJCODE_COOKIE));
+
+ if (data->len + data->metalen != (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 (sizeof (*data) + data->len + data->metalen)));
+
+ 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
+
+SCM
+scm_c_make_objcode_slice (SCM parent, scm_t_uint8 *ptr)
+#define FUNC_NAME "make-objcode-slice"
+{
+ 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 + parent_data->metalen
+ - sizeof (struct scm_objcode)))
+ scm_misc_error (FUNC_NAME, "offset out of bounds (~a vs ~a + ~a + ~a)",
+ SCM_LIST4 (scm_from_ulong ((unsigned long)ptr),
+ scm_from_ulong ((unsigned long)parent_data->base),
+ scm_from_uint32 (parent_data->len),
+ scm_from_uint32 (parent_data->metalen)));
+
+ data = (struct scm_objcode*)ptr;
+ if (data->base + data->len + data->metalen > parent_data->base + parent_data->len + parent_data->metalen)
+ 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
+ */
+
+SCM_DEFINE (scm_objcode_p, "objcode?", 1, 0, 0,
+ (SCM obj),
+ "")
+#define FUNC_NAME s_scm_objcode_p
+{
+ return SCM_BOOL (SCM_OBJCODE_P (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_objcode_meta, "objcode-meta", 1, 0, 0,
+ (SCM objcode),
+ "")
+#define FUNC_NAME s_scm_objcode_meta
+{
+ SCM_VALIDATE_OBJCODE (1, objcode);
+
+ if (SCM_OBJCODE_META_LEN (objcode) == 0)
+ return SCM_BOOL_F;
+ else
+ return scm_c_make_objcode_slice (objcode, (SCM_OBJCODE_BASE (objcode)
+ + SCM_OBJCODE_LEN (objcode)));
+}
+#undef FUNC_NAME
+
+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;
+ const scm_t_uint8 *c_bytecode;
+ struct scm_objcode *data;
+ SCM objcode;
+
+ if (scm_is_false (scm_u8vector_p (bytecode)))
+ scm_wrong_type_arg (FUNC_NAME, 1, bytecode);
+
+ c_bytecode = scm_u8vector_elements (bytecode, &handle, &size, &increment);
+ data = (struct scm_objcode*)c_bytecode;
+ SCM_NEWSMOB2 (objcode, scm_tc16_objcode, data, bytecode);
+ scm_array_handle_release (&handle);
+
+ SCM_ASSERT_RANGE (0, bytecode, size >= sizeof(struct scm_objcode));
+ if (data->len + data->metalen != (size - sizeof (*data)))
+ scm_misc_error (FUNC_NAME, "bad u8vector size (~a != ~a)",
+ SCM_LIST2 (scm_from_size_t (size),
+ scm_from_uint32 (sizeof (*data) + data->len + data->metalen)));
+ assert (increment == 1);
+ 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;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_load_objcode, "load-objcode", 1, 0, 0,
+ (SCM file),
+ "")
+#define FUNC_NAME s_scm_load_objcode
+{
+ int fd;
+ char *c_file;
+
+ SCM_VALIDATE_STRING (1, file);
+
+ c_file = scm_to_locale_string (file);
+ fd = open (c_file, O_RDONLY);
+ free (c_file);
+ if (fd < 0) SCM_SYSERROR;
+
+ return make_objcode_by_mmap (fd);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_objcode_to_bytecode, "objcode->bytecode", 1, 0, 0,
+ (SCM objcode),
+ "")
+#define FUNC_NAME s_scm_objcode_to_bytecode
+{
+ scm_t_uint8 *u8vector;
+ scm_t_uint32 len;
+
+ SCM_VALIDATE_OBJCODE (1, objcode);
+
+ len = sizeof(struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode);
+ /* FIXME: Is `gc_malloc' ok here? */
+ u8vector = scm_gc_malloc (len, "objcode-u8vector");
+ memcpy (u8vector, SCM_OBJCODE_DATA (objcode), len);
+
+ return scm_take_u8vector (u8vector, len);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_write_objcode, "write-objcode", 2, 0, 0,
+ (SCM objcode, SCM port),
+ "")
+#define FUNC_NAME s_scm_write_objcode
+{
+ SCM_VALIDATE_OBJCODE (1, objcode);
+ SCM_VALIDATE_OUTPUT_PORT (2, port);
+
+ scm_c_write (port, OBJCODE_COOKIE, strlen (OBJCODE_COOKIE));
+ scm_c_write (port, SCM_OBJCODE_DATA (objcode),
+ sizeof (struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode));
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+void
+scm_bootstrap_objcodes (void)
+{
+ scm_tc16_objcode = scm_make_smob_type ("objcode", 0);
+ scm_set_smob_mark (scm_tc16_objcode, objcode_mark);
+}
+
+/* Before, we used __BYTE_ORDER, but that is not defined on all
+ systems. So punt and use automake, PDP endianness be damned. */
+#ifdef WORDS_BIGENDIAN
+#define SCM_BYTE_ORDER 4321
+#else
+#define SCM_BYTE_ORDER 1234
+#endif
+
+void
+scm_init_objcodes (void)
+{
+ scm_bootstrap_vm ();
+
+#ifndef SCM_MAGIC_SNARFER
+#include "libguile/objcodes.x"
+#endif
+
+ scm_c_define ("word-size", scm_from_size_t (sizeof(SCM)));
+ scm_c_define ("byte-order", scm_from_uint16 (SCM_BYTE_ORDER));
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/