libguile/objcodes.c

   1 /* Copyright (C) 2001, 2009 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 #include <alignof.h>
  31
  32 #include "_scm.h"
  33 #include "vm-bootstrap.h"
  34 #include "programs.h"
  35 #include "objcodes.h"
  36
  37 /* SCM_OBJCODE_COOKIE is defined in _scm.h */
  38 /* The length of the header must be a multiple of 8 bytes.  */
  39 verify (((sizeof (SCM_OBJCODE_COOKIE) - 1) & 7) == 0);
  40
  41 \f
  42 /*
  43  * Objcode type
  44  */
  45
  46 scm_t_bits scm_tc16_objcode;
  47
  48 static SCM
  49 make_objcode_by_mmap (int fd)
  50 #define FUNC_NAME "make_objcode_by_mmap"
  51 {
  52   int ret;
  53   char *addr;
  54   struct stat st;
  55   SCM sret = SCM_BOOL_F;
  56   struct scm_objcode *data;
  57
  58   ret = fstat (fd, &st);
  59   if (ret < 0)
  60     SCM_SYSERROR;
  61
  62   if (st.st_size <= sizeof (struct scm_objcode) + strlen (SCM_OBJCODE_COOKIE))
  63     scm_misc_error (FUNC_NAME, "object file too small (~a bytes)",
  64                     scm_list_1 (SCM_I_MAKINUM (st.st_size)));
  65
  66   addr = mmap (0, st.st_size, PROT_READ, MAP_SHARED, fd, 0);
  67   if (addr == MAP_FAILED)
  68     {
  69       (void) close (fd);
  70       SCM_SYSERROR;
  71     }
  72
  73   if (memcmp (addr, SCM_OBJCODE_COOKIE, strlen (SCM_OBJCODE_COOKIE)))
  74     {
  75       SCM args = scm_list_1 (scm_from_locale_stringn
  76                              (addr, strlen (SCM_OBJCODE_COOKIE)));
  77       (void) close (fd);
  78       (void) munmap (addr, st.st_size);
  79       scm_misc_error (FUNC_NAME, "bad header on object file: ~s", args);
  80     }
  81
  82   data = (struct scm_objcode*)(addr + strlen (SCM_OBJCODE_COOKIE));
  83
  84   if (data->len + data->metalen != (st.st_size - sizeof (*data) - strlen (SCM_OBJCODE_COOKIE)))
  85     {
  86       (void) close (fd);
  87       (void) munmap (addr, st.st_size);
  88       scm_misc_error (FUNC_NAME, "bad length header (~a, ~a)",
  89                       scm_list_2 (scm_from_size_t (st.st_size),
  90                                   scm_from_uint32 (sizeof (*data) + data->len
  91                                                    + data->metalen)));
  92     }
  93
  94   SCM_NEWSMOB3 (sret, scm_tc16_objcode, addr + strlen (SCM_OBJCODE_COOKIE),
  95                 SCM_PACK (SCM_BOOL_F), fd);
  96   SCM_SET_SMOB_FLAGS (sret, SCM_F_OBJCODE_IS_MMAP);
  97
  98   /* FIXME: we leak ourselves and the file descriptor. but then again so does
  99      dlopen(). */
 100   return scm_permanent_object (sret);
 101 }
 102 #undef FUNC_NAME
 103
 104 SCM
 105 scm_c_make_objcode_slice (SCM parent, const scm_t_uint8 *ptr)
 106 #define FUNC_NAME "make-objcode-slice"
 107 {
 108   const struct scm_objcode *data, *parent_data;
 109   const scm_t_uint8 *parent_base;
 110   SCM ret;
 111
 112   SCM_VALIDATE_OBJCODE (1, parent);
 113   parent_data = SCM_OBJCODE_DATA (parent);
 114   parent_base = SCM_C_OBJCODE_BASE (parent_data);
 115
 116   if (ptr < parent_base
 117       || ptr >= (parent_base + parent_data->len + parent_data->metalen
 118                  - sizeof (struct scm_objcode)))
 119     scm_misc_error (FUNC_NAME, "offset out of bounds (~a vs ~a + ~a + ~a)",
 120                     scm_list_4 (scm_from_ulong ((unsigned long) ptr),
 121                                 scm_from_ulong ((unsigned long) parent_base),
 122                                 scm_from_uint32 (parent_data->len),
 123                                 scm_from_uint32 (parent_data->metalen)));
 124
 125   /* Make sure bytecode for the objcode-meta is suitable aligned.  Failing to
 126      do so leads to SIGBUS/SIGSEGV on some arches (e.g., SPARC).  */
 127   assert ((((scm_t_bits) ptr) &
 128            (alignof_type (struct scm_objcode) - 1UL)) == 0);
 129
 130   data = (struct scm_objcode*) ptr;
 131   assert (SCM_C_OBJCODE_BASE (data) + data->len + data->metalen
 132           <= parent_base + parent_data->len + parent_data->metalen);
 133
 134   SCM_NEWSMOB2 (ret, scm_tc16_objcode, data, parent);
 135   SCM_SET_SMOB_FLAGS (ret, SCM_F_OBJCODE_IS_SLICE);
 136   return ret;
 137 }
 138 #undef FUNC_NAME
 139
 140 \f
 141 /*
 142  * Scheme interface
 143  */
 144
 145 SCM_DEFINE (scm_objcode_p, "objcode?", 1, 0, 0,
 146             (SCM obj),
 147             "")
 148 #define FUNC_NAME s_scm_objcode_p
 149 {
 150   return scm_from_bool (SCM_OBJCODE_P (obj));
 151 }
 152 #undef FUNC_NAME
 153
 154 SCM_DEFINE (scm_objcode_meta, "objcode-meta", 1, 0, 0,
 155             (SCM objcode),
 156             "")
 157 #define FUNC_NAME s_scm_objcode_meta
 158 {
 159   SCM_VALIDATE_OBJCODE (1, objcode);
 160
 161   if (SCM_OBJCODE_META_LEN (objcode) == 0)
 162     return SCM_BOOL_F;
 163   else
 164     return scm_c_make_objcode_slice (objcode, (SCM_OBJCODE_BASE (objcode)
 165                                                + SCM_OBJCODE_LEN (objcode)));
 166 }
 167 #undef FUNC_NAME
 168
 169 SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 1, 0, 0,
 170             (SCM bytecode),
 171             "")
 172 #define FUNC_NAME s_scm_bytecode_to_objcode
 173 {
 174   size_t size;
 175   ssize_t increment;
 176   scm_t_array_handle handle;
 177   const scm_t_uint8 *c_bytecode;
 178   struct scm_objcode *data;
 179   SCM objcode;
 180
 181   if (scm_is_false (scm_u8vector_p (bytecode)))
 182     scm_wrong_type_arg (FUNC_NAME, 1, bytecode);
 183
 184   c_bytecode = scm_u8vector_elements (bytecode, &handle, &size, &increment);
 185   data = (struct scm_objcode*)c_bytecode;
 186   SCM_NEWSMOB2 (objcode, scm_tc16_objcode, data, bytecode);
 187   scm_array_handle_release (&handle);
 188
 189   SCM_ASSERT_RANGE (0, bytecode, size >= sizeof(struct scm_objcode));
 190   if (data->len + data->metalen != (size - sizeof (*data)))
 191     scm_misc_error (FUNC_NAME, "bad u8vector size (~a != ~a)",
 192                     scm_list_2 (scm_from_size_t (size),
 193                                 scm_from_uint32 (sizeof (*data) + data->len + data->metalen)));
 194   assert (increment == 1);
 195   SCM_SET_SMOB_FLAGS (objcode, SCM_F_OBJCODE_IS_U8VECTOR);
 196
 197   /* foolishly, we assume that as long as bytecode is around, that c_bytecode
 198      will be of the same length; perhaps a bad assumption? */
 199
 200   return objcode;
 201 }
 202 #undef FUNC_NAME
 203
 204 SCM_DEFINE (scm_load_objcode, "load-objcode", 1, 0, 0,
 205             (SCM file),
 206             "")
 207 #define FUNC_NAME s_scm_load_objcode
 208 {
 209   int fd;
 210   char *c_file;
 211
 212   SCM_VALIDATE_STRING (1, file);
 213
 214   c_file = scm_to_locale_string (file);
 215   fd = open (c_file, O_RDONLY);
 216   free (c_file);
 217   if (fd < 0) SCM_SYSERROR;
 218
 219   return make_objcode_by_mmap (fd);
 220 }
 221 #undef FUNC_NAME
 222
 223 SCM_DEFINE (scm_objcode_to_bytecode, "objcode->bytecode", 1, 0, 0,
 224             (SCM objcode),
 225             "")
 226 #define FUNC_NAME s_scm_objcode_to_bytecode
 227 {
 228   scm_t_uint8 *u8vector;
 229   scm_t_uint32 len;
 230
 231   SCM_VALIDATE_OBJCODE (1, objcode);
 232
 233   len = sizeof(struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode);
 234
 235   u8vector = scm_malloc (len);
 236   memcpy (u8vector, SCM_OBJCODE_DATA (objcode), len);
 237
 238   return scm_take_u8vector (u8vector, len);
 239 }
 240 #undef FUNC_NAME
 241
 242 SCM_DEFINE (scm_write_objcode, "write-objcode", 2, 0, 0,
 243             (SCM objcode, SCM port),
 244             "")
 245 #define FUNC_NAME s_scm_write_objcode
 246 {
 247   SCM_VALIDATE_OBJCODE (1, objcode);
 248   SCM_VALIDATE_OUTPUT_PORT (2, port);
 249
 250   scm_c_write (port, SCM_OBJCODE_COOKIE, strlen (SCM_OBJCODE_COOKIE));
 251   scm_c_write (port, SCM_OBJCODE_DATA (objcode),
 252                sizeof (struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode));
 253
 254   return SCM_UNSPECIFIED;
 255 }
 256 #undef FUNC_NAME
 257
 258 \f
 259 void
 260 scm_bootstrap_objcodes (void)
 261 {
 262   scm_tc16_objcode = scm_make_smob_type ("objcode", 0);
 263   scm_c_register_extension ("libguile", "scm_init_objcodes",
 264                             (scm_t_extension_init_func)scm_init_objcodes, NULL);
 265 }
 266
 267 /* Before, we used __BYTE_ORDER, but that is not defined on all
 268    systems. So punt and use automake, PDP endianness be damned. */
 269 #ifdef WORDS_BIGENDIAN
 270 #define SCM_BYTE_ORDER 4321
 271 #else
 272 #define SCM_BYTE_ORDER 1234
 273 #endif
 274
 275 void
 276 scm_init_objcodes (void)
 277 {
 278   scm_bootstrap_vm ();
 279
 280 #ifndef SCM_MAGIC_SNARFER
 281 #include "libguile/objcodes.x"
 282 #endif
 283
 284   scm_c_define ("word-size", scm_from_size_t (sizeof(SCM)));
 285   scm_c_define ("byte-order", scm_from_uint16 (SCM_BYTE_ORDER));
 286 }
 287
 288 /*
 289   Local Variables:
 290   c-file-style: "gnu"
 291   End:
 292 */