libguile/objcodes.c

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