libguile/objcodes.c

   1 /* Copyright (C) 2001 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  41
  42 #if HAVE_CONFIG_H
  43 #  include <config.h>
  44 #endif
  45
  46 #include <string.h>
  47 #include <fcntl.h>
  48 #include <unistd.h>
  49 #include <sys/mman.h>
  50 #include <sys/stat.h>
  51 #include <sys/types.h>
  52 #include <assert.h>
  53
  54 #include "vm-bootstrap.h"
  55 #include "programs.h"
  56 #include "objcodes.h"
  57
  58 /* nb, the length of the header should be a multiple of 8 bytes */
  59 #define OBJCODE_COOKIE "GOOF-0.5"
  60
  61 \f
  62 /*
  63  * Objcode type
  64  */
  65
  66 scm_t_bits scm_tc16_objcode;
  67
  68 static SCM
  69 make_objcode_by_mmap (int fd)
  70 #define FUNC_NAME "make_objcode_by_mmap"
  71 {
  72   int ret;
  73   char *addr;
  74   struct stat st;
  75   SCM sret = SCM_BOOL_F;
  76   struct scm_objcode *data;
  77
  78   ret = fstat (fd, &st);
  79   if (ret < 0)
  80     SCM_SYSERROR;
  81
  82   if (st.st_size <= sizeof (struct scm_objcode) + strlen (OBJCODE_COOKIE))
  83     scm_misc_error (FUNC_NAME, "object file too small (~a bytes)",
  84                     SCM_LIST1 (SCM_I_MAKINUM (st.st_size)));
  85
  86   addr = mmap (0, st.st_size, PROT_READ, MAP_SHARED, fd, 0);
  87   if (addr == MAP_FAILED)
  88     SCM_SYSERROR;
  89
  90   if (memcmp (addr, OBJCODE_COOKIE, strlen (OBJCODE_COOKIE)))
  91     SCM_SYSERROR;
  92
  93   data = (struct scm_objcode*)(addr + strlen (OBJCODE_COOKIE));
  94
  95   if (data->len + data->metalen != (st.st_size - sizeof (*data) - strlen (OBJCODE_COOKIE)))
  96     scm_misc_error (FUNC_NAME, "bad length header (~a, ~a)",
  97                     SCM_LIST2 (scm_from_size_t (st.st_size),
  98                                scm_from_uint32 (sizeof (*data) + data->len + data->metalen)));
  99
 100   SCM_NEWSMOB3 (sret, scm_tc16_objcode, addr + strlen (OBJCODE_COOKIE),
 101                 SCM_PACK (SCM_BOOL_F), fd);
 102   SCM_SET_SMOB_FLAGS (sret, SCM_F_OBJCODE_IS_MMAP);
 103
 104   /* FIXME: we leak ourselves and the file descriptor. but then again so does
 105      dlopen(). */
 106   return scm_permanent_object (sret);
 107 }
 108 #undef FUNC_NAME
 109
 110 SCM
 111 scm_c_make_objcode_slice (SCM parent, scm_t_uint8 *ptr)
 112 #define FUNC_NAME "make-objcode-slice"
 113 {
 114   struct scm_objcode *data, *parent_data;
 115   SCM ret;
 116
 117   SCM_VALIDATE_OBJCODE (1, parent);
 118   parent_data = SCM_OBJCODE_DATA (parent);
 119
 120   if (ptr < parent_data->base
 121       || ptr >= (parent_data->base + parent_data->len + parent_data->metalen
 122                  - sizeof (struct scm_objcode)))
 123     scm_misc_error (FUNC_NAME, "offset out of bounds (~a vs ~a + ~a + ~a)",
 124                     SCM_LIST4 (scm_from_ulong ((ulong)ptr),
 125                                scm_from_ulong ((ulong)parent_data->base),
 126                                scm_from_uint32 (parent_data->len),
 127                                scm_from_uint32 (parent_data->metalen)));
 128
 129   data = (struct scm_objcode*)ptr;
 130   if (data->base + data->len + data->metalen > parent_data->base + parent_data->len + parent_data->metalen)
 131     abort ();
 132
 133   SCM_NEWSMOB2 (ret, scm_tc16_objcode, data, parent);
 134   SCM_SET_SMOB_FLAGS (ret, SCM_F_OBJCODE_IS_SLICE);
 135   return ret;
 136 }
 137 #undef FUNC_NAME
 138
 139 static SCM
 140 objcode_mark (SCM obj)
 141 {
 142   return SCM_SMOB_OBJECT_2 (obj);
 143 }
 144
 145 \f
 146 /*
 147  * Scheme interface
 148  */
 149
 150 SCM_DEFINE (scm_objcode_p, "objcode?", 1, 0, 0,
 151             (SCM obj),
 152             "")
 153 #define FUNC_NAME s_scm_objcode_p
 154 {
 155   return SCM_BOOL (SCM_OBJCODE_P (obj));
 156 }
 157 #undef FUNC_NAME
 158
 159 SCM_DEFINE (scm_objcode_meta, "objcode-meta", 1, 0, 0,
 160             (SCM objcode),
 161             "")
 162 #define FUNC_NAME s_scm_objcode_meta
 163 {
 164   SCM_VALIDATE_OBJCODE (1, objcode);
 165
 166   if (SCM_OBJCODE_META_LEN (objcode) == 0)
 167     return SCM_BOOL_F;
 168   else
 169     return scm_c_make_objcode_slice (objcode, (SCM_OBJCODE_BASE (objcode)
 170                                                + SCM_OBJCODE_LEN (objcode)));
 171 }
 172 #undef FUNC_NAME
 173
 174 SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 1, 0, 0,
 175             (SCM bytecode),
 176             "")
 177 #define FUNC_NAME s_scm_bytecode_to_objcode
 178 {
 179   size_t size;
 180   ssize_t increment;
 181   scm_t_array_handle handle;
 182   const scm_t_uint8 *c_bytecode;
 183   struct scm_objcode *data;
 184   SCM objcode;
 185
 186   if (scm_is_false (scm_u8vector_p (bytecode)))
 187     scm_wrong_type_arg (FUNC_NAME, 1, bytecode);
 188
 189   c_bytecode = scm_u8vector_elements (bytecode, &handle, &size, &increment);
 190   data = (struct scm_objcode*)c_bytecode;
 191   SCM_NEWSMOB2 (objcode, scm_tc16_objcode, data, bytecode);
 192   scm_array_handle_release (&handle);
 193
 194   SCM_ASSERT_RANGE (0, bytecode, size >= sizeof(struct scm_objcode));
 195   if (data->len + data->metalen != (size - sizeof (*data)))
 196     scm_misc_error (FUNC_NAME, "bad u8vector size (~a != ~a)",
 197                     SCM_LIST2 (scm_from_size_t (size),
 198                                scm_from_uint32 (sizeof (*data) + data->len + data->metalen)));
 199   assert (increment == 1);
 200   SCM_SET_SMOB_FLAGS (objcode, SCM_F_OBJCODE_IS_U8VECTOR);
 201
 202   /* foolishly, we assume that as long as bytecode is around, that c_bytecode
 203      will be of the same length; perhaps a bad assumption? */
 204
 205   return objcode;
 206 }
 207 #undef FUNC_NAME
 208
 209 SCM_DEFINE (scm_load_objcode, "load-objcode", 1, 0, 0,
 210             (SCM file),
 211             "")
 212 #define FUNC_NAME s_scm_load_objcode
 213 {
 214   int fd;
 215   char *c_file;
 216
 217   SCM_VALIDATE_STRING (1, file);
 218
 219   c_file = scm_to_locale_string (file);
 220   fd = open (c_file, O_RDONLY);
 221   free (c_file);
 222   if (fd < 0) SCM_SYSERROR;
 223
 224   return make_objcode_by_mmap (fd);
 225 }
 226 #undef FUNC_NAME
 227
 228 SCM_DEFINE (scm_objcode_to_bytecode, "objcode->bytecode", 1, 0, 0,
 229             (SCM objcode),
 230             "")
 231 #define FUNC_NAME s_scm_objcode_to_bytecode
 232 {
 233   scm_t_uint8 *u8vector;
 234   scm_t_uint32 len;
 235
 236   SCM_VALIDATE_OBJCODE (1, objcode);
 237
 238   len = sizeof(struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode);
 239   /* FIXME:  Is `gc_malloc' ok here? */
 240   u8vector = scm_gc_malloc (len, "objcode-u8vector");
 241   memcpy (u8vector, SCM_OBJCODE_DATA (objcode), len);
 242
 243   return scm_take_u8vector (u8vector, len);
 244 }
 245 #undef FUNC_NAME
 246
 247 SCM_DEFINE (scm_write_objcode, "write-objcode", 2, 0, 0,
 248             (SCM objcode, SCM port),
 249             "")
 250 #define FUNC_NAME s_scm_write_objcode
 251 {
 252   SCM_VALIDATE_OBJCODE (1, objcode);
 253   SCM_VALIDATE_OUTPUT_PORT (2, port);
 254
 255   scm_c_write (port, OBJCODE_COOKIE, strlen (OBJCODE_COOKIE));
 256   scm_c_write (port, SCM_OBJCODE_DATA (objcode),
 257                sizeof (struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode));
 258
 259   return SCM_UNSPECIFIED;
 260 }
 261 #undef FUNC_NAME
 262
 263 \f
 264 void
 265 scm_bootstrap_objcodes (void)
 266 {
 267   scm_tc16_objcode = scm_make_smob_type ("objcode", 0);
 268   scm_set_smob_mark (scm_tc16_objcode, objcode_mark);
 269 }
 270
 271 void
 272 scm_init_objcodes (void)
 273 {
 274   scm_bootstrap_vm ();
 275
 276 #ifndef SCM_MAGIC_SNARFER
 277 #include "objcodes.x"
 278 #endif
 279
 280   scm_c_define ("word-size", scm_from_size_t (sizeof(SCM)));
 281   scm_c_define ("byte-order", scm_from_uint16 (__BYTE_ORDER));
 282 }
 283
 284 /*
 285   Local Variables:
 286   c-file-style: "gnu"
 287   End:
 288 */