libguile/objcodes.c

   1 /* Copyright (C) 2001 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public License
   5  * as published by the Free Software Foundation; either version 3 of
   6  * the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful, but
   9  * WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  16  * 02110-1301 USA
  17  */
  18
  19 #if HAVE_CONFIG_H
  20 #  include <config.h>
  21 #endif
  22
  23 #include <string.h>
  24 #include <fcntl.h>
  25 #include <unistd.h>
  26 #include <sys/mman.h>
  27 #include <sys/stat.h>
  28 #include <sys/types.h>
  29 #include <assert.h>
  30
  31 #include "_scm.h"
  32 #include "vm-bootstrap.h"
  33 #include "programs.h"
  34 #include "objcodes.h"
  35
  36 /* nb, the length of the header should be a multiple of 8 bytes */
  37 #define OBJCODE_COOKIE "GOOF-0.5"
  38
  39 \f
  40 /*
  41  * Objcode type
  42  */
  43
  44 scm_t_bits scm_tc16_objcode;
  45
  46 static SCM
  47 make_objcode_by_mmap (int fd)
  48 #define FUNC_NAME "make_objcode_by_mmap"
  49 {
  50   int ret;
  51   char *addr;
  52   struct stat st;
  53   SCM sret = SCM_BOOL_F;
  54   struct scm_objcode *data;
  55
  56   ret = fstat (fd, &st);
  57   if (ret < 0)
  58     SCM_SYSERROR;
  59
  60   if (st.st_size <= sizeof (struct scm_objcode) + strlen (OBJCODE_COOKIE))
  61     scm_misc_error (FUNC_NAME, "object file too small (~a bytes)",
  62                     scm_list_1 (SCM_I_MAKINUM (st.st_size)));
  63
  64   addr = mmap (0, st.st_size, PROT_READ, MAP_SHARED, fd, 0);
  65   if (addr == MAP_FAILED)
  66     SCM_SYSERROR;
  67
  68   if (memcmp (addr, OBJCODE_COOKIE, strlen (OBJCODE_COOKIE)))
  69     SCM_SYSERROR;
  70
  71   data = (struct scm_objcode*)(addr + strlen (OBJCODE_COOKIE));
  72
  73   if (data->len + data->metalen != (st.st_size - sizeof (*data) - strlen (OBJCODE_COOKIE)))
  74     scm_misc_error (FUNC_NAME, "bad length header (~a, ~a)",
  75                     scm_list_2 (scm_from_size_t (st.st_size),
  76                                 scm_from_uint32 (sizeof (*data) + data->len + data->metalen)));
  77
  78   SCM_NEWSMOB3 (sret, scm_tc16_objcode, addr + strlen (OBJCODE_COOKIE),
  79                 SCM_PACK (SCM_BOOL_F), fd);
  80   SCM_SET_SMOB_FLAGS (sret, SCM_F_OBJCODE_IS_MMAP);
  81
  82   /* FIXME: we leak ourselves and the file descriptor. but then again so does
  83      dlopen(). */
  84   return scm_permanent_object (sret);
  85 }
  86 #undef FUNC_NAME
  87
  88 SCM
  89 scm_c_make_objcode_slice (SCM parent, scm_t_uint8 *ptr)
  90 #define FUNC_NAME "make-objcode-slice"
  91 {
  92   struct scm_objcode *data, *parent_data;
  93   SCM ret;
  94
  95   SCM_VALIDATE_OBJCODE (1, parent);
  96   parent_data = SCM_OBJCODE_DATA (parent);
  97
  98   if (ptr < parent_data->base
  99       || ptr >= (parent_data->base + parent_data->len + parent_data->metalen
 100                  - sizeof (struct scm_objcode)))
 101     scm_misc_error (FUNC_NAME, "offset out of bounds (~a vs ~a + ~a + ~a)",
 102                     scm_list_4 (scm_from_ulong ((unsigned long)ptr),
 103                                 scm_from_ulong ((unsigned long)parent_data->base),
 104                                 scm_from_uint32 (parent_data->len),
 105                                 scm_from_uint32 (parent_data->metalen)));
 106
 107   data = (struct scm_objcode*)ptr;
 108   if (data->base + data->len + data->metalen > parent_data->base + parent_data->len + parent_data->metalen)
 109     abort ();
 110
 111   SCM_NEWSMOB2 (ret, scm_tc16_objcode, data, parent);
 112   SCM_SET_SMOB_FLAGS (ret, SCM_F_OBJCODE_IS_SLICE);
 113   return ret;
 114 }
 115 #undef FUNC_NAME
 116
 117 static SCM
 118 objcode_mark (SCM obj)
 119 {
 120   return SCM_SMOB_OBJECT_2 (obj);
 121 }
 122
 123 \f
 124 /*
 125  * Scheme interface
 126  */
 127
 128 SCM_DEFINE (scm_objcode_p, "objcode?", 1, 0, 0,
 129             (SCM obj),
 130             "")
 131 #define FUNC_NAME s_scm_objcode_p
 132 {
 133   return SCM_BOOL (SCM_OBJCODE_P (obj));
 134 }
 135 #undef FUNC_NAME
 136
 137 SCM_DEFINE (scm_objcode_meta, "objcode-meta", 1, 0, 0,
 138             (SCM objcode),
 139             "")
 140 #define FUNC_NAME s_scm_objcode_meta
 141 {
 142   SCM_VALIDATE_OBJCODE (1, objcode);
 143
 144   if (SCM_OBJCODE_META_LEN (objcode) == 0)
 145     return SCM_BOOL_F;
 146   else
 147     return scm_c_make_objcode_slice (objcode, (SCM_OBJCODE_BASE (objcode)
 148                                                + SCM_OBJCODE_LEN (objcode)));
 149 }
 150 #undef FUNC_NAME
 151
 152 SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 1, 0, 0,
 153             (SCM bytecode),
 154             "")
 155 #define FUNC_NAME s_scm_bytecode_to_objcode
 156 {
 157   size_t size;
 158   ssize_t increment;
 159   scm_t_array_handle handle;
 160   const scm_t_uint8 *c_bytecode;
 161   struct scm_objcode *data;
 162   SCM objcode;
 163
 164   if (scm_is_false (scm_u8vector_p (bytecode)))
 165     scm_wrong_type_arg (FUNC_NAME, 1, bytecode);
 166
 167   c_bytecode = scm_u8vector_elements (bytecode, &handle, &size, &increment);
 168   data = (struct scm_objcode*)c_bytecode;
 169   SCM_NEWSMOB2 (objcode, scm_tc16_objcode, data, bytecode);
 170   scm_array_handle_release (&handle);
 171
 172   SCM_ASSERT_RANGE (0, bytecode, size >= sizeof(struct scm_objcode));
 173   if (data->len + data->metalen != (size - sizeof (*data)))
 174     scm_misc_error (FUNC_NAME, "bad u8vector size (~a != ~a)",
 175                     scm_list_2 (scm_from_size_t (size),
 176                                 scm_from_uint32 (sizeof (*data) + data->len + data->metalen)));
 177   assert (increment == 1);
 178   SCM_SET_SMOB_FLAGS (objcode, SCM_F_OBJCODE_IS_U8VECTOR);
 179
 180   /* foolishly, we assume that as long as bytecode is around, that c_bytecode
 181      will be of the same length; perhaps a bad assumption? */
 182
 183   return objcode;
 184 }
 185 #undef FUNC_NAME
 186
 187 SCM_DEFINE (scm_load_objcode, "load-objcode", 1, 0, 0,
 188             (SCM file),
 189             "")
 190 #define FUNC_NAME s_scm_load_objcode
 191 {
 192   int fd;
 193   char *c_file;
 194
 195   SCM_VALIDATE_STRING (1, file);
 196
 197   c_file = scm_to_locale_string (file);
 198   fd = open (c_file, O_RDONLY);
 199   free (c_file);
 200   if (fd < 0) SCM_SYSERROR;
 201
 202   return make_objcode_by_mmap (fd);
 203 }
 204 #undef FUNC_NAME
 205
 206 SCM_DEFINE (scm_objcode_to_bytecode, "objcode->bytecode", 1, 0, 0,
 207             (SCM objcode),
 208             "")
 209 #define FUNC_NAME s_scm_objcode_to_bytecode
 210 {
 211   scm_t_uint8 *u8vector;
 212   scm_t_uint32 len;
 213
 214   SCM_VALIDATE_OBJCODE (1, objcode);
 215
 216   len = sizeof(struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode);
 217   /* FIXME:  Is `gc_malloc' ok here? */
 218   u8vector = scm_gc_malloc (len, "objcode-u8vector");
 219   memcpy (u8vector, SCM_OBJCODE_DATA (objcode), len);
 220
 221   return scm_take_u8vector (u8vector, len);
 222 }
 223 #undef FUNC_NAME
 224
 225 SCM_DEFINE (scm_write_objcode, "write-objcode", 2, 0, 0,
 226             (SCM objcode, SCM port),
 227             "")
 228 #define FUNC_NAME s_scm_write_objcode
 229 {
 230   SCM_VALIDATE_OBJCODE (1, objcode);
 231   SCM_VALIDATE_OUTPUT_PORT (2, port);
 232
 233   scm_c_write (port, OBJCODE_COOKIE, strlen (OBJCODE_COOKIE));
 234   scm_c_write (port, SCM_OBJCODE_DATA (objcode),
 235                sizeof (struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode));
 236
 237   return SCM_UNSPECIFIED;
 238 }
 239 #undef FUNC_NAME
 240
 241 \f
 242 void
 243 scm_bootstrap_objcodes (void)
 244 {
 245   scm_tc16_objcode = scm_make_smob_type ("objcode", 0);
 246   scm_set_smob_mark (scm_tc16_objcode, objcode_mark);
 247   scm_c_register_extension ("libguile", "scm_init_objcodes",
 248                             (scm_t_extension_init_func)scm_init_objcodes, NULL);
 249 }
 250
 251 /* Before, we used __BYTE_ORDER, but that is not defined on all
 252    systems. So punt and use automake, PDP endianness be damned. */
 253 #ifdef WORDS_BIGENDIAN
 254 #define SCM_BYTE_ORDER 4321
 255 #else
 256 #define SCM_BYTE_ORDER 1234
 257 #endif
 258
 259 void
 260 scm_init_objcodes (void)
 261 {
 262   scm_bootstrap_vm ();
 263
 264 #ifndef SCM_MAGIC_SNARFER
 265 #include "libguile/objcodes.x"
 266 #endif
 267
 268   scm_c_define ("word-size", scm_from_size_t (sizeof(SCM)));
 269   scm_c_define ("byte-order", scm_from_uint16 (SCM_BYTE_ORDER));
 270 }
 271
 272 /*
 273   Local Variables:
 274   c-file-style: "gnu"
 275   End:
 276 */