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