-/* 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"
-
-#define OBJCODE_COOKIE "GOOF-0.5"
-
-\f
-/*
- * Objcode type
- */
-
-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;
-
- ret = fstat (fd, &st);
- if (ret < 0)
- SCM_SYSERROR;
-
- if (st.st_size <= 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;
-
- 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);
-}
-#undef FUNC_NAME
-
-static scm_sizet
-objcode_free (SCM obj)
-#define FUNC_NAME "objcode_free"
-{
- 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;
-}
-#undef FUNC_NAME
-
-\f
-/*
- * Scheme interface
- */
-
-#if 0
-SCM_DEFINE (scm_do_pair, "do-pair", 2, 0, 0,
- (SCM car, SCM cdr),
- "This is a stupid test to see how cells work. (Ludo)")
-{
- static SCM room[512];
- static SCM *where = &room[0];
- SCM the_pair;
- size_t incr;
-
- if ((scm_t_bits)where & 6)
- {
- /* Align the cell pointer so that Guile considers it as a
- non-immediate object (see tags.h). */
- incr = (scm_t_bits)where & 6;
- incr = (~incr) & 7;
- where += incr;
- }
-
- printf ("do-pair: pool @ %p, pair @ %p\n", &room[0], where);
- where[0] = car;
- where[1] = cdr;
-
- the_pair = PTR2SCM (where);
- /* This doesn't work because SCM_SET_GC_MARK will look for some sort of a
- "mark bitmap" at the end of a supposed cell segment which doesn't
- exist. */
-
- return (the_pair);
-}
-#endif
-
-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_bytecode_to_objcode, "bytecode->objcode", 3, 0, 0,
- (SCM bytecode, SCM nlocs, SCM nexts),
- "")
-#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;
- SCM objcode;
-
- if (scm_u8vector_p (bytecode) != SCM_BOOL_T)
- 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);
-
- scm_array_handle_release (&handle);
-
- 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_u8vector, "objcode->u8vector", 1, 0, 0,
- (SCM objcode),
- "")
-#define FUNC_NAME s_scm_objcode_to_u8vector
-{
- scm_t_uint8 *u8vector;
- size_t size;
-
- SCM_VALIDATE_OBJCODE (1, objcode);
-
- size = SCM_OBJCODE_SIZE (objcode);
- /* FIXME: Is `gc_malloc' ok here? */
- u8vector = scm_gc_malloc (size, "objcode-u8vector");
- memcpy (u8vector, SCM_OBJCODE_BASE (objcode), size);
-
- return scm_take_u8vector (u8vector, size);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_objcode_to_program, "objcode->program", 1, 0, 0,
- (SCM objcode),
- "")
-#define FUNC_NAME s_scm_objcode_to_program
-{
- SCM prog;
- size_t size;
- char *base;
- struct scm_program *p;
-
- SCM_VALIDATE_OBJCODE (1, objcode);
-
- base = SCM_OBJCODE_BASE (objcode);
- size = SCM_OBJCODE_SIZE (objcode);
- prog = scm_c_make_program (base + 10, size - 10, objcode);
- p = SCM_PROGRAM_DATA (prog);
- p->nlocs = base[8];
- p->nexts = base[9];
- return prog;
-}
-#undef FUNC_NAME
-
-\f
-void
-scm_bootstrap_objcodes (void)
-{
- scm_tc16_objcode = scm_make_smob_type ("objcode", 0);
- scm_set_smob_free (scm_tc16_objcode, objcode_free);
-}
-
-void
-scm_init_objcodes (void)
-{
- scm_bootstrap_vm ();
-
-#ifndef SCM_MAGIC_SNARFER
-#include "objcodes.x"
-#endif
-}
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
+/* Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library 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
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+#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 <alignof.h>
+
+#include "_scm.h"
+#include "programs.h"
+#include "objcodes.h"
+
+/* SCM_OBJCODE_COOKIE is defined in _scm.h */
+/* The length of the header must be a multiple of 8 bytes. */
+verify (((sizeof (SCM_OBJCODE_COOKIE) - 1) & 7) == 0);
+
+\f
+/*
+ * Objcode type
+ */
+
+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 (SCM_OBJCODE_COOKIE))
+ scm_misc_error (FUNC_NAME, "object file too small (~a bytes)",
+ scm_list_1 (SCM_I_MAKINUM (st.st_size)));
+
+ addr = mmap (0, st.st_size, PROT_READ, MAP_SHARED, fd, 0);
+ if (addr == MAP_FAILED)
+ {
+ (void) close (fd);
+ SCM_SYSERROR;
+ }
+
+ if (memcmp (addr, SCM_OBJCODE_COOKIE, strlen (SCM_OBJCODE_COOKIE)))
+ {
+ SCM args = scm_list_1 (scm_from_locale_stringn
+ (addr, strlen (SCM_OBJCODE_COOKIE)));
+ (void) close (fd);
+ (void) munmap (addr, st.st_size);
+ scm_misc_error (FUNC_NAME, "bad header on object file: ~s", args);
+ }
+
+ data = (struct scm_objcode*)(addr + strlen (SCM_OBJCODE_COOKIE));
+
+ if (data->len + data->metalen != (st.st_size - sizeof (*data) - strlen (SCM_OBJCODE_COOKIE)))
+ {
+ (void) close (fd);
+ (void) munmap (addr, st.st_size);
+ scm_misc_error (FUNC_NAME, "bad length header (~a, ~a)",
+ scm_list_2 (scm_from_size_t (st.st_size),
+ scm_from_uint32 (sizeof (*data) + data->len
+ + data->metalen)));
+ }
+
+ sret = scm_double_cell (scm_tc7_objcode | (SCM_F_OBJCODE_IS_MMAP<<8),
+ (scm_t_bits)(addr + strlen (SCM_OBJCODE_COOKIE)),
+ SCM_UNPACK (SCM_BOOL_F),
+ (scm_t_bits)fd);
+
+ /* 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, const scm_t_uint8 *ptr)
+#define FUNC_NAME "make-objcode-slice"
+{
+ const struct scm_objcode *data, *parent_data;
+ const scm_t_uint8 *parent_base;
+
+ SCM_VALIDATE_OBJCODE (1, parent);
+ parent_data = SCM_OBJCODE_DATA (parent);
+ parent_base = SCM_C_OBJCODE_BASE (parent_data);
+
+ if (ptr < parent_base
+ || ptr >= (parent_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_list_4 (scm_from_ulong ((unsigned long) ptr),
+ scm_from_ulong ((unsigned long) parent_base),
+ scm_from_uint32 (parent_data->len),
+ scm_from_uint32 (parent_data->metalen)));
+
+ /* Make sure bytecode for the objcode-meta is suitable aligned. Failing to
+ do so leads to SIGBUS/SIGSEGV on some arches (e.g., SPARC). */
+ assert ((((scm_t_bits) ptr) &
+ (alignof_type (struct scm_objcode) - 1UL)) == 0);
+
+ data = (struct scm_objcode*) ptr;
+ assert (SCM_C_OBJCODE_BASE (data) + data->len + data->metalen
+ <= parent_base + parent_data->len + parent_data->metalen);
+
+ return scm_double_cell (scm_tc7_objcode | (SCM_F_OBJCODE_IS_SLICE<<8),
+ (scm_t_bits)data, SCM_UNPACK (parent), 0);
+}
+#undef FUNC_NAME
+
+\f
+/*
+ * Scheme interface
+ */
+
+SCM_DEFINE (scm_objcode_p, "objcode?", 1, 0, 0,
+ (SCM obj),
+ "")
+#define FUNC_NAME s_scm_objcode_p
+{
+ return scm_from_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;
+ const scm_t_uint8 *c_bytecode;
+ struct scm_objcode *data;
+
+ if (!scm_is_bytevector (bytecode))
+ scm_wrong_type_arg (FUNC_NAME, 1, bytecode);
+
+ size = SCM_BYTEVECTOR_LENGTH (bytecode);
+ c_bytecode = (const scm_t_uint8*)SCM_BYTEVECTOR_CONTENTS (bytecode);
+
+ SCM_ASSERT_RANGE (0, bytecode, size >= sizeof(struct scm_objcode));
+ data = (struct scm_objcode*)c_bytecode;
+
+ if (data->len + data->metalen != (size - sizeof (*data)))
+ scm_misc_error (FUNC_NAME, "bad bytevector size (~a != ~a)",
+ scm_list_2 (scm_from_size_t (size),
+ scm_from_uint32 (sizeof (*data) + data->len + data->metalen)));
+
+ /* foolishly, we assume that as long as bytecode is around, that c_bytecode
+ will be of the same length; perhaps a bad assumption? */
+ return scm_double_cell (scm_tc7_objcode | (SCM_F_OBJCODE_IS_BYTEVECTOR<<8),
+ (scm_t_bits)data, SCM_UNPACK (bytecode), 0);
+}
+#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_int8 *s8vector;
+ scm_t_uint32 len;
+
+ SCM_VALIDATE_OBJCODE (1, objcode);
+
+ len = sizeof(struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode);
+
+ s8vector = scm_malloc (len);
+ memcpy (s8vector, SCM_OBJCODE_DATA (objcode), len);
+
+ return scm_c_take_bytevector (s8vector, 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, SCM_OBJCODE_COOKIE, strlen (SCM_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_i_objcode_print (SCM objcode, SCM port, scm_print_state *pstate)
+{
+ scm_puts ("#<objcode ", port);
+ scm_uintprint ((scm_t_bits)SCM_OBJCODE_BASE (objcode), 16, port);
+ scm_puts (">", port);
+}
+
+\f
+void
+scm_bootstrap_objcodes (void)
+{
+ scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+ "scm_init_objcodes",
+ (scm_t_extension_init_func)scm_init_objcodes, NULL);
+}
+
+/* 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)
+{
+#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:
+*/
HCoop / bpt / guile.git / blobdiff