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