libguile/dump.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 \f
  43
  44 #include <string.h>
  45 #include <unistd.h>
  46 #include <sys/mman.h>
  47 #include <sys/stat.h>
  48 #include <sys/types.h>
  49
  50 #include "libguile/_scm.h"
  51 #include "libguile/tags.h"
  52 #include "libguile/root.h"
  53 #include "libguile/alist.h"
  54 #include "libguile/smob.h"
  55 #include "libguile/ports.h"
  56 #include "libguile/fports.h"
  57 #include "libguile/strings.h"
  58 #include "libguile/hashtab.h"
  59 #include "libguile/vectors.h"
  60 #include "libguile/validate.h"
  61 #include "libguile/dump.h"
  62
  63 #define SCM_DUMP_COOKIE                 "\x7fGBF-0.1"
  64
  65 #define SCM_DUMP_HASH_SIZE              151
  66 #define SCM_DUMP_IMAGE_SIZE             4096
  67
  68 #define SCM_DUMP_INDEX_TO_WORD(x)       ((scm_bits_t) ((x) << 3))
  69 #define SCM_DUMP_WORD_TO_INDEX(x)       ((long) ((x) >> 3))
  70
  71 struct scm_dump_header {
  72   scm_bits_t cookie;                    /* cookie string */
  73   scm_bits_t version;                   /* version string */
  74   scm_bits_t nobjs;                     /* the number of objects */
  75                                         /* or immediate value */
  76 };
  77
  78 \f
  79 /*
  80  * Dump state
  81  */
  82
  83 static scm_bits_t scm_tc16_dstate;
  84
  85 struct scm_dstate {
  86   int mmapped;
  87   scm_sizet image_size;
  88   int image_index;
  89   char *image_base;             /* Memory image */
  90   int table_index;
  91   SCM table;                    /* Object table */
  92   SCM task;                     /* Update task */
  93 };
  94
  95 #define SCM_DSTATE_DATA(d)          ((struct scm_dstate *) SCM_SMOB_DATA (d))
  96 #define SCM_DSTATE_TABLE(d)         (SCM_DSTATE_DATA (d)->table)
  97 #define SCM_DSTATE_TABLE_REF(d,i)   (SCM_VELTS (SCM_DSTATE_TABLE (d))[i])
  98 #define SCM_DSTATE_TABLE_SET(d,i,x) (SCM_VELTS (SCM_DSTATE_TABLE (d))[i] = (x))
  99 #define SCM_DSTATE_TASK(d)          (SCM_DSTATE_DATA (d)->task)
 100
 101 #define SCM_DTASK_ID(t)             ((scm_bits_t) SCM_CELL_WORD_1 (t))
 102 #define SCM_DTASK_ADDR(t)           ((scm_bits_t *) SCM_CELL_WORD_2 (t))
 103 #define SCM_DTASK_NEXT(t)           (SCM_CELL_OBJECT_3 (t))
 104 #define SCM_SET_DTASK_ID(t,x)       SCM_SET_CELL_WORD_1 (t, x)
 105 #define SCM_SET_DTASK_ADDR(t,x)     SCM_SET_CELL_WORD_2 (t, x)
 106 #define SCM_SET_DTASK_NEXT(t,x)     SCM_SET_CELL_OBJECT_3 (t, x)
 107
 108 static SCM
 109 make_dstate ()
 110 #define FUNC_NAME "make_dstate"
 111 {
 112   struct scm_dstate *p = SCM_MUST_MALLOC (sizeof (struct scm_dstate));
 113   p->mmapped     = 0;
 114   p->image_size  = SCM_DUMP_IMAGE_SIZE;
 115   p->image_index = 0;
 116   p->image_base  = SCM_MUST_MALLOC (p->image_size);
 117   p->table_index = 0;
 118   p->table       = SCM_BOOL_F;
 119   p->task        = SCM_EOL;
 120   SCM_RETURN_NEWSMOB (scm_tc16_dstate, p);
 121 }
 122 #undef FUNC_NAME
 123
 124 static SCM
 125 make_dstate_by_mmap (int fd)
 126 #define FUNC_NAME "make_dstate_by_mmap"
 127 {
 128   int ret;
 129   char *addr;
 130   struct stat st;
 131   struct scm_dstate *p = SCM_MUST_MALLOC (sizeof (struct scm_dstate));
 132
 133   SCM_SYSCALL (ret = fstat (fd, &st));
 134   if (ret < 0)
 135     SCM_SYSERROR;
 136
 137   SCM_SYSCALL (addr = mmap (0, st.st_size, PROT_READ, MAP_SHARED, fd, 0));
 138   if (addr == MAP_FAILED)
 139     SCM_SYSERROR;
 140
 141   p->mmapped     = 1;
 142   p->image_size  = st.st_size;
 143   p->image_index = 0;
 144   p->image_base  = addr;
 145   p->table_index = 0;
 146   p->table       = SCM_BOOL_F;
 147   p->task        = SCM_EOL;
 148   SCM_RETURN_NEWSMOB (scm_tc16_dstate, p);
 149 }
 150 #undef FUNC_NAME
 151
 152 static SCM
 153 dstate_mark (SCM obj)
 154 {
 155   SCM task;
 156   struct scm_dstate *p = SCM_DSTATE_DATA (obj);
 157   for (task = p->task; !SCM_NULLP (task); task = SCM_DTASK_NEXT (task))
 158     scm_gc_mark (task);
 159   return p->table;
 160 }
 161
 162 static scm_sizet
 163 dstate_free (SCM obj)
 164 #define FUNC_NAME "dstate_free"
 165 {
 166   int size = sizeof (struct scm_dstate);
 167   struct scm_dstate *p = SCM_DSTATE_DATA (obj);
 168
 169   /* Free dump image */
 170   if (p->mmapped)
 171     {
 172       int rv;
 173       SCM_SYSCALL (rv = munmap (p->image_base, p->image_size));
 174       if (rv < 0)
 175         SCM_SYSERROR;
 176     }
 177   else
 178     {
 179       size += p->image_size;
 180       if (p->image_base)
 181         scm_must_free (p->image_base);
 182     }
 183
 184   scm_must_free (p);
 185   return size;
 186 }
 187 #undef FUNC_NAME
 188
 189 static void
 190 dstate_extend (struct scm_dstate *p)
 191 {
 192   scm_sizet old_size = p->image_size;
 193   p->image_size *= 2;
 194   p->image_base = scm_must_realloc (p->image_base,
 195                                     old_size,
 196                                     p->image_size,
 197                                     "dstate_extend");
 198 }
 199
 200 \f
 201 /*
 202  * Object indicator
 203  */
 204
 205 static scm_bits_t
 206 scm_object_indicator (SCM obj, SCM dstate)
 207 {
 208   if (SCM_IMP (obj))
 209     {
 210       return SCM_UNPACK (obj);
 211     }
 212   else
 213     {
 214       SCM id = scm_hashq_ref (SCM_DSTATE_TABLE (dstate), obj, SCM_BOOL_F);
 215       if (SCM_FALSEP (id))
 216         return -1;
 217       else
 218         return SCM_DUMP_INDEX_TO_WORD (SCM_INUM (id));
 219     }
 220 }
 221
 222 static SCM
 223 scm_indicator_object (scm_bits_t word, SCM dstate)
 224 {
 225   if (SCM_IMP (SCM_PACK (word)))
 226     return SCM_PACK (word);
 227   else
 228     return SCM_DSTATE_TABLE_REF (dstate, SCM_DUMP_WORD_TO_INDEX (word));
 229 }
 230
 231 \f
 232 /*
 233  * Dump interface
 234  */
 235
 236 /* store functions */
 237
 238 static void
 239 scm_store_pad (SCM dstate)
 240 {
 241   struct scm_dstate *p = SCM_DSTATE_DATA (dstate);
 242   while (p->image_index + sizeof (scm_bits_t) >= p->image_size)
 243     dstate_extend (p);
 244   while (p->image_index % sizeof (scm_bits_t) != 0)
 245     p->image_base[p->image_index++] = '\0';
 246 }
 247
 248 void
 249 scm_store_word (const scm_bits_t word, SCM dstate)
 250 {
 251   struct scm_dstate *p = SCM_DSTATE_DATA (dstate);
 252   while (p->image_index + sizeof (scm_bits_t) >= p->image_size)
 253     dstate_extend (p);
 254   memcpy (p->image_base + p->image_index, &word, sizeof (scm_bits_t));
 255   p->image_index += sizeof (scm_bits_t);
 256 }
 257
 258 void
 259 scm_store_bytes (const void *addr, scm_sizet size, SCM dstate)
 260 {
 261   struct scm_dstate *p = SCM_DSTATE_DATA (dstate);
 262   scm_store_word (size, dstate);
 263   while (p->image_index + size + sizeof (scm_bits_t) >= p->image_size)
 264     dstate_extend (p);
 265   memcpy (p->image_base + p->image_index, addr, size);
 266   p->image_index += size;
 267   scm_store_pad (dstate);
 268 }
 269
 270 void
 271 scm_store_string (const char *addr, scm_sizet size, SCM dstate)
 272 {
 273   struct scm_dstate *p = SCM_DSTATE_DATA (dstate);
 274   while (p->image_index + size + 1 >= p->image_size)
 275     dstate_extend (p);
 276   memcpy (p->image_base + p->image_index, addr, size);
 277   memcpy (p->image_base + p->image_index + size, "\0", 1);
 278   p->image_index += size + 1;
 279   scm_store_pad (dstate);
 280 }
 281
 282 void
 283 scm_store_object (SCM obj, SCM dstate)
 284 {
 285   scm_bits_t id = scm_object_indicator (obj, dstate);
 286   if (id == -1)
 287     {
 288       /* OBJ is not stored yet.  Do it later */
 289       struct scm_dstate *p = SCM_DSTATE_DATA (dstate);
 290       SCM task;
 291       SCM_NEWCELL2 (task);
 292       SCM_SET_DTASK_ID (task, SCM_UNPACK (obj));
 293       SCM_SET_DTASK_ADDR (task, p->image_index);
 294       SCM_SET_DTASK_NEXT (task, p->task);
 295       p->task = task;
 296     }
 297   scm_store_word (id, dstate);
 298 }
 299
 300 /* restore functions */
 301
 302 static void
 303 scm_restore_pad (struct scm_dstate *p)
 304 {
 305   while (p->image_index % sizeof (scm_bits_t) != 0)
 306     p->image_index++;
 307 }
 308
 309 void
 310 scm_restore_word (scm_bits_t *wordp, SCM dstate)
 311 {
 312   struct scm_dstate *p = SCM_DSTATE_DATA (dstate);
 313   *wordp = *(scm_bits_t *) (p->image_base + p->image_index);
 314   p->image_index += sizeof (scm_bits_t);
 315 }
 316
 317 void
 318 scm_restore_bytes (const void **pp, scm_sizet *sizep, SCM dstate)
 319 {
 320   scm_bits_t size;
 321   struct scm_dstate *p = SCM_DSTATE_DATA (dstate);
 322   scm_restore_word (&size, dstate);
 323   if (sizep)
 324     *sizep = size;
 325   *pp = p->image_base + p->image_index;
 326   p->image_index += size;
 327   scm_restore_pad (p);
 328 }
 329
 330 void
 331 scm_restore_string (const char **pp, scm_sizet *sizep, SCM dstate)
 332 {
 333   int len;
 334   struct scm_dstate *p = SCM_DSTATE_DATA (dstate);
 335   *pp = p->image_base + p->image_index;
 336   len = strlen (*pp);
 337   if (sizep)
 338     *sizep = len;
 339   p->image_index += len + 1;
 340   scm_restore_pad (p);
 341 }
 342
 343 void
 344 scm_restore_object (SCM *objp, SCM dstate)
 345 {
 346   scm_bits_t id;
 347   scm_restore_word (&id, dstate);
 348   *objp = scm_indicator_object (id, dstate);
 349
 350   if (SCM_UNBNDP (*objp))
 351     {
 352       struct scm_dstate *p = SCM_DSTATE_DATA (dstate);
 353       SCM task;
 354       SCM_NEWCELL2 (task);
 355       SCM_SET_DTASK_ID (task, id);
 356       SCM_SET_DTASK_ADDR (task, objp);
 357       SCM_SET_DTASK_NEXT (task, p->task);
 358       p->task = task;
 359     }
 360 }
 361
 362 \f
 363 /*
 364  * Dump routine
 365  */
 366
 367 static void
 368 scm_dump (SCM obj, SCM dstate)
 369 {
 370   struct scm_dstate *p = SCM_DSTATE_DATA (dstate);
 371
 372   /* Check if immediate or already dumpped */
 373   if (scm_object_indicator (obj, dstate) != -1)
 374     return;
 375
 376   /* Mark it */
 377   scm_hashq_set_x (p->table, obj, SCM_MAKINUM (p->table_index));
 378   p->table_index++;
 379
 380   if (SCM_SLOPPY_CONSP (obj))
 381     {
 382       scm_store_word (scm_tc3_cons, dstate);
 383       /* Store cdr first in order to avoid a possible deep recursion
 384        * with a long list */
 385       scm_store_object (SCM_CDR (obj), dstate);
 386       scm_store_object (SCM_CAR (obj), dstate);
 387       goto next_dump;
 388     }
 389   switch (SCM_TYP7 (obj))
 390     {
 391     case scm_tc7_symbol:
 392       {
 393         scm_store_word (scm_tc7_symbol, dstate);
 394         scm_store_string (SCM_SYMBOL_CHARS (obj),
 395                           SCM_SYMBOL_LENGTH (obj),
 396                           dstate);
 397         return;
 398       }
 399     case scm_tc7_substring:
 400     case scm_tc7_string:
 401       {
 402         scm_store_word (scm_tc7_string, dstate);
 403         scm_store_string (SCM_STRING_CHARS (obj),
 404                           SCM_STRING_LENGTH (obj),
 405                           dstate);
 406         return;
 407       }
 408     case scm_tc7_vector:
 409       {
 410         int i;
 411         scm_bits_t len = SCM_VECTOR_LENGTH (obj);
 412         SCM *base = SCM_VELTS (obj);
 413         scm_store_word (scm_tc7_vector, dstate);
 414         scm_store_word (len, dstate);
 415         for (i = 0; i < len; i++)
 416           scm_store_object (base[i], dstate);
 417         goto next_dump;
 418       }
 419     case scm_tc7_smob:
 420       {
 421         void (*dump) () = SCM_SMOB_DESCRIPTOR (obj).dump;
 422         if (!dump)
 423           goto error;
 424
 425         /* FIXME: SCM_CELL_TYPE may change when undump!! */
 426         scm_store_word (SCM_CELL_TYPE (obj), dstate);
 427         dump (obj, dstate);
 428         goto next_dump;
 429       }
 430     default:
 431     error:
 432       scm_misc_error ("scm_dump_mark", "Cannot dump: ~A", SCM_LIST1 (obj));
 433     }
 434
 435  next_dump:
 436   {
 437     SCM task;
 438     for (task = p->task; !SCM_NULLP (task); task = SCM_DTASK_NEXT (task))
 439       {
 440         SCM obj = SCM_PACK (SCM_DTASK_ID (task));
 441         scm_dump (obj, dstate);
 442         *(scm_bits_t *) (p->image_base + (int) SCM_DTASK_ADDR (task)) =
 443           scm_object_indicator (obj, dstate);
 444       }
 445   }
 446 }
 447
 448 static void
 449 scm_undump (SCM dstate)
 450 {
 451   struct scm_dstate *p = SCM_DSTATE_DATA (dstate);
 452   scm_bits_t tc;
 453   SCM obj;
 454
 455   scm_restore_word (&tc, dstate);
 456
 457   if (SCM_ITAG3 (SCM_PACK (tc)) == scm_tc3_cons)
 458     {
 459       SCM_NEWCELL (obj);
 460       /* cdr was stored first */
 461       scm_restore_object (SCM_CDRLOC (obj), dstate);
 462       scm_restore_object (SCM_CARLOC (obj), dstate);
 463       goto store_object;
 464     }
 465
 466   switch (SCM_ITAG7 (SCM_PACK (tc)))
 467     {
 468     case scm_tc7_symbol:
 469       {
 470         scm_sizet len;
 471         const char *mem;
 472         scm_restore_string (&mem, &len, dstate);
 473         obj = scm_mem2symbol (mem, len);
 474         goto store_object;
 475       }
 476     case scm_tc7_string:
 477       {
 478         scm_sizet len;
 479         const char *mem;
 480         scm_restore_string (&mem, &len, dstate);
 481         obj = scm_makfromstr (mem, len, 0);
 482         goto store_object;
 483       }
 484     case scm_tc7_vector:
 485       {
 486         int i;
 487         scm_bits_t len;
 488         SCM *base;
 489         scm_restore_word (&len, dstate);
 490         obj = scm_c_make_vector (len, SCM_BOOL_F);
 491         base = SCM_VELTS (obj);
 492         for (i = 0; i < len; i++)
 493           scm_restore_object (&base[i], dstate);
 494         goto store_object;
 495       }
 496     case scm_tc7_smob:
 497       {
 498         SCM (*undump) () = scm_smobs[SCM_TC2SMOBNUM (tc)].undump;
 499         if (!undump)
 500           goto error;
 501         obj = undump (dstate);
 502         goto store_object;
 503       }
 504     default:
 505     error:
 506       scm_misc_error ("scm_undump", "Cannot undump", SCM_EOL);
 507     }
 508
 509  store_object:
 510   SCM_DSTATE_TABLE_SET (dstate, p->table_index, obj);
 511   p->table_index++;
 512 }
 513
 514 \f
 515 /*
 516  * Scheme interface
 517  */
 518
 519 SCM_DEFINE (scm_binary_write, "binary-write", 1, 1, 0,
 520             (SCM obj, SCM port),
 521             "Write OBJ to PORT in a binary format.")
 522 #define FUNC_NAME s_scm_binary_write
 523 {
 524   struct scm_dstate *p;
 525   struct scm_dump_header header;
 526   SCM dstate;
 527
 528   /* Check port */
 529   if (SCM_UNBNDP (port))
 530     port = scm_cur_outp;
 531   else
 532     SCM_VALIDATE_OUTPUT_PORT (2, port);
 533
 534   /* Dump objects */
 535   dstate = make_dstate ();
 536   p = SCM_DSTATE_DATA (dstate);
 537   p->table = scm_c_make_hash_table (SCM_DUMP_HASH_SIZE);
 538   scm_dump (obj, dstate);
 539
 540   /* Write image */
 541   header.cookie  = ((scm_bits_t *) SCM_DUMP_COOKIE)[0];
 542   header.version = ((scm_bits_t *) SCM_DUMP_COOKIE)[1];
 543   header.nobjs   = (p->table_index
 544                     ? SCM_DUMP_INDEX_TO_WORD (p->table_index)
 545                     : SCM_UNPACK (obj));
 546   scm_lfwrite ((const char *) &header, sizeof (struct scm_dump_header), port);
 547   if (p->image_index)
 548     scm_lfwrite (p->image_base, p->image_index, port);
 549
 550   return SCM_UNSPECIFIED;
 551 }
 552 #undef FUNC_NAME
 553
 554 SCM_DEFINE (scm_binary_read, "binary-read", 0, 1, 0,
 555             (SCM port),
 556             "Read an object from PORT in a binary format.")
 557 #define FUNC_NAME s_scm_binary_read
 558 {
 559   int i, nobjs;
 560   struct scm_dstate *p;
 561   struct scm_dump_header *header;
 562   SCM dstate;
 563
 564   /* Check port */
 565   if (SCM_UNBNDP (port))
 566     port = scm_cur_inp;
 567   else
 568     SCM_VALIDATE_INPUT_PORT (1, port);
 569
 570   /* Initialize */
 571   if (SCM_FPORTP (port))
 572     /* Undump with mmap */
 573     dstate = make_dstate_by_mmap (SCM_FPORT_FDES (port));
 574   else
 575     /* Undump with malloc */
 576     SCM_MISC_ERROR ("Not supported yet", SCM_EOL);
 577   p = SCM_DSTATE_DATA (dstate);
 578
 579   /* Read header */
 580   header = (struct scm_dump_header *) p->image_base;
 581   p->image_index += sizeof (struct scm_dump_header);
 582   if (p->image_size < sizeof (*header))
 583     SCM_MISC_ERROR ("Invalid binary format: ~A", SCM_LIST1 (port));
 584   if (header->cookie != ((scm_bits_t *) SCM_DUMP_COOKIE)[0])
 585     SCM_MISC_ERROR ("Invalid binary format: ~A", SCM_LIST1 (port));
 586   if (header->version != ((scm_bits_t *) SCM_DUMP_COOKIE)[1])
 587     SCM_MISC_ERROR ("Unsupported binary version: ~A", SCM_LIST1 (port));
 588
 589   /* Check for immediate */
 590   if (SCM_IMP (SCM_PACK (header->nobjs)))
 591     return SCM_PACK (header->nobjs);
 592
 593   /* Create object table */
 594   nobjs = SCM_DUMP_WORD_TO_INDEX (header->nobjs);
 595   p->table = scm_c_make_vector (nobjs, SCM_UNDEFINED);
 596
 597   /* Undump */
 598   for (i = 0; i < nobjs; i++)
 599     scm_undump (dstate);
 600
 601   /* Update references */
 602   {
 603     SCM task;
 604     for (task = p->task; !SCM_NULLP (task); task = SCM_DTASK_NEXT (task))
 605       {
 606         *SCM_DTASK_ADDR (task) =
 607           SCM_UNPACK (scm_indicator_object (SCM_DTASK_ID (task), dstate));
 608       }
 609   }
 610
 611   /* Return */
 612   {
 613     SCM obj = SCM_DSTATE_TABLE_REF (dstate, 0);
 614     p->table = SCM_BOOL_F;
 615     return obj;
 616   }
 617 }
 618 #undef FUNC_NAME
 619
 620 \f
 621 void
 622 scm_init_dump ()
 623 {
 624   scm_tc16_dstate = scm_make_smob_type ("dstate", 0);
 625   scm_set_smob_mark (scm_tc16_dstate, dstate_mark);
 626   scm_set_smob_free (scm_tc16_dstate, dstate_free);
 627 #ifndef SCM_MAGIC_SNARFER
 628 #include "libguile/dump.x"
 629 #endif
 630 }
 631
 632 /*
 633   Local Variables:
 634   c-file-style: "gnu"
 635   End:
 636 */