libguile/objcodes.c

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