1 /* Part of SWI-Prolog
2
3 Author: Jan Wielemaker
4 E-mail: J.Wielemaker@vu.nl
5 WWW: http://www.swi-prolog.org
6 Copyright (c) 1985-2020, University of Amsterdam
7 VU University Amsterdam
8 CWI, Amsterdam
9 All rights reserved.
10
11 Redistribution and use in source and binary forms, with or without
12 modification, are permitted provided that the following conditions
13 are met:
14
15 1. Redistributions of source code must retain the above copyright
16 notice, this list of conditions and the following disclaimer.
17
18 2. Redistributions in binary form must reproduce the above copyright
19 notice, this list of conditions and the following disclaimer in
20 the documentation and/or other materials provided with the
21 distribution.
22
23 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
24 "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
25 LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
26 FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
27 COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
28 INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
29 BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
30 LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
31 CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
32 LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
33 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
34 POSSIBILITY OF SUCH DAMAGE.
35 */
36
37 /*#define O_DEBUG 1*/
38 #include "pl-incl.h"
39 #include "pl-comp.h"
40 #include "pl-arith.h"
41 #include "os/pl-utf8.h"
42 #include "pl-dbref.h"
43 #include "pl-dict.h"
44 #ifdef HAVE_SYS_PARAM_H
45 #include <sys/param.h>
46 #endif
47 #ifdef HAVE_UNISTD_H
48 #include <unistd.h>
49 #endif
50
51 #ifdef O_DEBUG
52 #define Qgetc(s) Sgetc(s)
53 #define TRACK_POS ""
54 #else
55 #define Qgetc(s) Snpgetc(s) /* ignore position recording */
56 #define TRACK_POS "r"
57 #endif
58
59 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
60 SWI-Prolog can compile Prolog source files into intermediate code files,
61 which can be loaded very fast. They can be saved as stand alone
62 executables using Unix #! magic number.
63
64 A wic file consists of the magic code and a version check code. This is
65 followed by the command line option defaults. Then an optional series
66 of `include' statements follow. Finally the predicates and directives
67 are described. Predicates are described close to the internal
68 representation. Directives are stored as binary terms representing the
69 query.
70
71 The default options and include statements are written incrementally in
72 each wic file. In the normal boot cycle first the boot file is
73 determined. Then the option structure is filled with the default option
74 found in this boot file. Next the command line arguments are scanned to
75 obtain all options. Then stacks, built in's, etc. are initialised.
76 The the boot file is read again, but now only scanning for directives
77 and predicates.
78
79 IF YOU CHANGE ANYTHING TO THIS FILE, SO THAT OLD WIC-FILES CAN NO LONGER
80 BE READ, PLEASE DO NOT FORGET TO INCREMENT THE VERSION NUMBER!
81
82 Below is an informal description of the format of a `.qlf' file:
83
84 <wic-file> ::= <magic code>
85 <version number>
86 <bits-per-word>
87 <home> % a <string>
88 {<statement>}
89 'T'
90 ----------------------------------------------------------------
91 <qlf-file> ::= <qlf-magic>
92 <version-number>
93 <bits-per-word>
94 'F' <string> % path of qlf file
95 {'I' <include>}
96 'Q' <qlf-part>
97 <qlf-magic> ::= <string>
98 <qlf-module> ::= <qlf-header>
99 <size> % size in bytes
100 {<statement>}
101 'X'
102 <qlf-header> ::= 'M' <XR/modulename> % module name
103 <source> % file + time
104 <line>
105 {'S' <XR/supername>}
106 {<qlf-export>}
107 'X'
108 | <source> % not a module
109 <time>
110 <qlf-export> ::= 'E' <XR/functor>
111 <source> ::= 'F' <string> <time> <system>
112 | '-'
113 ----------------------------------------------------------------
114 <magic code> ::= <string> % normally #!<path>
115 <version number>::= <num>
116 <statement> ::= 'W' <string> % include wic file
117 | 'P' <XR/functor> % predicate
118 <flags>
119 {<clause>} <pattern>
120 | 'O' <XR/modulename> % pred out of module
121 <XR/functor>
122 <flags>
123 {<clause>} <pattern>
124 | 'D'
125 <lineno> % source line number
126 <term> % directive
127 | 'E' <XR/functor> % export predicate
128 | 'I' <XR/procedure> <flags> % import predicate
129 | 'Q' <qlf-module> % include module
130 | 'M' <XR/modulename> % load-in-module
131 {<statement>}
132 'X'
133 <flags> ::= <num> % Bitwise or of PRED_*
134 <clause> ::= 'C' <#codes>
135 <line_no>
136 <owner_file>
137 <source_file>
138 <# prolog vars> <# vars>
139 <is_fact> % 0 or 1
140 <#n subclause> <codes>
141 | 'X' % end of list
142 <XR> ::= XR_REF <num> % XR id from table
143 XR_NIL % []
144 XR_CONS % functor of [_|_]
145 XR_ATOM <len><chars> % atom
146 XR_BLOB <blob><private> % typed atom (blob)
147 XR_INT <num> % number
148 XR_FLOAT <word>* % float (double)
149 XR_STRING <string> % string
150 XR_STRING_UTF8 <utf-8 string> % wide string
151 XR_FUNCTOR <XR/name> <num> % functor
152 XR_PRED <XR/fdef> <XR/module>% predicate
153 XR_MODULE <XR/name> % module
154 XR_FILE 's'|'u' <XR/atom> <time>
155 '-'
156 XR_BLOB_TYPE <len><chars> % blob type-name
157 <term> ::= <num> % # variables in term
158 <theterm>
159 <theterm> ::= <XR/atomic> % atomic data
160 | 'v' <num> % variable
161 | 't' <XR/functor> {<theterm>} % compound
162 <system> ::= 's' % system source file
163 | 'u' % user source file
164 <time> ::= <word> % time file was loaded
165 <line> ::= <num>
166 <codes> ::= <num> {<code>}
167 <string> ::= {<non-zero byte>} <0>
168 <word> ::= <4 byte entity>
169 <include> ::= <owner> <parent> <line> <file> <time>
170
171 Integers are stored in a packed format to reduce the size of the
172 intermediate code file as 99% of them is normally small, but in
173 principle not limited (virtual machine codes, arities, table sizes,
174 etc). We use the "zigzag" encoding to deal with negative integers and
175 write the positive value in chunks of 7 bits, least significant bits
176 first. The last byte has its 0x80 mask set.
177 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
178
179 #define QLFMAGICNUM 0x716c7374 /* "qlst" on little-endian machine */
180
181 #define XR_REF 0 /* reference to previous */
182 #define XR_NIL 1 /* [] */
183 #define XR_CONS 2 /* functor of [_|_] */
184 #define XR_ATOM 3 /* atom */
185 #define XR_FUNCTOR 4 /* functor */
186 #define XR_PRED 5 /* procedure */
187 #define XR_INT 6 /* int */
188 #define XR_FLOAT 7 /* float */
189 #define XR_STRING 8 /* string */
190 #define XR_FILE 9 /* source file */
191 #define XR_MODULE 10 /* a module */
192 #define XR_BLOB 11 /* a typed atom (blob) */
193 #define XR_BLOB_TYPE 12 /* name of atom-type declaration */
194 #define XR_STRING_UTF8 13 /* Wide character string */
195 #define XR_NULL 14 /* NULL pointer */
196
197 #define V_LABEL 256 /* Label pseudo opcode */
198 #define V_H_INTEGER 257 /* Abstract various H_INT variations */
199 #define V_B_INTEGER 258 /* Abstract various B_INT variations */
200 #define V_A_INTEGER 259 /* Abstract various A_INT variations */
201
202 #define PRED_SYSTEM 0x01 /* system predicate */
203 #define PRED_HIDE_CHILDS 0x02 /* hide my childs */
204
205 static char saveMagic[] = "SWI-Prolog state (www.swi-prolog.org)\n";
206 static char qlfMagic[] = "SWI-Prolog .qlf file\n";
207
208 typedef struct source_mark
209 { long file_index;
210 struct source_mark *next;
211 } source_mark, *SourceMark;
212
213
214 #define XR_BLOCKS 32
215 typedef struct xr_table
216 { unsigned int id; /* next id to give out */
217 struct xr_table* previous; /* stack */
218 Word blocks[XR_BLOCKS]; /* main table */
219 word preallocated[7];
220 } xr_table, *XrTable;
221
222
223 typedef struct path_translated
224 { struct path_translated *next;
225 atom_t from;
226 atom_t to;
227 } path_translated;
228
229 typedef struct qlf_state
230 { char *save_dir; /* Directory saved */
231 char *load_dir; /* Directory loading */
232 int has_moved; /* Paths must be translated */
233 path_translated *translated; /* Translated paths */
234 struct qlf_state *previous; /* previous saved state (reentrance) */
235 } qlf_state;
236
237
238 typedef struct wic_state
239 { char *wicFile; /* name of output file */
240 char *mkWicFile; /* Wic file under construction */
241 IOSTREAM *wicFd; /* file descriptor of wic file */
242
243 Definition currentPred; /* current procedure */
244 SourceFile currentSource; /* current source file */
245
246 Table idMap; /* mapped identifiers */
247 Table savedXRTable; /* saved XR entries */
248 intptr_t savedXRTableId; /* next id to hand out */
249
250 SourceMark source_mark_head; /* Locations of sources */
251 SourceMark source_mark_tail;
252 int has_source_marks;
253
254 int saved_version; /* Version saved */
255 int obfuscate; /* Obfuscate source */
256 int load_nesting; /* Nesting level of loadPart() */
257 qlf_state *load_state; /* current load-state */
258
259 xr_table *XR; /* external references */
260
261 struct
262 { int invalid_wide_chars; /* Cannot represent due to UCS-2 */
263 } errors;
264
265 struct wic_state *parent; /* parent state */
266 } wic_state;
267
268 static char * getString(IOSTREAM *, size_t *len);
269 static int64_t getInt64(IOSTREAM *);
270 static int getInt32(IOSTREAM *s);
271 static int getInt(IOSTREAM *);
272 static double getFloat(IOSTREAM *);
273 static bool loadWicFd(wic_state *state);
274 static bool loadPredicate(wic_state *state, int skip ARG_LD);
275 static bool loadImport(wic_state *state, int skip ARG_LD);
276 static void saveXRBlobType(wic_state *state, PL_blob_t *type);
277 static void putString(const char *, size_t len, IOSTREAM *);
278 static void putInt64(int64_t, IOSTREAM *);
279 static void putFloat(double, IOSTREAM *);
280 static void saveWicClause(wic_state *state, Clause cl);
281 static void closePredicateWic(wic_state *state);
282 static word loadXRc(wic_state *state, int c ARG_LD);
283 static atom_t getBlob(wic_state *state ARG_LD);
284 static bool loadStatement(wic_state *state, int c, int skip ARG_LD);
285 static bool loadPart(wic_state *state, Module *module, int skip ARG_LD);
286 static bool loadInModule(wic_state *state, int skip ARG_LD);
287 static int qlfVersion(wic_state *state, const char *magic, int *vp);
288 static atom_t qlfFixSourcePath(wic_state *state, const char *raw);
289 static int pushPathTranslation(wic_state *state, const char *loadname, int flags);
290 static void popPathTranslation(wic_state *state);
291 static int qlfIsCompatible(wic_state *state, const char *magic);
292
293 /* Convert CA1_VAR arguments to VM independent and back
294 */
295 #define VAR_OFFSET(i) ((intptr_t)((i) - (ARGOFFSET / (intptr_t) sizeof(word))))
296 #define OFFSET_VAR(i) ((intptr_t)((i) + (ARGOFFSET / (intptr_t) sizeof(word))))
297
298 #undef LD
299 #define LD LOCAL_LD
300
301
302 /*******************************
303 * LOADED XR ID HANDLING *
304 *******************************/
305
306 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
307 XR reference handling during loading. This uses a dynamic array using
308 doubling sub arrays as also used for atoms, functors, etc.
309 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
310
311 static void
pushXrIdTable(wic_state * state)312 pushXrIdTable(wic_state *state)
313 { XrTable t = allocHeapOrHalt(sizeof(*t));
314
315 memset(t, 0, sizeof(*t));
316 t->id = 0;
317 t->blocks[0] = t->preallocated - 1;
318 t->blocks[1] = t->preallocated - 1;
319 t->blocks[2] = t->preallocated - 1;
320
321 t->previous = state->XR;
322 state->XR = t;
323 }
324
325
326 static void
popXrIdTable(wic_state * state)327 popXrIdTable(wic_state *state)
328 { XrTable t = state->XR;
329 unsigned int id, idx;
330
331 state->XR = t->previous; /* pop the stack */
332
333 for(id=0; id < 7; id++)
334 { word w = t->preallocated[id];
335
336 if ( isAtom(w) )
337 PL_unregister_atom(w);
338 }
339 for(idx = 3; idx < XR_BLOCKS && t->blocks[idx]; idx++)
340 { size_t bs = (size_t)1<<idx;
341 Word p = t->blocks[idx]+bs;
342 size_t i;
343
344 for(i=0; i<bs && id < t->id; i++, id++)
345 { word w = p[i];
346
347 if ( isAtom(w) )
348 PL_unregister_atom(w);
349 }
350
351 freeHeap(p, bs*sizeof(word));
352 }
353
354 freeHeap(t, sizeof(*t));
355 }
356
357
358 static word
lookupXrId(wic_state * state,unsigned int id)359 lookupXrId(wic_state *state, unsigned int id)
360 { XrTable t = state->XR;
361 unsigned int idx = MSB(id);
362
363 DEBUG(CHK_SECURE, assert(t->blocks[idx]));
364 return t->blocks[idx][id];
365 }
366
367
368 static void
storeXrId(wic_state * state,unsigned int id,word value)369 storeXrId(wic_state *state, unsigned int id, word value)
370 { XrTable t = state->XR;
371 unsigned int idx = MSB(id);
372
373 if ( !t->blocks[idx] )
374 { size_t bs = (size_t)1<<idx;
375 Word newblock;
376
377 newblock = allocHeapOrHalt(bs*sizeof(word));
378 t->blocks[idx] = newblock-bs;
379 }
380
381 t->blocks[idx][id] = value;
382 }
383
384
385 /*******************************
386 * PRIMITIVE LOADING *
387 *******************************/
388
389 #define PATH_ISDIR 0x1 /* pushPathTranslation() flags */
390
391 static bool
qlfLoadError_ctx(wic_state * state,char * file,int line)392 qlfLoadError_ctx(wic_state *state, char *file, int line)
393 { fatalError("%s: QLF format error at index = %ld (%s:%d)",
394 state->wicFile, Stell(state->wicFd), file, line);
395
396 fail;
397 }
398
399 #define qlfLoadError(state) qlfLoadError_ctx(state, __FILE__, __LINE__)
400
401 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
402 Load a string from the input stream. There are two cases: 0-terminated
403 short strings (files, etc) have length set to NULL and the general
404 Prolog string case has length pointing to a pointer. The latter is used
405 only for saved (directive) terms and the result is thus pushed to the
406 global stack.
407
408 Returns NULL if the string is too large.
409 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
410
411 static char *
getString(IOSTREAM * fd,size_t * length)412 getString(IOSTREAM *fd, size_t *length)
413 { GET_LD
414 char *s;
415 size_t len = (size_t)getInt64(fd);
416 size_t i;
417
418 if ( !length && len > MAXPATHLEN )
419 return NULL;
420 if ( length && len > globalStackLimit() )
421 return NULL;
422
423 if ( LD->qlf.getstr_buffer_size < len+1 )
424 { size_t size = ((len+1+1023)/1024)*1024;
425
426 if ( LD->qlf.getstr_buffer )
427 LD->qlf.getstr_buffer = realloc(LD->qlf.getstr_buffer, size);
428 else
429 LD->qlf.getstr_buffer = malloc(size);
430
431 if ( LD->qlf.getstr_buffer )
432 LD->qlf.getstr_buffer_size = size;
433 else
434 outOfCore();
435 }
436
437 for( i=0, s = LD->qlf.getstr_buffer; i<len; i++ )
438 { int c = Qgetc(fd);
439
440 if ( c == EOF )
441 fatalError("Unexpected EOF on QLF file at offset %d",
442 Stell(fd));
443
444 *s++ = c;
445 }
446 *s = EOS;
447
448 if ( length )
449 *length = (unsigned) len;
450
451 return LD->qlf.getstr_buffer;
452 }
453
454
455 pl_wchar_t *
wicGetStringUTF8(IOSTREAM * fd,size_t * length,pl_wchar_t * buf,size_t bufsize)456 wicGetStringUTF8(IOSTREAM *fd, size_t *length,
457 pl_wchar_t *buf, size_t bufsize)
458 { size_t i, len = (size_t)getInt64(fd);
459 IOENC oenc = fd->encoding;
460 pl_wchar_t *tmp, *o;
461
462 if ( length )
463 *length = len;
464
465 if ( len < bufsize )
466 tmp = buf;
467 else
468 tmp = PL_malloc(len*sizeof(pl_wchar_t));
469
470 fd->encoding = ENC_UTF8;
471 for(i=0, o=tmp; i<len; i++)
472 { int c = Sgetcode(fd);
473
474 if ( c < 0 )
475 fatalError("Unexpected EOF in UCS atom");
476 *o++ = c;
477 }
478 fd->encoding = oenc;
479
480 return tmp;
481 }
482
483
484
485 static atom_t
getAtom(IOSTREAM * fd,PL_blob_t * type)486 getAtom(IOSTREAM *fd, PL_blob_t *type)
487 { char buf[1024];
488 char *tmp, *s;
489 size_t len = getInt(fd);
490 size_t i;
491 atom_t a;
492
493 if ( len < sizeof(buf) )
494 tmp = buf;
495 else
496 tmp = allocHeapOrHalt(len);
497
498 for(s=tmp, i=0; i<len; i++)
499 { int c = Qgetc(fd);
500
501 if ( c == EOF )
502 fatalError("Unexpected EOF on intermediate code file at offset %d",
503 Stell(fd));
504 *s++ = c;
505 }
506 if ( type )
507 { int new;
508
509 a = lookupBlob(tmp, len, type, &new);
510 } else
511 { a = lookupAtom(tmp, len);
512 }
513
514 if ( tmp != buf )
515 freeHeap(tmp, len);
516
517 return a;
518 }
519
520
521 static PL_blob_t *
getBlobType(IOSTREAM * fd)522 getBlobType(IOSTREAM *fd)
523 { const char *name;
524
525 if ( !(name = getString(fd, NULL)) )
526 fatalError("Invalid blob type in QLF");
527
528 return PL_find_blob_type(name);
529 }
530
531
532 static char *
getMagicString(IOSTREAM * fd,char * buf,int maxlen)533 getMagicString(IOSTREAM *fd, char *buf, int maxlen)
534 { char *s;
535 int c;
536
537 for( s = buf; --maxlen >= 0 && (*s = (c = Sgetc(fd))); s++ )
538 { if ( c == EOF )
539 return NULL;
540 }
541
542 if ( maxlen > 0 )
543 return buf;
544
545 return NULL;
546 }
547
548
549 static inline uint64_t
zigzag_encode(int64_t n)550 zigzag_encode(int64_t n)
551 { return (n << 1) ^ (n >> 63);
552 }
553
554
555 static inline int64_t
zigzag_decode(uint64_t n)556 zigzag_decode(uint64_t n)
557 { return (n >> 1) ^ -(n&1);
558 }
559
560
561 static int64_t
getInt64(IOSTREAM * fd)562 getInt64(IOSTREAM *fd)
563 { int c = Qgetc(fd);
564
565 if ( c&0x80 )
566 { DEBUG(MSG_QLF_INTEGER, Sdprintf("%" PRId64 "\n", zigzag_decode(c&0x7f)));
567 return zigzag_decode(c&0x7f);
568 } else
569 { uint64_t v = c&0x7f;
570 int shift = 7;
571
572 for(;;)
573 { c = Qgetc(fd);
574
575 if ( c&0x80 )
576 { uint64_t l = (c&0x7f);
577 v |= l<<shift;
578 DEBUG(MSG_QLF_INTEGER, Sdprintf("%" PRId64 "\n", zigzag_decode(v)));
579 return zigzag_decode(v);
580 } else
581 { uint64_t b = c;
582 v |= b<<shift;
583 shift += 7;
584 }
585 }
586 }
587 }
588
589
590 static int
getInt(IOSTREAM * fd)591 getInt(IOSTREAM *fd)
592 { int64_t val = getInt64(fd);
593
594 return (int)val;
595 }
596
597
598 static unsigned int
getUInt(IOSTREAM * fd)599 getUInt(IOSTREAM *fd)
600 { unsigned int c = Qgetc(fd);
601
602 if ( c&0x80 )
603 { DEBUG(MSG_QLF_INTEGER, Sdprintf("%d\n", c&0x7f));
604 return c&0x7f;
605 } else
606 { unsigned int v = c&0x7f;
607 int shift = 7;
608
609 for(;;)
610 { c = Qgetc(fd);
611
612 if ( c&0x80 )
613 { unsigned int l = (c&0x7f);
614 v |= l<<shift;
615 DEBUG(MSG_QLF_INTEGER, Sdprintf("%d\n", v));
616 return v;
617 } else
618 { unsigned int b = c;
619 v |= b<<shift;
620 shift += 7;
621 }
622 }
623 }
624 }
625
626
627 #ifdef WORDS_BIGENDIAN
628 static const int double_byte_order[] = { 7,6,5,4,3,2,1,0 };
629 #else
630 static const int double_byte_order[] = { 0,1,2,3,4,5,6,7 };
631 #endif
632
633 #define BYTES_PER_DOUBLE (sizeof(double_byte_order)/sizeof(int))
634
635 static double
getFloat(IOSTREAM * fd)636 getFloat(IOSTREAM *fd)
637 { double f;
638 unsigned char *cl = (unsigned char *)&f;
639 unsigned int i;
640
641 for(i=0; i<BYTES_PER_DOUBLE; i++)
642 { int c = Qgetc(fd);
643
644 if ( c == -1 )
645 fatalError("Unexpected end-of-file in QLT file");
646 cl[double_byte_order[i]] = c;
647 }
648
649 DEBUG(MSG_QLF_FLOAT, Sdprintf("getFloat() --> %f\n", f));
650
651 return f;
652 }
653
654
655 static int
getInt32(IOSTREAM * s)656 getInt32(IOSTREAM *s)
657 { int v;
658
659 v = (Sgetc(s) & 0xff) << 24;
660 v |= (Sgetc(s) & 0xff) << 16;
661 v |= (Sgetc(s) & 0xff) << 8;
662 v |= (Sgetc(s) & 0xff);
663
664 return v;
665 }
666
667
668 static inline word
loadXR__LD(wic_state * state ARG_LD)669 loadXR__LD(wic_state *state ARG_LD)
670 { return loadXRc(state, Qgetc(state->wicFd) PASS_LD);
671 }
672 #define loadXR(s) loadXR__LD(s PASS_LD)
673
674
675 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
676 loadXRc(int c0, IOSTREAM *fd ARG_LD) loads a constant from the stream.
677 Note that some constants (integers, floats and strings) can cause GC or
678 stack-shifts.
679 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
680
681 static word
loadXRc(wic_state * state,int c ARG_LD)682 loadXRc(wic_state *state, int c ARG_LD)
683 { IOSTREAM *fd = state->wicFd;
684 word xr;
685 int id = 0; /* make gcc happy! */
686
687 switch( c )
688 { case XR_REF:
689 { unsigned int xr = getUInt(fd);
690 DEBUG(MSG_QLF_XR, Sdprintf("Reuse XR(%d)\n", (long)xr));
691 word val = lookupXrId(state, xr);
692
693 return val;
694 }
695 case XR_NIL:
696 return ATOM_nil;
697 case XR_CONS:
698 return ATOM_dot;
699 case XR_ATOM:
700 { id = ++state->XR->id;
701 xr = getAtom(fd, NULL);
702 DEBUG(MSG_QLF_XR, Sdprintf("XR(%d) = '%s'\n", id, stringAtom(xr)));
703 break;
704 }
705 case XR_BLOB:
706 { id = ++state->XR->id;
707 xr = getBlob(state PASS_LD);
708 DEBUG(MSG_QLF_XR, Sdprintf("XR(%d) = <blob>\n", id));
709 break;
710 }
711 case XR_BLOB_TYPE:
712 { id = ++state->XR->id;
713 xr = (word)getBlobType(fd);
714 DEBUG(MSG_QLF_XR,
715 Sdprintf("XR(%d) = <blob-type>%s", id, ((PL_blob_t*)xr)->name));
716 break;
717 }
718 case XR_FUNCTOR:
719 { atom_t name;
720 int arity;
721
722 id = ++state->XR->id;
723 name = loadXR(state);
724 arity = getInt(fd);
725 xr = (word) lookupFunctorDef(name, arity);
726 DEBUG(MSG_QLF_XR,
727 Sdprintf("XR(%d) = %s/%d\n", id, stringAtom(name), arity));
728 break;
729 }
730 case XR_PRED:
731 { functor_t f;
732 Module m;
733
734 id = ++state->XR->id;
735 f = (functor_t) loadXR(state);
736 m = (Module) loadXR(state);
737 xr = (word) lookupProcedure(f, m);
738 DEBUG(MSG_QLF_XR,
739 Sdprintf("XR(%d) = proc %s\n", id, procedureName((Procedure)xr)));
740 break;
741 }
742 case XR_MODULE:
743 { GET_LD
744 atom_t name;
745 id = ++state->XR->id;
746 name = loadXR(state);
747 xr = (word) lookupModule(name);
748 DEBUG(MSG_QLF_XR, Sdprintf("XR(%d) = module %s\n", id, stringAtom(name)));
749 break;
750 }
751 case XR_INT:
752 { int64_t i = getInt64(fd);
753 word w;
754 int rc;
755
756 if ( (rc=put_int64(&w, i, ALLOW_GC PASS_LD)) != TRUE )
757 { raiseStackOverflow(rc);
758 return 0;
759 }
760
761 return w;
762 }
763 case XR_FLOAT:
764 { word w;
765 double f = getFloat(fd);
766 int rc;
767
768 if ( (rc=put_double(&w, f, ALLOW_GC PASS_LD)) != TRUE )
769 { raiseStackOverflow(rc);
770 return 0;
771 }
772
773 return w;
774 }
775 #if O_STRING
776 case XR_STRING:
777 { char *s;
778 size_t len;
779
780 if ( (s = getString(fd, &len)) )
781 { return globalString(len, s);
782 } else
783 { raiseStackOverflow(GLOBAL_OVERFLOW);
784 return 0;
785 }
786 }
787 case XR_STRING_UTF8:
788 { pl_wchar_t *w;
789 size_t len;
790 pl_wchar_t buf[256];
791 word s;
792
793 w = wicGetStringUTF8(fd, &len, buf, sizeof(buf)/sizeof(pl_wchar_t));
794 s = globalWString(len, w);
795 if ( w != buf )
796 PL_free(w);
797
798 return s;
799 }
800 #endif
801 case XR_FILE:
802 { int c;
803
804 id = ++state->XR->id;
805
806 switch( (c=Qgetc(fd)) )
807 { case 'u':
808 case 's':
809 { atom_t name = loadXR(state);
810 double time = getFloat(fd);
811 PL_chars_t text;
812 SourceFile sf;
813
814 PL_STRINGS_MARK();
815 get_atom_text(name, &text);
816 PL_mb_text(&text, REP_UTF8);
817 sf = lookupSourceFile(qlfFixSourcePath(state, text.text.t), TRUE);
818 PL_STRINGS_RELEASE();
819
820 if ( sf->mtime == 0.0 )
821 { sf->mtime = time;
822 sf->system = (c == 's' ? TRUE : FALSE);
823 }
824 sf->count++;
825 xr = (word)sf;
826 /* do not release sf; part of state */
827 break;
828 }
829 case '-':
830 xr = 0;
831 break;
832 default:
833 xr = 0; /* make gcc happy */
834 fatalError("Illegal XR file index %d: %c", Stell(fd)-1, c);
835 }
836
837 break;
838 }
839 case XR_NULL:
840 return 0;
841 default:
842 { xr = 0; /* make gcc happy */
843 fatalError("Illegal XR entry at index %ld: %d", Stell(fd)-1, c);
844 }
845 }
846
847 storeXrId(state, id, xr);
848
849 return xr;
850 }
851
852
853 static atom_t
getBlob(wic_state * state ARG_LD)854 getBlob(wic_state *state ARG_LD)
855 { PL_blob_t *type = (PL_blob_t*)loadXR(state);
856
857 if ( type->load )
858 { return (*type->load)(state->wicFd);
859 } else
860 { return getAtom(state->wicFd, type);
861 }
862 }
863
864
865 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
866 Returns FALSE while leaving a resource exception if the term cannot be
867 allocated.
868 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
869
870 static int
do_load_qlf_term(wic_state * state,term_t vars[],term_t term ARG_LD)871 do_load_qlf_term(wic_state *state, term_t vars[], term_t term ARG_LD)
872 { IOSTREAM *fd = state->wicFd;
873 int c = Qgetc(fd);
874
875 if ( c == 'v' )
876 { int id = getInt(fd);
877
878 if ( vars[id] )
879 { return PL_unify(term, vars[id]);
880 } else
881 { if ( (vars[id] = PL_new_term_ref()) )
882 { PL_put_term(vars[id], term);
883 return TRUE;
884 }
885 return FALSE;
886 }
887 } else if ( c == 't' )
888 { functor_t f;
889 term_t c2;
890
891 if ( (f = (functor_t) loadXR(state)) &&
892 (c2 = PL_new_term_ref()) &&
893 PL_unify_functor(term, f) )
894 { int arity = arityFunctor(f);
895 int n;
896
897 for(n=0; n < arity; n++)
898 { _PL_get_arg(n+1, term, c2);
899 if ( !do_load_qlf_term(state, vars, c2 PASS_LD) )
900 return FALSE;
901 }
902
903 return TRUE;
904 }
905
906 return FALSE;
907 } else
908 { word w;
909
910 if ( (w=loadXRc(state, c PASS_LD)) )
911 return _PL_unify_atomic(term, w);
912
913 return FALSE;
914 }
915 }
916
917
918 static int
loadQlfTerm(wic_state * state,term_t term ARG_LD)919 loadQlfTerm(wic_state *state, term_t term ARG_LD)
920 { IOSTREAM *fd = state->wicFd;
921 int nvars;
922 Word vars;
923 int rc;
924
925 DEBUG(MSG_QLF_TERM, Sdprintf("Loading from %ld ...", (long)Stell(fd)));
926
927 if ( (nvars = getInt(fd)) )
928 { term_t *v;
929 int n;
930
931 vars = alloca(nvars * sizeof(term_t));
932 for(n=nvars, v=vars; n>0; n--, v++)
933 *v = 0L;
934 } else
935 vars = NULL;
936
937 PL_put_variable(term);
938 rc = do_load_qlf_term(state, vars, term PASS_LD);
939 if ( rc )
940 resortDictsInTerm(term);
941 DEBUG(MSG_QLF_TERM,
942 Sdprintf("Loaded ");
943 PL_write_term(Serror, term, 1200, 0);
944 Sdprintf(" to %ld\n", (long)Stell(fd)));
945 return rc;
946 }
947
948
949 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
950 Load intermediate code state from the specified stream. rcpath contains
951 the ZIP file name.
952 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
953
954 int
loadWicFromStream(const char * rcpath,IOSTREAM * fd)955 loadWicFromStream(const char *rcpath, IOSTREAM *fd)
956 { wic_state state;
957 int rval;
958
959 memset(&state, 0, sizeof(state));
960 state.wicFd = fd;
961 state.wicFile = (char*)rcpath;
962
963 pushXrIdTable(&state);
964 rval = loadWicFd(&state);
965 popXrIdTable(&state);
966
967 return rval;
968 }
969
970
971 static int
loadWicFile(const char * file)972 loadWicFile(const char *file)
973 { IOSTREAM *fd;
974 int rval;
975
976 if ( !(fd = Sopen_file(file, "rb" TRACK_POS)) )
977 { warning("Cannot open Quick Load File %s: %s", file, OsError());
978 return FALSE;
979 }
980
981 rval = loadWicFromStream(file, fd);
982 Sclose(fd);
983
984 return rval;
985 }
986
987
988 static bool
loadWicFd(wic_state * state)989 loadWicFd(wic_state *state)
990 { GET_LD
991 IOSTREAM *fd = state->wicFd;
992
993 if ( !qlfIsCompatible(state, saveMagic) ||
994 !pushPathTranslation(state, systemDefaults.home, PATH_ISDIR) )
995 return FALSE;
996
997 for(;;)
998 { int c = Qgetc(fd);
999
1000 switch( c )
1001 { case EOF:
1002 case 'T': /* trailer */
1003 popPathTranslation(state);
1004 succeed;
1005 case 'W':
1006 { char *name = store_string(getString(fd, NULL) );
1007
1008 if ( (name=getString(fd, NULL)) )
1009 { name = store_string(name);
1010 loadWicFile(name);
1011 continue;
1012 } else
1013 { fatalError("Invalid QLF: bad string");
1014 return FALSE;
1015 }
1016 }
1017 case 'X':
1018 break;
1019 default:
1020 { loadStatement(state, c, FALSE PASS_LD);
1021 continue;
1022 }
1023 }
1024 }
1025 }
1026
1027
1028 static bool
loadStatement(wic_state * state,int c,int skip ARG_LD)1029 loadStatement(wic_state *state, int c, int skip ARG_LD)
1030 { IOSTREAM *fd = state->wicFd;
1031
1032 switch(c)
1033 { case 'P':
1034 return loadPredicate(state, skip PASS_LD);
1035
1036 case 'O':
1037 { word mname = loadXR(state);
1038 Module om = LD->modules.source;
1039 bool rval;
1040
1041 LD->modules.source = lookupModule(mname);
1042 rval = loadPredicate(state, skip PASS_LD);
1043 LD->modules.source = om;
1044
1045 return rval;
1046 }
1047 case 'I':
1048 return loadImport(state, skip PASS_LD);
1049
1050 case 'D':
1051 { fid_t cid;
1052
1053 if ( (cid=PL_open_foreign_frame()) )
1054 { term_t goal = PL_new_term_ref();
1055 atom_t osf = source_file_name;
1056 int oln = source_line_no;
1057
1058 source_file_name = (state->currentSource ? state->currentSource->name
1059 : NULL_ATOM);
1060 source_line_no = getInt(fd);
1061
1062 if ( !loadQlfTerm(state, goal PASS_LD) )
1063 return FALSE;
1064 DEBUG(MSG_QLF_DIRECTIVE,
1065 if ( source_file_name )
1066 { Sdprintf("%s:%d: Directive: ",
1067 PL_atom_chars(source_file_name), source_line_no);
1068 } else
1069 { Sdprintf("Directive: ");
1070 }
1071 PL_write_term(Serror, goal, 1200, PL_WRT_NEWLINE));
1072 if ( !skip )
1073 { if ( !callProlog(MODULE_user, goal, PL_Q_NODEBUG, NULL) )
1074 { if ( !printMessage(ATOM_warning,
1075 PL_FUNCTOR_CHARS, "goal_failed", 2,
1076 PL_CHARS, "directive",
1077 PL_TERM, goal) )
1078 PL_clear_exception();
1079 }
1080 }
1081 PL_discard_foreign_frame(cid);
1082
1083 source_file_name = osf;
1084 source_line_no = oln;
1085
1086 succeed;
1087 }
1088
1089 return FALSE;
1090 }
1091
1092 case 'Q':
1093 { bool rc;
1094
1095 state->load_nesting++;
1096 rc = loadPart(state, NULL, skip PASS_LD);
1097 state->load_nesting--;
1098
1099 return rc;
1100 }
1101 case 'M':
1102 return loadInModule(state, skip PASS_LD);
1103
1104 default:
1105 return qlfLoadError(state);
1106 }
1107 }
1108
1109
1110 static void
loadPredicateFlags(wic_state * state,Definition def,int skip)1111 loadPredicateFlags(wic_state *state, Definition def, int skip)
1112 { unsigned int flags = getUInt(state->wicFd);
1113
1114 if ( !skip )
1115 { unsigned long lflags = 0L;
1116
1117 if ( flags & PRED_SYSTEM )
1118 lflags |= P_LOCKED;
1119 if ( flags & PRED_HIDE_CHILDS )
1120 lflags |= HIDE_CHILDS;
1121
1122 set(def, lflags);
1123 }
1124 }
1125
1126 #ifdef O_GMP
1127
1128 static int
mp_cpsign(ssize_t hdrsize,int mpsize)1129 mp_cpsign(ssize_t hdrsize, int mpsize)
1130 { return hdrsize >= 0 ? mpsize : -mpsize;
1131 }
1132
1133 static void
mpz_hdr_size(ssize_t hdrsize,mpz_t mpz,size_t * wszp)1134 mpz_hdr_size(ssize_t hdrsize, mpz_t mpz, size_t *wszp)
1135 { size_t size = hdrsize >= 0 ? hdrsize : -hdrsize;
1136 size_t limpsize = (size+sizeof(mp_limb_t)-1)/sizeof(mp_limb_t);
1137 size_t wsize = (limpsize*sizeof(mp_limb_t)+sizeof(word)-1)/sizeof(word);
1138
1139 mpz->_mp_size = limpsize;
1140 mpz->_mp_alloc = limpsize;
1141
1142 *wszp = wsize;
1143 }
1144
1145
1146 static void
mpz_load_bits(IOSTREAM * fd,Word p,mpz_t mpz,size_t bytes)1147 mpz_load_bits(IOSTREAM *fd, Word p, mpz_t mpz, size_t bytes)
1148 { char fast[1024];
1149 char *cbuf;
1150 size_t i;
1151
1152 if ( bytes < sizeof(fast) )
1153 cbuf = fast;
1154 else
1155 cbuf = PL_malloc(bytes);
1156
1157 for(i=0; i<bytes; i++)
1158 cbuf[i] = Qgetc(fd);
1159
1160 mpz->_mp_d = (mp_limb_t*)p;
1161 mpz_import(mpz, bytes, 1, 1, 1, 0, cbuf);
1162 assert((Word)mpz->_mp_d == p); /* check no (re-)allocation is done */
1163 if ( cbuf != fast )
1164 PL_free(cbuf);
1165 }
1166
1167
1168 #endif
1169
1170 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1171 Label handling
1172 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1173
1174 typedef struct vm_rlabel
1175 { size_t offset; /* location of jump */
1176 size_t soi; /* start of instruction */
1177 unsigned int id; /* label id */
1178 } vm_rlabel;
1179
1180 typedef struct vm_rlabel_state
1181 { size_t soi; /* offset for start of instruction */
1182 tmp_buffer buf; /* buffer labels */
1183 } vm_rlabel_state;
1184
1185 static void
init_rlabels(vm_rlabel_state * state)1186 init_rlabels(vm_rlabel_state *state)
1187 { initBuffer(&state->buf);
1188 }
1189
1190 static void
exit_rlabels(vm_rlabel_state * state)1191 exit_rlabels(vm_rlabel_state *state)
1192 { discardBuffer(&state->buf);
1193 }
1194
1195 static void
push_rlabel(vm_rlabel_state * state,unsigned int id,size_t offset)1196 push_rlabel(vm_rlabel_state *state, unsigned int id, size_t offset)
1197 { vm_rlabel *top = allocFromBuffer(&state->buf, sizeof(*top));
1198 vm_rlabel *bottom = baseBuffer(&state->buf, vm_rlabel);
1199 vm_rlabel *prev = top;
1200
1201 while(prev > bottom && id > prev[-1].id)
1202 prev--;
1203 memmove(prev+1, prev, (char*)top - (char*)prev);
1204 prev->id = id;
1205 prev->soi = state->soi;
1206 prev->offset = offset;
1207 }
1208
1209 static void
resolve_rlabel(vm_rlabel_state * state,unsigned int id,Code base,Clause clause)1210 resolve_rlabel(vm_rlabel_state *state, unsigned int id, Code base, Clause clause)
1211 { vm_rlabel *top = topBuffer(&state->buf, vm_rlabel);
1212 vm_rlabel *bottom = baseBuffer(&state->buf, vm_rlabel);
1213 size_t copy = 0;
1214
1215 DEBUG(MSG_QLF_LABEL,
1216 Sdprintf("%s: V_LABEL %d\n", predicateName(clause->predicate), id));
1217
1218 for(--top; top >= bottom; top--)
1219 { if ( top->id < id )
1220 { copy++;
1221 continue;
1222 }
1223
1224 if ( top->id == id )
1225 { Code pc = &base[top->soi];
1226 size_t jmp;
1227
1228 pc = stepPC(pc); /* end of instruction */
1229 assert(base[top->offset] == (code)id);
1230 jmp = &base[state->soi] - pc;
1231 base[top->offset] = jmp;
1232 DEBUG(MSG_QLF_LABEL,
1233 Sdprintf(" Put %d at %zd\n", (int)jmp, top->offset));
1234 continue;
1235 }
1236
1237 if ( top->id > id )
1238 { top++;
1239
1240 if ( copy )
1241 { vm_rlabel *cptop = topBuffer(&state->buf, vm_rlabel);
1242 size_t cpsize = copy*sizeof(*cptop);
1243
1244 memmove(top, cptop - copy, cpsize);
1245 state->buf.top = (char*)(top+copy);
1246 } else
1247 { state->buf.top = (char*)top;
1248 }
1249
1250 break;
1251 }
1252 }
1253 }
1254
1255
1256 static bool
loadPredicate(wic_state * state,int skip ARG_LD)1257 loadPredicate(wic_state *state, int skip ARG_LD)
1258 { IOSTREAM *fd = state->wicFd;
1259 Procedure proc;
1260 Definition def;
1261 Clause clause;
1262 functor_t f = (functor_t) loadXR(state);
1263 SourceFile csf = NULL;
1264
1265 proc = lookupProcedureToDefine(f, LD->modules.source);
1266 DEBUG(MSG_QLF_PREDICATE, Sdprintf("Loading %s%s",
1267 procedureName(proc),
1268 skip ? " (skip)" : ""));
1269
1270 def = proc->definition;
1271 if ( !skip && state->currentSource )
1272 { if ( def->impl.any.defined )
1273 { if ( !redefineProcedure(proc, state->currentSource, DISCONTIGUOUS_STYLE) )
1274 { int rc = printMessage(ATOM_error, exception_term);
1275 (void)rc;
1276 PL_clear_exception();
1277 skip = TRUE;
1278 }
1279 }
1280 addProcedureSourceFile(state->currentSource, proc);
1281 }
1282 loadPredicateFlags(state, def, skip);
1283
1284 for(;;)
1285 { switch(Qgetc(fd) )
1286 { case 'X':
1287 { DEBUG(MSG_QLF_PREDICATE, Sdprintf("ok\n"));
1288 succeed;
1289 }
1290 case 'C':
1291 { int has_dicts = 0;
1292 tmp_buffer buf;
1293 vm_rlabel_state lstate;
1294
1295 DEBUG(MSG_QLF_PREDICATE, Sdprintf("."));
1296 initBuffer(&buf);
1297 init_rlabels(&lstate);
1298 clause = (Clause)allocFromBuffer(&buf, sizeofClause(0));
1299 clause->references = 0;
1300 clause->line_no = getUInt(fd);
1301
1302 { SourceFile of = (void *) loadXR(state);
1303 SourceFile sf = (void *) loadXR(state);
1304 unsigned int ono = (of ? of->index : 0);
1305 unsigned int sno = (sf ? sf->index : 0);
1306 if ( sf )
1307 { acquireSourceFile(sf);
1308 if ( of != sf )
1309 acquireSourceFile(of);
1310 }
1311 clause->owner_no = ono;
1312 clause->source_no = sno;
1313 if ( of && of != csf )
1314 { addProcedureSourceFile(sf, proc);
1315 csf = of;
1316 }
1317 }
1318
1319 clearFlags(clause);
1320 clause->prolog_vars = (unsigned short) getUInt(fd);
1321 clause->variables = (unsigned short) getUInt(fd);
1322 if ( getUInt(fd) == 0 ) /* 0: fact */
1323 set(clause, UNIT_CLAUSE);
1324 clause->predicate = def;
1325
1326 #define addCode(c) addBuffer(&buf, (c), code)
1327
1328 for(;;)
1329 { code op = getUInt(fd);
1330 const char *ats;
1331 int n = 0;
1332
1333 lstate.soi = entriesBuffer(&buf, code);
1334 switch(op)
1335 { case V_LABEL:
1336 { unsigned lbl = getUInt(fd);
1337 resolve_rlabel(&lstate, lbl, baseBuffer(&buf, code),
1338 baseBuffer(&buf, struct clause));
1339 continue;
1340 }
1341 case V_H_INTEGER:
1342 case V_B_INTEGER:
1343 { int64_t val = getInt64(fd);
1344 word w = consInt(val);
1345
1346 if ( valInt(w) == val )
1347 { addCode(encode(op==V_H_INTEGER ? H_SMALLINT : B_SMALLINT));
1348 addCode(w);
1349 #if SIZEOF_VOIDP == 8
1350 } else
1351 { addCode(encode(op==V_H_INTEGER ? H_INTEGER : B_INTEGER));
1352 addCode((intptr_t)val);
1353 }
1354 #else
1355 } else if ( val >= INTPTR_MIN && val <= INTPTR_MAX )
1356 { addCode(encode(op==V_H_INTEGER ? H_INTEGER : B_INTEGER));
1357 addCode((intptr_t)val);
1358 } else
1359 { addCode(encode(op==V_H_INTEGER ? H_INT64 : B_INT64));
1360 addMultipleBuffer(&buf, (char*)&val, sizeof(int64_t), char);
1361 }
1362 #endif
1363
1364 continue;
1365 }
1366 case V_A_INTEGER:
1367 { int64_t val = getInt64(fd);
1368
1369 #if SIZEOF_VOIDP == 8
1370 addCode(encode(A_INTEGER));
1371 addCode((intptr_t)val);
1372 #else
1373 if ( val >= INTPTR_MIN && val <= INTPTR_MAX )
1374 { addCode(encode(A_INTEGER));
1375 addCode((intptr_t)val);
1376 } else
1377 { addCode(encode(A_INT64));
1378 addMultipleBuffer(&buf, (char*)&val, sizeof(int64_t), char);
1379 }
1380 #endif
1381 continue;
1382 }
1383 }
1384
1385 if ( op >= I_HIGHEST )
1386 fatalError("Illegal op-code (%d) at %ld", op, Stell(fd));
1387
1388 ats = codeTable[op].argtype;
1389 DEBUG(MSG_QLF_VMI,
1390 Sdprintf("\t%s from %ld\n", codeTable[op].name, Stell(fd)));
1391 if ( op == I_CONTEXT )
1392 { clause = baseBuffer(&buf, struct clause);
1393 set(clause, CL_BODY_CONTEXT);
1394 set(def, P_MFCONTEXT);
1395 }
1396 addCode(encode(op));
1397 DEBUG(0,
1398 { const char ca1_float[2] = {CA1_FLOAT};
1399 const char ca1_int64[2] = {CA1_INT64};
1400 assert(codeTable[op].arguments == VM_DYNARGC ||
1401 (size_t)codeTable[op].arguments == strlen(ats) ||
1402 (streq(ats, ca1_float) &&
1403 codeTable[op].arguments == WORDS_PER_DOUBLE) ||
1404 (streq(ats, ca1_int64) &&
1405 codeTable[op].arguments == WORDS_PER_INT64));
1406 });
1407
1408 for(n=0; ats[n]; n++)
1409 { switch(ats[n])
1410 { case CA1_PROC:
1411 { addCode(loadXR(state));
1412 break;
1413 }
1414 case CA1_FUNC:
1415 { word w = loadXR(state);
1416 FunctorDef fd = valueFunctor(w);
1417 if ( fd->name == ATOM_dict )
1418 has_dicts++;
1419
1420 addCode(w);
1421 break;
1422 }
1423 case CA1_DATA:
1424 { word w = loadXR(state);
1425 if ( isAtom(w) )
1426 PL_register_atom(w);
1427 addCode(w);
1428 break;
1429 }
1430 case CA1_AFUNC:
1431 { word f = loadXR(state);
1432 int i = indexArithFunction(f);
1433 assert(i>0);
1434 addCode(i);
1435 break;
1436 }
1437 case CA1_MODULE:
1438 addCode(loadXR(state));
1439 break;
1440 case CA1_JUMP:
1441 { unsigned lbl = getUInt(fd);
1442 size_t off = entriesBuffer(&buf, code);
1443 addCode(lbl);
1444 push_rlabel(&lstate, lbl, off);
1445 break;
1446 }
1447 case CA1_INTEGER:
1448 addCode((code)getInt64(fd));
1449 break;
1450 case CA1_VAR:
1451 case CA1_FVAR:
1452 case CA1_CHP:
1453 addCode((code)OFFSET_VAR(getInt64(fd)));
1454 break;
1455 case CA1_INT64:
1456 { int64_t val = getInt64(fd);
1457
1458 addMultipleBuffer(&buf, (char*)&val, sizeof(int64_t), char);
1459 break;
1460 }
1461 case CA1_FLOAT:
1462 { double f = getFloat(fd);
1463
1464 addMultipleBuffer(&buf, (char*)&f, sizeof(double), char);
1465 break;
1466 }
1467 case CA1_STRING: /* <n> chars */
1468 { size_t l = getInt(fd);
1469 int c0 = Qgetc(fd);
1470
1471 if ( c0 == 'B' )
1472 { int lw = (l+sizeof(word))/sizeof(word);
1473 int pad = (lw*sizeof(word) - l);
1474 Code bp;
1475 char *s;
1476
1477 DEBUG(MSG_QLF_VMI, Sdprintf("String of %ld bytes\n", l));
1478 bp = allocFromBuffer(&buf, sizeof(word)*(lw+1));
1479 s = (char *)&bp[1];
1480 *bp = mkStrHdr(lw, pad);
1481 bp += lw;
1482 *bp++ = 0L;
1483 *s++ = 'B';
1484 l--;
1485 while(l-- > 0)
1486 *s++ = Qgetc(fd);
1487 } else
1488 { size_t i;
1489 size_t bs = (l+1)*sizeof(pl_wchar_t);
1490 size_t lw = (bs+sizeof(word))/sizeof(word);
1491 int pad = (lw*sizeof(word) - bs);
1492 word m = mkStrHdr(lw, pad);
1493 IOENC oenc = fd->encoding;
1494
1495 DEBUG(MSG_QLF_VMI,
1496 Sdprintf("Wide string of %zd chars; lw=%zd; pad=%d\n",
1497 l, lw, pad));
1498
1499 assert(c0 == 'W');
1500
1501 addCode(m); /* The header */
1502 addBuffer(&buf, 'W', char);
1503 for(i=1; i<sizeof(pl_wchar_t); i++)
1504 addBuffer(&buf, 0, char);
1505
1506 fd->encoding = ENC_UTF8;
1507 for(i=0; i<l; i++)
1508 { int code = Sgetcode(fd);
1509 pl_wchar_t c = code;
1510
1511 if ( (int)c != code )
1512 { state->errors.invalid_wide_chars++;
1513 c = UTF8_MALFORMED_REPLACEMENT;
1514 }
1515
1516 addBuffer(&buf, c, pl_wchar_t);
1517 }
1518 fd->encoding = oenc;
1519
1520 for(i=0; i<pad; i++)
1521 addBuffer(&buf, 0, char);
1522 }
1523 break;
1524 }
1525 case CA1_MPZ:
1526 #ifdef O_GMP
1527 #define ABS(x) ((x) >= 0 ? (x) : -(x))
1528 DEBUG(MSG_QLF_VMI, Sdprintf("Loading MPZ from %ld\n", Stell(fd)));
1529 { ssize_t hdrsize = getInt64(fd);
1530 size_t wsize;
1531 mpz_t mpz;
1532 word m;
1533 Word p;
1534
1535 mpz_hdr_size(hdrsize, mpz, &wsize);
1536 m = mkIndHdr(wsize+1, TAG_INTEGER);
1537 p = allocFromBuffer(&buf, sizeof(word)*(wsize+2));
1538
1539 *p++ = m;
1540 p[wsize] = 0;
1541 *p++ = mpz_size_stack(mp_cpsign(hdrsize, mpz->_mp_size));
1542 p[wsize] = 0;
1543 mpz_load_bits(fd, p, mpz, ABS(hdrsize));
1544
1545 DEBUG(MSG_QLF_VMI, Sdprintf("Loaded MPZ to %ld\n", Stell(fd)));
1546 break;
1547 }
1548 case CA1_MPQ:
1549 DEBUG(MSG_QLF_VMI, Sdprintf("Loading MPQ from %ld\n", Stell(fd)));
1550 { ssize_t num_hdrsize = getInt64(fd);
1551 ssize_t den_hdrsize = getInt64(fd);
1552 size_t wsize, num_wsize, den_wsize;
1553 mpz_t num;
1554 mpz_t den;
1555 word m;
1556 Word p;
1557
1558 mpz_hdr_size(num_hdrsize, num, &num_wsize);
1559 mpz_hdr_size(den_hdrsize, den, &den_wsize);
1560 wsize = num_wsize + den_wsize;
1561 m = mkIndHdr(wsize+2, TAG_INTEGER);
1562 p = allocFromBuffer(&buf, sizeof(word)*(wsize+3));
1563
1564 *p++ = m;
1565 *p++ = mpq_size_stack(mp_cpsign(num_hdrsize, num->_mp_size));
1566 *p++ = mpq_size_stack(mp_cpsign(den_hdrsize, den->_mp_size));
1567 p[num_wsize] = 0;
1568 mpz_load_bits(fd, p, num, ABS(num_hdrsize));
1569 p += num_wsize;
1570 p[den_wsize] = 0;
1571 mpz_load_bits(fd, p, den, ABS(den_hdrsize));
1572
1573 DEBUG(MSG_QLF_VMI, Sdprintf("Loaded MPQ to %ld\n", Stell(fd)));
1574 break;
1575 }
1576 #else
1577 fatalError("No support for MPZ numbers");
1578 #endif
1579 default:
1580 fatalError("No support for VM argtype %d (arg %d of %s)",
1581 ats[n], n, codeTable[op].name);
1582 }
1583 }
1584 switch(op)
1585 { case I_EXITFACT:
1586 case I_EXIT: /* fact */
1587 goto done;
1588 }
1589 }
1590
1591 done:
1592 exit_rlabels(&lstate);
1593
1594 if ( !skip )
1595 { size_t csize = sizeOfBuffer(&buf);
1596 size_t ncodes = (csize-sizeofClause(0))/sizeof(code);
1597 Clause bcl = baseBuffer(&buf, struct clause);
1598
1599 bcl->code_size = ncodes;
1600 clause = (Clause)PL_malloc_atomic(csize);
1601 memcpy(clause, bcl, csize);
1602
1603 if ( has_dicts )
1604 { if ( !resortDictsInClause(clause) )
1605 { outOfCore();
1606 exit(1);
1607 }
1608 }
1609 if ( csf )
1610 csf->current_procedure = proc;
1611
1612 GD->statistics.codes += clause->code_size;
1613 assertProcedureSource(csf, proc, clause PASS_LD);
1614 }
1615
1616 discardBuffer(&buf);
1617 }
1618 }
1619 }
1620 }
1621
1622
1623 static bool
runInitialization(SourceFile sf)1624 runInitialization(SourceFile sf)
1625 { int rc = FALSE;
1626
1627 if ( sf )
1628 { GET_LD
1629 fid_t fid = PL_open_foreign_frame();
1630 term_t av = PL_new_term_refs(2);
1631 static predicate_t pred = NULL;
1632
1633 if ( !pred )
1634 pred = PL_predicate("$run_initialization", 2, "system");
1635
1636 PL_put_atom(av+0, sf->name);
1637 PL_put_nil( av+1);
1638 rc = PL_call_predicate(MODULE_system, PL_Q_NORMAL, pred, av);
1639
1640 PL_discard_foreign_frame(fid);
1641 }
1642
1643 return rc;
1644 }
1645
1646
1647 static bool
loadImport(wic_state * state,int skip ARG_LD)1648 loadImport(wic_state *state, int skip ARG_LD)
1649 { Procedure proc = (Procedure) loadXR(state);
1650 int flags = getInt(state->wicFd);
1651
1652 if ( !skip )
1653 return importDefinitionModule(LD->modules.source, proc->definition, flags);
1654
1655 succeed;
1656 }
1657
1658
1659 static atom_t
qlfFixSourcePath(wic_state * state,const char * raw)1660 qlfFixSourcePath(wic_state *state, const char *raw)
1661 { char buf[MAXPATHLEN];
1662 char *canonical;
1663
1664 if ( state->load_state->has_moved &&
1665 strprefix(raw, state->load_state->save_dir) )
1666 { char *s;
1667 size_t lensave = strlen(state->load_state->save_dir);
1668 const char *tail = &raw[lensave];
1669
1670 if ( strlen(state->load_state->load_dir)+1+strlen(tail)+1 > MAXPATHLEN )
1671 fatalError("Path name too long: %s", raw);
1672
1673 strcpy(buf, state->load_state->load_dir);
1674 s = &buf[strlen(buf)];
1675 strcpy(s, tail);
1676 } else
1677 { if ( strlen(raw)+1 > MAXPATHLEN )
1678 { fatalError("Path name too long: %s", raw);
1679 return NULL_ATOM;
1680 }
1681 strcpy(buf, raw);
1682 }
1683
1684 if ( (canonical=canonicalisePath(buf)) )
1685 { atom_t translated = file_name_to_atom(canonical);
1686
1687 if ( strcmp(raw, canonical) )
1688 { path_translated *tr = PL_malloc(sizeof(*tr));
1689
1690 tr->from = file_name_to_atom(raw);
1691 tr->to = translated;
1692 tr->next = state->load_state->translated;
1693 state->load_state->translated = tr;
1694 }
1695
1696 return translated;
1697 } else
1698 { fatalError("Path name too long: %s", buf);
1699 return NULL_ATOM;
1700 }
1701 }
1702
1703
1704 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1705 (**) Note. When loading a qlf file we must do the possible reconsult
1706 stuff associated with loading sourcefiles. If we are loading a state all
1707 is nice and fresh, so we can skip that. Actually, we *must* skip that as
1708 a state is created based on modules rather than files. Multifile
1709 predicates are stored with the module. If we take no measures loading
1710 the file from which a clause originates will remove the one loaded with
1711 the module where it is a multifile one.
1712 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1713
1714 static bool
qlfLoadSource(wic_state * state)1715 qlfLoadSource(wic_state *state)
1716 { IOSTREAM *fd = state->wicFd;
1717 char *str = getString(fd, NULL);
1718 double time = getFloat(fd);
1719 int issys = (Qgetc(fd) == 's') ? TRUE : FALSE;
1720 atom_t fname;
1721
1722 if ( !str )
1723 { fatalError("Invalid QLF: illegal string");
1724 return FALSE;
1725 }
1726 fname = qlfFixSourcePath(state, str);
1727
1728 DEBUG(MSG_QLF_PATH,
1729 if ( !streq(stringAtom(fname), str) )
1730 Sdprintf("Replaced path %s --> %s\n", str, stringAtom(fname)));
1731
1732 state->currentSource = lookupSourceFile(fname, TRUE);
1733 PL_unregister_atom(fname); /* locked with sourceFile */
1734 state->currentSource->mtime = time;
1735 state->currentSource->system = issys;
1736 if ( GD->bootsession ) /* (**) */
1737 state->currentSource->count++;
1738 else
1739 startConsult(state->currentSource);
1740
1741 succeed;
1742 }
1743
1744
1745 static bool
loadModuleProperties(wic_state * state,Module m,int skip ARG_LD)1746 loadModuleProperties(wic_state *state, Module m, int skip ARG_LD)
1747 { IOSTREAM *fd = state->wicFd;
1748
1749 if ( !skip )
1750 clearSupersModule(m);
1751
1752 for(;;)
1753 { switch(Qgetc(fd))
1754 { case 'C':
1755 { atom_t cname = loadXR(state);
1756
1757 if ( !skip )
1758 m->class = cname;
1759
1760 continue;
1761 }
1762 case 'S':
1763 { atom_t sname = loadXR(state);
1764 Module s = lookupModule(sname);
1765
1766 if ( !skip )
1767 addSuperModule(m, s, 'Z');
1768
1769 continue;
1770 }
1771 case 'E':
1772 { functor_t f = (functor_t) loadXR(state);
1773
1774 if ( !skip )
1775 { Procedure proc = lookupProcedure(f, LD->modules.source);
1776
1777 addNewHTable(LD->modules.source->public, (void *)f, proc);
1778 if ( state->currentSource )
1779 exportProcedureSource(state->currentSource, m, proc);
1780 } else
1781 { if ( !lookupHTable(m->public, (void *)f) )
1782 { FunctorDef fd = valueFunctor(f);
1783
1784 warning("%s: skipped module \"%s\" lacks %s/%d",
1785 state->wicFile,
1786 stringAtom(m->name),
1787 stringAtom(fd->name),
1788 fd->arity);
1789 }
1790 }
1791
1792 continue;
1793 }
1794 case 'X':
1795 break;
1796 default:
1797 return qlfLoadError(state);
1798 }
1799 break;
1800 }
1801
1802 succeed;
1803 }
1804
1805
1806 static bool
loadPart(wic_state * state,Module * module,int skip ARG_LD)1807 loadPart(wic_state *state, Module *module, int skip ARG_LD)
1808 { IOSTREAM *fd = state->wicFd;
1809 Module om = LD->modules.source;
1810 SourceFile of = state->currentSource;
1811 int stchk = debugstatus.styleCheck;
1812 access_level_t alevel = LD->prolog_flag.access_level;
1813
1814 switch(Qgetc(fd))
1815 { case 'M':
1816 { atom_t mname = loadXR(state);
1817 int c = Qgetc(fd);
1818
1819 DEBUG(MSG_QLF_SECTION,
1820 Sdprintf("Loading module %s\n", PL_atom_chars(mname)));
1821
1822 switch( c )
1823 { case '-':
1824 { LD->modules.source = lookupModule(mname);
1825 /* TBD: clear module? */
1826 DEBUG(MSG_QLF_SECTION, Sdprintf("\tNo source\n"));
1827 break;
1828 }
1829 case 'F':
1830 { Module m;
1831 int line;
1832
1833 qlfLoadSource(state);
1834 line = getInt(fd);
1835 DEBUG(MSG_QLF_SECTION,
1836 Sdprintf("\tSource = %s:%d\n",
1837 PL_atom_chars(state->currentSource->name), line));
1838
1839 m = lookupModule(mname);
1840 if ( m->file && m->file != state->currentSource )
1841 { warning("%s:\n\tmodule \"%s\" already loaded from \"%s\" (skipped)",
1842 state->wicFile, stringAtom(m->name), stringAtom(m->file->name));
1843 skip = TRUE;
1844 LD->modules.source = m;
1845 } else
1846 { if ( !declareModule(mname, NULL_ATOM, NULL_ATOM,
1847 state->currentSource, line, FALSE) )
1848 fail;
1849 }
1850
1851 if ( module )
1852 *module = LD->modules.source;
1853
1854 break;
1855 }
1856 default:
1857 qlfLoadError(state);
1858 break;
1859 }
1860
1861 if ( !loadModuleProperties(state, LD->modules.source, skip PASS_LD) )
1862 fail;
1863
1864 break;
1865 }
1866 case 'F':
1867 { qlfLoadSource(state);
1868
1869 if ( module )
1870 *module = NULL;
1871
1872 break;
1873 }
1874 default:
1875 return qlfLoadError(state);
1876 }
1877
1878 for(;;)
1879 { int c = Qgetc(fd);
1880
1881 switch(c)
1882 { case 'X':
1883 { if ( !GD->bootsession )
1884 { runInitialization(state->currentSource);
1885 if ( state->currentSource )
1886 endConsult(state->currentSource);
1887 }
1888 LD->modules.source = om;
1889 state->currentSource = of;
1890 debugstatus.styleCheck = stchk;
1891 setAccessLevel(alevel);
1892
1893 succeed;
1894 }
1895 default:
1896 loadStatement(state, c, skip PASS_LD);
1897 }
1898 }
1899 }
1900
1901
1902 static bool
loadInModule(wic_state * state,int skip ARG_LD)1903 loadInModule(wic_state *state, int skip ARG_LD)
1904 { IOSTREAM *fd = state->wicFd;
1905 word mname = loadXR(state);
1906 Module om = LD->modules.source;
1907
1908 LD->modules.source = lookupModule(mname);
1909
1910 for(;;)
1911 { int c = Qgetc(fd);
1912
1913 switch(c)
1914 { case 'X':
1915 { LD->modules.source = om;
1916 succeed;
1917 }
1918 default:
1919 loadStatement(state, c, skip PASS_LD);
1920 }
1921 }
1922 }
1923
1924
1925 static bool
loadInclude(wic_state * state ARG_LD)1926 loadInclude(wic_state *state ARG_LD)
1927 { IOSTREAM *fd = state->wicFd;
1928 atom_t owner, pn, fn;
1929 int line;
1930 double time;
1931 fid_t fid = PL_open_foreign_frame();
1932 term_t t = PL_new_term_ref();
1933 sourceloc loc;
1934
1935 owner = loadXR(state);
1936 pn = loadXR(state);
1937 line = getInt(fd);
1938 fn = loadXR(state);
1939 time = getFloat(fd);
1940
1941 if ( !PL_unify_term(t,
1942 PL_FUNCTOR, FUNCTOR_colon2,
1943 PL_ATOM, ATOM_system,
1944 PL_FUNCTOR_CHARS, "$included", 4,
1945 PL_ATOM, pn,
1946 PL_INT, line,
1947 PL_ATOM, fn,
1948 PL_FLOAT, time) )
1949 return FALSE;
1950
1951 loc.file = pn;
1952 loc.line = line;
1953
1954 assert_term(t, NULL, CL_END, owner, &loc, 0 PASS_LD);
1955
1956 PL_discard_foreign_frame(fid);
1957 return TRUE;
1958 }
1959
1960
1961 /*******************************
1962 * WRITING .QLF FILES *
1963 *******************************/
1964
1965 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1966 The code below handles the creation of `wic' files. It offers a number
1967 of predicates which enables us to write the compilation toplevel in
1968 Prolog.
1969
1970 Note that we keep track of the `current procedure' to keep all clauses
1971 of a predicate together.
1972 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1973
1974 #define STR_NOLEN ((size_t)-1)
1975
1976 static void
putString(const char * s,size_t len,IOSTREAM * fd)1977 putString(const char *s, size_t len, IOSTREAM *fd)
1978 { const char *e;
1979
1980 if ( len == STR_NOLEN )
1981 len = strlen(s);
1982 e = &s[len];
1983
1984 putInt64(len, fd);
1985 while(s<e)
1986 { Sputc(*s, fd);
1987 s++;
1988 }
1989 }
1990
1991
1992 static void
putStringW(const pl_wchar_t * s,size_t len,IOSTREAM * fd)1993 putStringW(const pl_wchar_t *s, size_t len, IOSTREAM *fd)
1994 { const pl_wchar_t *e;
1995 IOENC oenc = fd->encoding;
1996
1997 if ( len == STR_NOLEN )
1998 len = wcslen(s);
1999 e = &s[len];
2000
2001 putInt64(len, fd);
2002 fd->encoding = ENC_UTF8;
2003 while(s<e)
2004 { Sputcode(*s, fd);
2005 s++;
2006 }
2007 fd->encoding = oenc;
2008 }
2009
2010
2011 static void
putAtom(wic_state * state,atom_t w)2012 putAtom(wic_state *state, atom_t w)
2013 { GET_LD
2014 IOSTREAM *fd = state->wicFd;
2015 atom_t mapped;
2016 Atom a;
2017 static PL_blob_t *text_blob;
2018
2019 if ( state->idMap &&
2020 (mapped = (atom_t)lookupHTable(state->idMap, (void*)w)) )
2021 { assert(isAtom(mapped));
2022 w = mapped;
2023 }
2024
2025 if ( !text_blob )
2026 text_blob = PL_find_blob_type("text");
2027
2028 a = atomValue(w);
2029 if ( a->type != text_blob )
2030 { Sputc(XR_BLOB, fd);
2031 saveXRBlobType(state, a->type);
2032 if ( a->type->save )
2033 { (*a->type->save)(a->atom, fd);
2034 } else
2035 { putString(a->name, a->length, fd);
2036 }
2037 } else
2038 { Sputc(XR_ATOM, fd);
2039 putString(a->name, a->length, fd);
2040 }
2041 }
2042
2043
2044 static void
putInt64(int64_t n,IOSTREAM * fd)2045 putInt64(int64_t n, IOSTREAM *fd)
2046 { uint64_t i = zigzag_encode(n);
2047
2048 do
2049 { int b = i&0x7f;
2050
2051 i >>= 7;
2052 if ( !i )
2053 b |= 0x80;
2054 Sputc(b, fd);
2055 } while ( i );
2056 }
2057
2058
2059 static void
putUInt(unsigned int i,IOSTREAM * fd)2060 putUInt(unsigned int i, IOSTREAM *fd)
2061 { do
2062 { int b = i&0x7f;
2063
2064 i >>= 7;
2065 if ( !i )
2066 b |= 0x80;
2067 Sputc(b, fd);
2068 } while ( i );
2069 }
2070
2071 static void
putFloat(double f,IOSTREAM * fd)2072 putFloat(double f, IOSTREAM *fd)
2073 { unsigned char *cl = (unsigned char *)&f;
2074 unsigned int i;
2075
2076 DEBUG(MSG_QLF_FLOAT, Sdprintf("putFloat(%f)\n", f));
2077
2078 for(i=0; i<BYTES_PER_DOUBLE; i++)
2079 Sputc(cl[double_byte_order[i]], fd);
2080 }
2081
2082
2083 static void
putInt32(int v,IOSTREAM * fd)2084 putInt32(int v, IOSTREAM *fd)
2085 { Sputc((v>>24)&0xff, fd);
2086 Sputc((v>>16)&0xff, fd);
2087 Sputc((v>>8)&0xff, fd);
2088 Sputc(v&0xff, fd);
2089 }
2090
2091
2092 static void
freeXRSymbol(void * name,void * value)2093 freeXRSymbol(void *name, void *value)
2094 { word w = (word)name;
2095
2096 if ( w&0x1 )
2097 { w &= ~0x1;
2098 if ( isAtom(w) )
2099 { PL_unregister_atom(w);
2100 DEBUG(5, Sdprintf("UNREG: %s\n", stringAtom(w)));
2101 }
2102 }
2103 }
2104
2105
2106 void
initXR(wic_state * state)2107 initXR(wic_state *state)
2108 { state->currentPred = NULL;
2109 state->currentSource = NULL;
2110 state->savedXRTable = newHTable(256);
2111 state->savedXRTable->free_symbol = freeXRSymbol;
2112 state->savedXRTableId = 0;
2113 }
2114
2115
2116 void
destroyXR(wic_state * state)2117 destroyXR(wic_state *state)
2118 { destroyHTable(state->savedXRTable);
2119 state->savedXRTable = NULL;
2120 if ( state->idMap )
2121 { destroyHTable(state->idMap);
2122 state->idMap = NULL;
2123 }
2124 }
2125
2126
2127 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2128 XR (External Reference) table handling. The table contains atoms,
2129 functors and various types of pointers (Module, Procedure and
2130 SourceFile). For savedXR() to work, atom_t and functor_t may not
2131 conflict with pointers. We assume -as in many other places in the code-
2132 that pointers are 4-byte aligned.
2133
2134 savedXRConstant() must be used for atom_t and functor_t, while
2135 savedXRPointer must be used for the pointers. The value for
2136 savedXRConstant() is or-ed with 0x1 to avoid conflict with pointers.
2137 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
2138
2139 static int
savedXR(wic_state * state,void * xr)2140 savedXR(wic_state *state, void *xr)
2141 { GET_LD
2142 IOSTREAM *fd = state->wicFd;
2143 unsigned int id;
2144
2145 if ( (id = (intptr_t)lookupHTable(state->savedXRTable, xr)) )
2146 { Sputc(XR_REF, fd);
2147 putUInt(id, fd);
2148
2149 succeed;
2150 } else
2151 { id = ++state->savedXRTableId;
2152 addNewHTable(state->savedXRTable, xr, (void *)(intptr_t)id);
2153 }
2154
2155 fail;
2156 }
2157
2158
2159 static inline int
savedXRConstant(wic_state * state,word w)2160 savedXRConstant(wic_state *state, word w)
2161 { int rc;
2162
2163 assert(tag(w) == TAG_ATOM); /* Only functor_t and atom_t */
2164
2165 if ( !(rc=savedXR(state, (void *)(w|0x1))) && isAtom(w) )
2166 { DEBUG(MSG_QLF_XR, Sdprintf("REG: %s\n", stringAtom(w)));
2167 PL_register_atom(w);
2168 }
2169
2170 return rc;
2171 }
2172
2173
2174 static int XRNullPointer = 0;
2175
2176 static inline int
savedXRPointer(wic_state * state,void * p)2177 savedXRPointer(wic_state *state, void *p)
2178 { assert(((word)p & 0x1) == 0);
2179
2180 if ( !p )
2181 { return savedXR(state, &XRNullPointer);
2182 }
2183
2184 return savedXR(state, p);
2185 }
2186
2187
2188 static void
saveXR__LD(wic_state * state,word xr ARG_LD)2189 saveXR__LD(wic_state *state, word xr ARG_LD)
2190 { IOSTREAM *fd = state->wicFd;
2191
2192 if ( isTaggedInt(xr) ) /* TBD: switch */
2193 { Sputc(XR_INT, fd);
2194 putInt64(valInt(xr), fd);
2195 return;
2196 } else if ( isBignum(xr) )
2197 { Sputc(XR_INT, fd);
2198 putInt64(valBignum(xr), fd);
2199 return;
2200 } else if ( isFloat(xr) )
2201 { Sputc(XR_FLOAT, fd);
2202 putFloat(valFloat(xr), fd);
2203 return;
2204 #if O_STRING
2205 } else if ( isString(xr) )
2206 { char *s;
2207 pl_wchar_t *w;
2208 size_t len;
2209
2210 if ( (s = getCharsString(xr, &len)) )
2211 { Sputc(XR_STRING, fd);
2212 putString(s, len, fd);
2213 } else if ( (w=getCharsWString(xr, &len)) )
2214 { Sputc(XR_STRING_UTF8, fd);
2215 putStringW(w, len, fd);
2216 }
2217 return;
2218 #endif /* O_STRING */
2219 }
2220
2221 if ( xr == ATOM_nil )
2222 { Sputc(XR_NIL, fd);
2223 return;
2224 }
2225 if ( xr == ATOM_dot )
2226 { Sputc(XR_CONS, fd);
2227 return;
2228 }
2229
2230
2231 if ( savedXRConstant(state, xr) )
2232 return;
2233
2234 if ( isAtom(xr) )
2235 { DEBUG(MSG_QLF_XR,
2236 Sdprintf("XR(%d) = '%s'\n", state->savedXRTableId, stringAtom(xr)));
2237 putAtom(state, xr);
2238 return;
2239 }
2240
2241 assert(0);
2242 }
2243 #define saveXR(state, xr) saveXR__LD(state, xr PASS_LD)
2244
2245
2246 static void
saveXRBlobType(wic_state * state,PL_blob_t * type)2247 saveXRBlobType(wic_state *state, PL_blob_t *type)
2248 { IOSTREAM *fd = state->wicFd;
2249
2250 if ( savedXRPointer(state, type) )
2251 return;
2252
2253 Sputc(XR_BLOB_TYPE, fd);
2254 putString(type->name, STR_NOLEN, fd);
2255 }
2256
2257
2258 static void
saveXRModule(wic_state * state,Module m ARG_LD)2259 saveXRModule(wic_state *state, Module m ARG_LD)
2260 { IOSTREAM *fd = state->wicFd;
2261
2262 if ( !m )
2263 { Sputc(XR_NULL, fd);
2264 return;
2265 }
2266
2267 if ( savedXRPointer(state, m) )
2268 return;
2269
2270 Sputc(XR_MODULE, fd);
2271 DEBUG(MSG_QLF_XR,
2272 Sdprintf("XR(%d) = module %s\n",
2273 state->savedXRTableId, stringAtom(m->name)));
2274 saveXR(state, m->name);
2275 }
2276
2277
2278 static void
saveXRFunctor(wic_state * state,functor_t f ARG_LD)2279 saveXRFunctor(wic_state *state, functor_t f ARG_LD)
2280 { IOSTREAM *fd = state->wicFd;
2281 FunctorDef fdef;
2282 functor_t mapped;
2283
2284 if ( savedXRConstant(state, f) )
2285 return;
2286
2287 if ( state->idMap &&
2288 (mapped = (functor_t)lookupHTable(state->idMap, (void*)f)) )
2289 f = mapped;
2290
2291 fdef = valueFunctor(f);
2292
2293 DEBUG(MSG_QLF_XR,
2294 Sdprintf("XR(%d) = %s/%d\n",
2295 state->savedXRTableId, stringAtom(fdef->name), fdef->arity));
2296 Sputc(XR_FUNCTOR, fd);
2297 saveXR(state, fdef->name);
2298 putInt64(fdef->arity, fd);
2299 }
2300
2301
2302 static void
saveXRProc(wic_state * state,Procedure p ARG_LD)2303 saveXRProc(wic_state *state, Procedure p ARG_LD)
2304 { IOSTREAM *fd = state->wicFd;
2305
2306 if ( savedXRPointer(state, p) )
2307 return;
2308
2309 DEBUG(MSG_QLF_XR, Sdprintf("XR(%d) = proc %s\n",
2310 state->savedXRTableId, procedureName(p)));
2311 Sputc(XR_PRED, fd);
2312 saveXRFunctor(state, p->definition->functor->functor PASS_LD);
2313 saveXRModule(state, p->definition->module PASS_LD);
2314 }
2315
2316
2317 static void
saveXRSourceFile(wic_state * state,SourceFile f ARG_LD)2318 saveXRSourceFile(wic_state *state, SourceFile f ARG_LD)
2319 { IOSTREAM *fd = state->wicFd;
2320
2321 if ( savedXRPointer(state, f) )
2322 return;
2323
2324 Sputc(XR_FILE, fd);
2325
2326 if ( f )
2327 { DEBUG(MSG_QLF_XR, Sdprintf("XR(%d) = file %s\n",
2328 state->savedXRTableId, stringAtom(f->name)));
2329 Sputc(f->system ? 's' : 'u', fd);
2330 saveXR(state, f->name);
2331 putFloat(f->mtime, fd);
2332 } else
2333 { DEBUG(MSG_QLF_XR, Sdprintf("XR(%d) = <no file>\n", state->savedXRTableId));
2334 Sputc('-', fd);
2335 }
2336 }
2337
2338
2339
2340 static void
do_save_qlf_term(wic_state * state,Word t ARG_LD)2341 do_save_qlf_term(wic_state *state, Word t ARG_LD)
2342 { IOSTREAM *fd = state->wicFd;
2343
2344 deRef(t);
2345 if ( isTerm(*t) )
2346 { functor_t f = functorTerm(*t);
2347
2348 if ( f == FUNCTOR_dvard1 )
2349 { int id = (int)valInt(argTerm(*t, 0));
2350
2351 Sputc('v', fd);
2352 putInt64(id, fd);
2353 } else
2354 { Word q = argTermP(*t, 0);
2355 int n, arity = arityFunctor(f);
2356
2357 Sputc('t', fd);
2358 saveXRFunctor(state, f PASS_LD);
2359 for(n=0; n < arity; n++, q++)
2360 do_save_qlf_term(state, q PASS_LD);
2361 }
2362 } else
2363 { assert(isAtomic(*t));
2364 saveXR(state, *t);
2365 }
2366 }
2367
2368
2369 static int
saveQlfTerm(wic_state * state,term_t t ARG_LD)2370 saveQlfTerm(wic_state *state, term_t t ARG_LD)
2371 { IOSTREAM *fd = state->wicFd;
2372 intptr_t nvars, rc=TRUE;
2373 fid_t cid;
2374 nv_options options;
2375
2376 cid = PL_open_foreign_frame();
2377
2378 DEBUG(MSG_QLF_TERM,
2379 Sdprintf("Saving ");
2380 PL_write_term(Serror, t, 1200, 0);
2381 Sdprintf(" from %d ... ", Stell(fd)));
2382
2383 options.functor = FUNCTOR_dvard1;
2384 options.on_attvar = AV_SKIP;
2385 options.singletons = FALSE; /* TBD: TRUE may be better! */
2386 options.numbered_check = TRUE; /* otherwise may be wrong */
2387
2388 if ( (nvars = numberVars(t, &options, 0 PASS_LD)) != NV_ERROR )
2389 { putInt64(nvars, fd);
2390 do_save_qlf_term(state, valTermRef(t) PASS_LD); /* TBD */
2391 DEBUG(MSG_QLF_TERM, Sdprintf("to %d\n", Stell(fd)));
2392 } else
2393 { rc = FALSE;
2394 }
2395
2396 PL_discard_foreign_frame(cid);
2397
2398 return rc;
2399 }
2400
2401
2402 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2403 Label handling
2404 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
2405
2406 typedef struct vm_wlabel
2407 { Code address;
2408 unsigned int id;
2409 } vm_wlabel;
2410
2411 typedef struct vm_wlabel_state
2412 { tmp_buffer buf;
2413 vm_wlabel current;
2414 unsigned int next_id;
2415 } vm_wlabel_state;
2416
2417 static void
init_wlabels(vm_wlabel_state * state)2418 init_wlabels(vm_wlabel_state *state)
2419 { initBuffer(&state->buf);
2420 state->current.address = NULL;
2421 state->next_id = 0;
2422 }
2423
2424 static void
exit_wlabels(vm_wlabel_state * state)2425 exit_wlabels(vm_wlabel_state *state)
2426 { assert(entriesBuffer(&state->buf, vm_wlabel) == 0);
2427 discardBuffer(&state->buf);
2428 }
2429
2430 static vm_wlabel *
push_wlabel(vm_wlabel_state * state,Code to,Clause clause)2431 push_wlabel(vm_wlabel_state *state, Code to, Clause clause)
2432 { vm_wlabel *lbl;
2433
2434 if ( state->current.address )
2435 { if ( to == state->current.address )
2436 { lbl = &state->current;
2437 } else if ( to < state->current.address )
2438 { addBuffer(&state->buf, state->current, vm_wlabel);
2439 state->current.address = to;
2440 state->current.id = ++state->next_id;
2441 lbl = &state->current;
2442 } else
2443 { vm_wlabel *top = allocFromBuffer(&state->buf, sizeof(*top));
2444 vm_wlabel *bottom = baseBuffer(&state->buf, vm_wlabel);
2445 vm_wlabel *prev = top;
2446
2447 while(prev > bottom && to > prev[-1].address)
2448 prev--;
2449 if ( prev > bottom && prev[-1].address == to )
2450 { (void)popBuffer(&state->buf, vm_wlabel);
2451 lbl = &prev[-1];
2452 } else
2453 { memmove(prev+1, prev, (char*)top - (char*)prev);
2454 prev->address = to;
2455 prev->id = ++state->next_id;
2456 lbl = prev;
2457 }
2458 }
2459 } else
2460 { state->current.address = to;
2461 state->current.id = ++state->next_id;
2462 lbl = &state->current;
2463 }
2464
2465 DEBUG(MSG_QLF_LABEL,
2466 { Sdprintf("%s, clause %d: current: %d at %p\n",
2467 predicateName(clause->predicate),
2468 clauseNo(clause, 0),
2469 state->current.id, state->current.address);
2470 vm_wlabel *top = topBuffer(&state->buf, vm_wlabel);
2471 vm_wlabel *bottom = baseBuffer(&state->buf, vm_wlabel);
2472 for(--top; top >= bottom; top--)
2473 Sdprintf(" %d at %p\n", top->id, top->address);
2474 });
2475
2476 return lbl;
2477 }
2478
2479 static void
emit_wlabels(vm_wlabel_state * state,Code here,IOSTREAM * fd)2480 emit_wlabels(vm_wlabel_state *state, Code here, IOSTREAM *fd)
2481 { while(state->current.address == here)
2482 { putUInt(V_LABEL, fd);
2483 putUInt(state->current.id, fd);
2484
2485 if ( entriesBuffer(&state->buf, vm_wlabel) != 0 )
2486 state->current = popBuffer(&state->buf, vm_wlabel);
2487 else
2488 state->current.address = NULL;
2489 }
2490 }
2491
2492
2493 #ifdef O_GMP
2494 static void
put_mpz_size(IOSTREAM * fd,mpz_t mpz,size_t * szp)2495 put_mpz_size(IOSTREAM *fd, mpz_t mpz, size_t *szp)
2496 { size_t size = (mpz_sizeinbase(mpz, 2)+7)/8;
2497 ssize_t hdrsize;
2498
2499 if ( mpz_sgn(mpz) < 0 )
2500 hdrsize = -(ssize_t)size;
2501 else
2502 hdrsize = (ssize_t)size;
2503
2504 *szp = size;
2505 putInt64(hdrsize, fd);
2506 }
2507
2508 static void
put_mpz_bits(IOSTREAM * fd,mpz_t mpz,size_t size)2509 put_mpz_bits(IOSTREAM *fd, mpz_t mpz, size_t size)
2510 { size_t i, count;
2511 char fast[1024];
2512 char *buf;
2513
2514 if ( size < sizeof(fast) )
2515 buf = fast;
2516 else
2517 buf = PL_malloc(size);
2518
2519 mpz_export(buf, &count, 1, 1, 1, 0, mpz);
2520 assert(count == size);
2521 for(i=0; i<count; i++)
2522 Sputc(buf[i]&0xff, fd);
2523 if ( buf != fast )
2524 PL_free(buf);
2525 }
2526
2527 #endif
2528
2529
2530 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2531 saveWicClause() saves a clause to the .qlf file. For predicate
2532 references of I_CALL and I_DEPART, we cannot store the predicate itself
2533 as this would lead to an inconsistency if the .qlf file is loaded into
2534 another context module. Therefore we just store the functor. For now
2535 this is ok as constructs of the form module:goal are translated using
2536 the meta-call mechanism. This needs consideration if we optimise this
2537 (which is not that likely as I think module:goal, where `module' is an
2538 atom, should be restricted to very special cases and toplevel
2539 interaction.
2540 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
2541
2542 static void
saveWicClause(wic_state * state,Clause clause)2543 saveWicClause(wic_state *state, Clause clause)
2544 { GET_LD
2545 IOSTREAM *fd = state->wicFd;
2546 Code bp, ep;
2547 vm_wlabel_state lstate;
2548
2549 Sputc('C', fd);
2550 putUInt(state->obfuscate ? 0 : clause->line_no, fd);
2551 saveXRSourceFile(state,
2552 state->obfuscate ? NULL
2553 : indexToSourceFile(clause->owner_no)
2554 PASS_LD);
2555 saveXRSourceFile(state,
2556 state->obfuscate ? NULL
2557 : indexToSourceFile(clause->source_no)
2558 PASS_LD);
2559 putUInt(clause->prolog_vars, fd);
2560 putUInt(clause->variables, fd);
2561 putUInt(true(clause, UNIT_CLAUSE) ? 0 : 1, fd);
2562
2563 bp = clause->codes;
2564 ep = bp + clause->code_size;
2565 init_wlabels(&lstate);
2566
2567 while( bp < ep )
2568 { Code si = bp; /* start instruction */
2569 unsigned int op = decode(*bp++);
2570 const char *ats = codeTable[op].argtype;
2571 int n;
2572
2573 emit_wlabels(&lstate, si, fd);
2574
2575 switch(op)
2576 { { int64_t v;
2577
2578 case H_SMALLINT:
2579 v = valInt(*bp++);
2580 goto vh_int;
2581 #if SIZEOF_VOIDP == 4
2582 case H_INT64:
2583 { Word p = (Word)&v;
2584 cpInt64Data(p, bp);
2585 goto vh_int;
2586 }
2587 #endif
2588 case H_INTEGER:
2589 v = (intptr_t)*bp++;
2590 vh_int:
2591 putUInt(V_H_INTEGER, fd);
2592 putInt64(v, fd);
2593 continue;
2594 }
2595 { int64_t v;
2596
2597 case B_SMALLINT:
2598 v = valInt(*bp++);
2599 goto vb_int;
2600 #if SIZEOF_VOIDP == 4
2601 case B_INT64:
2602 { Word p = (Word)&v;
2603 cpInt64Data(p, bp);
2604 goto vb_int;
2605 }
2606 #endif
2607 case B_INTEGER:
2608 v = (intptr_t)*bp++;
2609 vb_int:
2610 putUInt(V_B_INTEGER, fd);
2611 putInt64(v, fd);
2612 continue;
2613 }
2614 { int64_t v;
2615
2616 #if SIZEOF_VOIDP == 4
2617 case A_INT64:
2618 { Word p = (Word)&v;
2619 cpInt64Data(p, bp);
2620 goto va_int;
2621 }
2622 #endif
2623 case A_INTEGER:
2624 v = (intptr_t)*bp++;
2625 #if SIZEOF_VOIDP == 4
2626 va_int:
2627 #endif
2628 putUInt(V_A_INTEGER, fd);
2629 putInt64(v, fd);
2630 continue;
2631 }
2632 }
2633
2634 putUInt(op, fd);
2635
2636 DEBUG(MSG_QLF_VMI, Sdprintf("\t%s at %ld\n", codeTable[op].name, Stell(fd)));
2637 for(n=0; ats[n]; n++)
2638 { switch(ats[n])
2639 { case CA1_PROC:
2640 { Procedure p = (Procedure) *bp++;
2641 saveXRProc(state, p PASS_LD);
2642 break;
2643 }
2644 case CA1_MODULE:
2645 { Module m = (Module) *bp++; /* can be NULL, see I_CALLATMV */
2646 saveXRModule(state, m PASS_LD);
2647 break;
2648 }
2649 case CA1_FUNC:
2650 { functor_t f = (functor_t) *bp++;
2651 saveXRFunctor(state, f PASS_LD);
2652 break;
2653 }
2654 case CA1_AFUNC:
2655 { functor_t f = functorArithFunction((unsigned int)*bp++);
2656 saveXRFunctor(state, f PASS_LD);
2657 break;
2658 }
2659 case CA1_DATA:
2660 { word xr = (word) *bp++;
2661 saveXR(state, xr);
2662 break;
2663 }
2664 case CA1_JUMP:
2665 { Code to = stepPC(si) + *bp++;
2666 vm_wlabel *lbl = push_wlabel(&lstate, to, clause);
2667 putUInt(lbl->id, fd);
2668 break;
2669 }
2670 case CA1_INTEGER:
2671 { putInt64(*bp++, fd);
2672 break;
2673 }
2674 case CA1_VAR:
2675 case CA1_FVAR:
2676 case CA1_CHP:
2677 { intptr_t var = *bp++;
2678 putInt64(VAR_OFFSET(var), fd);
2679 break;
2680 }
2681 case CA1_INT64:
2682 { int64_t val;
2683 Word p = (Word)&val;
2684
2685 cpInt64Data(p, bp);
2686 putInt64(val, fd);
2687 break;
2688 }
2689 case CA1_FLOAT:
2690 { union
2691 { word w[WORDS_PER_DOUBLE];
2692 double f;
2693 } v;
2694 Word p = v.w;
2695 cpDoubleData(p, bp);
2696 putFloat(v.f, fd);
2697 break;
2698 }
2699 case CA1_STRING:
2700 { word m = *bp;
2701 char *s = (char *)++bp;
2702 size_t wn = wsizeofInd(m);
2703 size_t l = wn*sizeof(word) - padHdr(m);
2704 bp += wn;
2705
2706 if ( *s == 'B' )
2707 { putInt64(l, fd);
2708 while( l-- > 0 )
2709 Sputc(*s++&0xff, fd);
2710 } else
2711 { pl_wchar_t *w = (pl_wchar_t*)s + 1;
2712 IOENC oenc = fd->encoding;
2713
2714 assert(*s == 'W');
2715 l /= sizeof(pl_wchar_t);
2716 l--;
2717
2718 putInt64(l, fd);
2719 Sputc('W', fd);
2720 fd->encoding = ENC_UTF8;
2721 for( ; l-- > 0; w++)
2722 { Sputcode(*w, fd);
2723 }
2724 fd->encoding = oenc;
2725 }
2726
2727 break;
2728 }
2729 #ifdef O_GMP
2730 case CA1_MPZ:
2731 { mpz_t mpz;
2732 size_t size;
2733
2734 bp = get_mpz_from_code(bp, mpz);
2735 put_mpz_size(fd, mpz, &size);
2736 put_mpz_bits(fd, mpz, size);
2737
2738 DEBUG(MSG_QLF_VMI, Sdprintf("Saved MPZ to %ld\n", Stell(fd)));
2739 break;
2740 }
2741 case CA1_MPQ:
2742 { mpq_t mpq;
2743 size_t num_size;
2744 size_t den_size;
2745
2746 bp = get_mpq_from_code(bp, mpq);
2747 put_mpz_size(fd, mpq_numref(mpq), &num_size);
2748 put_mpz_size(fd, mpq_denref(mpq), &den_size);
2749 put_mpz_bits(fd, mpq_numref(mpq), num_size);
2750 put_mpz_bits(fd, mpq_denref(mpq), den_size);
2751
2752 DEBUG(MSG_QLF_VMI, Sdprintf("Saved MPQ to %ld\n", Stell(fd)));
2753 break;
2754 }
2755 #endif
2756 default:
2757 fatalError("No support for VM argtype %d (arg %d of %s)",
2758 ats[n], n, codeTable[op].name);
2759 }
2760 }
2761 }
2762
2763 exit_wlabels(&lstate);
2764 }
2765
2766
2767 /********************************
2768 * COMPILATION *
2769 *********************************/
2770
2771 static void
closePredicateWic(wic_state * state)2772 closePredicateWic(wic_state *state)
2773 { if ( state->currentPred )
2774 { Sputc('X', state->wicFd);
2775 state->currentPred = NULL;
2776 }
2777 }
2778
2779
2780 static unsigned int
predicateFlags(Definition def,atom_t sclass)2781 predicateFlags(Definition def, atom_t sclass)
2782 { unsigned int flags = 0;
2783
2784 if ( sclass == ATOM_kernel )
2785 { if ( true(def, P_LOCKED) && false(def, HIDE_CHILDS) )
2786 return PRED_SYSTEM;
2787 return (PRED_SYSTEM|PRED_HIDE_CHILDS);
2788 }
2789
2790 if ( true(def, P_LOCKED) )
2791 flags |= PRED_SYSTEM;
2792 if ( true(def, HIDE_CHILDS) )
2793 flags |= PRED_HIDE_CHILDS;
2794
2795 return flags;
2796 }
2797
2798
2799 static void
openPredicateWic(wic_state * state,Definition def,atom_t sclass ARG_LD)2800 openPredicateWic(wic_state *state, Definition def, atom_t sclass ARG_LD)
2801 { if ( def != state->currentPred)
2802 { IOSTREAM *fd = state->wicFd;
2803 unsigned int mode = predicateFlags(def, sclass);
2804
2805 closePredicateWic(state);
2806 state->currentPred = def;
2807
2808 if ( def->module != LD->modules.source )
2809 { Sputc('O', fd);
2810 saveXR(state, def->module->name);
2811 } else
2812 { Sputc('P', fd);
2813 }
2814
2815 saveXRFunctor(state, def->functor->functor PASS_LD);
2816 putUInt(mode, fd);
2817 }
2818 }
2819
2820
2821 static bool
putMagic(const char * s,IOSTREAM * fd)2822 putMagic(const char *s, IOSTREAM *fd)
2823 { for(; *s; s++)
2824 Sputc(*s, fd);
2825 Sputc(EOS, fd);
2826
2827 succeed;
2828 }
2829
2830
2831 static bool
writeWicHeader(wic_state * state)2832 writeWicHeader(wic_state *state)
2833 { IOSTREAM *fd = state->wicFd;
2834
2835 putMagic(saveMagic, fd);
2836 putInt64(PL_QLF_VERSION, fd);
2837 putInt64(VM_SIGNATURE, fd);
2838 if ( systemDefaults.home )
2839 putString(systemDefaults.home, STR_NOLEN, fd);
2840 else
2841 putString("<no home>", STR_NOLEN, fd);
2842
2843 initXR(state);
2844
2845 DEBUG(MSG_QLF_SECTION, Sdprintf("Header complete ...\n"));
2846 succeed;
2847 }
2848
2849
2850 static bool
writeWicTrailer(wic_state * state)2851 writeWicTrailer(wic_state *state)
2852 { IOSTREAM *fd = state->wicFd;
2853
2854 closePredicateWic(state);
2855 Sputc('X', fd);
2856 destroyXR(state);
2857 Sputc('T', fd);
2858
2859 state->wicFd = NULL;
2860 if ( state->wicFile )
2861 { remove_string(state->wicFile);
2862 state->wicFile = NULL;
2863 }
2864
2865 succeed;
2866 }
2867
2868 /* FIXME: Deal with owner/real location in saved state
2869 */
2870
2871 static bool
addClauseWic(wic_state * state,term_t term,atom_t file ARG_LD)2872 addClauseWic(wic_state *state, term_t term, atom_t file ARG_LD)
2873 { Clause clause;
2874 sourceloc loc;
2875
2876 loc.file = file;
2877 loc.line = source_line_no;
2878
2879 if ( (clause = assert_term(term, NULL, CL_END, file, &loc, 0 PASS_LD)) )
2880 { openPredicateWic(state, clause->predicate, ATOM_development PASS_LD);
2881 saveWicClause(state, clause);
2882
2883 succeed;
2884 }
2885
2886 Sdprintf("Failed to compile: "); pl_write(term); Sdprintf("\n");
2887 fail;
2888 }
2889
2890 static bool
addDirectiveWic(wic_state * state,term_t term ARG_LD)2891 addDirectiveWic(wic_state *state, term_t term ARG_LD)
2892 { IOSTREAM *fd = state->wicFd;
2893
2894 closePredicateWic(state);
2895 Sputc('D', fd);
2896 putInt64(source_line_no, fd);
2897
2898 return saveQlfTerm(state, term PASS_LD);
2899 }
2900
2901
2902 static bool
importWic(wic_state * state,Procedure proc,atom_t strength ARG_LD)2903 importWic(wic_state *state, Procedure proc, atom_t strength ARG_LD)
2904 { int flags = atomToImportStrength(strength);
2905
2906 assert(flags >= 0);
2907 closePredicateWic(state);
2908
2909 Sputc('I', state->wicFd);
2910 saveXRProc(state, proc PASS_LD);
2911 putInt64(flags, state->wicFd);
2912
2913 succeed;
2914 }
2915
2916 /*******************************
2917 * PART MARKS *
2918 *******************************/
2919
2920 static void
initSourceMarks(wic_state * state)2921 initSourceMarks(wic_state *state)
2922 { state->has_source_marks = TRUE;
2923 state->source_mark_head = NULL;
2924 state->source_mark_tail = NULL;
2925 }
2926
2927
2928 static void
sourceMark(wic_state * state)2929 sourceMark(wic_state *state)
2930 { if ( state->has_source_marks )
2931 { SourceMark pm = allocHeapOrHalt(sizeof(struct source_mark));
2932
2933 pm->file_index = Stell(state->wicFd);
2934 pm->next = NULL;
2935 if ( state->source_mark_tail )
2936 { state->source_mark_tail->next = pm;
2937 state->source_mark_tail = pm;
2938 } else
2939 { state->source_mark_tail = pm;
2940 state->source_mark_head = pm;
2941 }
2942 }
2943 }
2944
2945
2946 static int
writeSourceMarks(wic_state * state)2947 writeSourceMarks(wic_state *state)
2948 { long n = 0;
2949 SourceMark pn, pm = state->source_mark_head;
2950
2951 DEBUG(MSG_QLF_SECTION, Sdprintf("Writing source marks: "));
2952
2953 for( ; pm; pm = pn )
2954 { pn = pm->next;
2955
2956 DEBUG(MSG_QLF_SECTION, Sdprintf(" %d", pm->file_index));
2957 putInt32(pm->file_index, state->wicFd);
2958 freeHeap(pm, sizeof(*pm));
2959 n++;
2960 }
2961 state->source_mark_head = state->source_mark_tail = NULL;
2962
2963 DEBUG(MSG_QLF_SECTION, Sdprintf("\nWritten %d marks\n", n));
2964 putInt32(n, state->wicFd);
2965
2966 return 0;
2967 }
2968
2969 /* Raise an error of the format
2970
2971 error(qlf_format_error(File, Message), _)
2972 */
2973
2974 static int
qlfError(wic_state * state,const char * error,...)2975 qlfError(wic_state *state, const char *error, ...)
2976 { va_list args;
2977 char message[LINESIZ];
2978 int rc;
2979 const char *file = state->wicFile;
2980
2981 if ( !file )
2982 file = "<unknown>";
2983
2984 va_start(args, error);
2985 Svsnprintf(message, sizeof(message), error, args);
2986 va_end(args);
2987
2988 if ( GD->bootsession )
2989 { fatalError("%s: %s", file, message);
2990 rc = FALSE; /* keep compiler happy */
2991 exit(1);
2992 } else
2993 { GET_LD
2994 term_t ex, fn;
2995
2996 rc = ( (ex=PL_new_term_ref()) &&
2997 (fn=PL_new_term_ref()) &&
2998 PL_unify_chars(fn, PL_ATOM|REP_FN, (size_t)-1, file) &&
2999 PL_unify_term(ex,
3000 PL_FUNCTOR, FUNCTOR_error2,
3001 PL_FUNCTOR_CHARS, "qlf_format_error", 2,
3002 PL_TERM, fn,
3003 PL_CHARS, message,
3004 PL_VARIABLE) &&
3005 PL_raise_exception(ex) );
3006 }
3007
3008 return rc;
3009 }
3010
3011
3012 static int
qlfSourceInfo(wic_state * state,size_t offset,term_t list ARG_LD)3013 qlfSourceInfo(wic_state *state, size_t offset, term_t list ARG_LD)
3014 { IOSTREAM *s = state->wicFd;
3015 char *str;
3016 term_t head = PL_new_term_ref();
3017 atom_t fname;
3018
3019 if ( Sseek(s, (long)offset, SIO_SEEK_SET) != 0 )
3020 return qlfError(state, "seek to %zd failed: %s", offset, OsError());
3021 if ( Sgetc(s) != 'F' || !(str=getString(s, NULL)) )
3022 return qlfError(state, "invalid string (offset %zd)", offset);
3023 fname = qlfFixSourcePath(state, str);
3024
3025 return PL_unify_list(list, head, list) &&
3026 PL_unify_atom(head, fname);
3027 }
3028
3029
3030 static word
qlfInfo(const char * file,term_t cversion,term_t minload,term_t fversion,term_t csig,term_t fsig,term_t files0 ARG_LD)3031 qlfInfo(const char *file,
3032 term_t cversion, term_t minload, term_t fversion,
3033 term_t csig, term_t fsig,
3034 term_t files0 ARG_LD)
3035 { IOSTREAM *s = NULL;
3036 int lversion;
3037 int nqlf, i;
3038 size_t *qlfstart = NULL;
3039 word rval = FALSE;
3040 term_t files = PL_copy_term_ref(files0);
3041 wic_state state;
3042
3043 memset(&state, 0, sizeof(state));
3044 state.wicFile = (char*)file;
3045
3046 if ( !(s = Sopen_file(file, "rbr")) )
3047 { term_t f = PL_new_term_ref();
3048
3049 PL_put_atom_chars(f, file);
3050 return PL_error(NULL, 0, OsError(), ERR_FILE_OPERATION,
3051 ATOM_open, ATOM_source_sink, f);
3052 }
3053 state.wicFd = s;
3054
3055 if ( cversion )
3056 { int vm_signature;
3057
3058 if ( !PL_unify_integer(cversion, PL_QLF_VERSION) ||
3059 !PL_unify_integer(minload, PL_QLF_LOADVERSION) ||
3060 !PL_unify_integer(csig, (int)VM_SIGNATURE) )
3061 goto out;
3062
3063 if ( !qlfVersion(&state, qlfMagic, &lversion) ||
3064 !PL_unify_integer(fversion, lversion) )
3065 goto out;
3066
3067 vm_signature = getInt(s); /* TBD: provide to Prolog layer */
3068
3069 if ( !PL_unify_integer(fsig, vm_signature) )
3070 goto out;
3071 } else
3072 { if ( !qlfIsCompatible(&state, qlfMagic) )
3073 goto out;
3074 }
3075
3076 if ( !pushPathTranslation(&state, file, 0) )
3077 goto out;
3078
3079 if ( Sseek(s, -4, SIO_SEEK_END) < 0 ) /* 4 bytes of PutInt32() */
3080 { qlfError(&state, "seek to index failed: %s", OsError());
3081 goto out;
3082 }
3083 if ( (nqlf = getInt32(s)) < 0 )
3084 { qlfError(&state, "invalid number of files (%d)", nqlf);
3085 goto out;
3086 }
3087 if ( Sseek(s, -4 * (nqlf+1), SIO_SEEK_END) < 0 )
3088 { qlfError(&state, "seek to files failed: %s", OsError());
3089 goto out;
3090 }
3091
3092 DEBUG(MSG_QLF_SECTION, Sdprintf("Found %d sources at", nqlf));
3093 if ( !(qlfstart = malloc(sizeof(size_t)*nqlf)) )
3094 { PL_no_memory();
3095 goto out;
3096 }
3097 for(i=0; i<nqlf; i++)
3098 { qlfstart[i] = (size_t)getInt32(s);
3099 DEBUG(MSG_QLF_SECTION, Sdprintf(" %ld", qlfstart[i]));
3100 }
3101 DEBUG(MSG_QLF_SECTION, Sdprintf("\n"));
3102
3103 for(i=0; i<nqlf; i++)
3104 { if ( !qlfSourceInfo(&state, qlfstart[i], files PASS_LD) )
3105 goto out;
3106 }
3107
3108 rval = PL_unify_nil(files);
3109
3110 out:
3111 popPathTranslation(&state);
3112 if ( qlfstart )
3113 free(qlfstart);
3114 if ( s )
3115 Sclose(s);
3116
3117 return rval;
3118 }
3119
3120
3121 /** '$qlf_info'(+File,
3122 -CurrentVersion, -MinLOadVersion, -FileVersion,
3123 -CurrentSignature, -FileSignature,
3124 -Files)
3125
3126 Provide information about a QLF file.
3127
3128 @arg CurrentVersion is the current save version
3129 @arg FileVersion is the version of the file
3130 @arg CurrentSignature is the current VM signature
3131 @arg FileSignature is the signature of the file
3132 @arg Files is a list of atoms representing the files used to create the QLF
3133 */
3134
3135 static
3136 PRED_IMPL("$qlf_info", 7, qlf_info, 0)
3137 { PRED_LD
3138 char *name;
3139
3140 if ( !PL_get_file_name(A1, &name, PL_FILE_ABSOLUTE) )
3141 fail;
3142
3143 return qlfInfo(name, A2, A3, A4, A5, A6, A8 PASS_LD);
3144 }
3145
3146
3147 static
3148 PRED_IMPL("$qlf_sources", 2, qlf_sources, 0)
3149 { PRED_LD
3150 char *name;
3151
3152 if ( !PL_get_file_name(A1, &name, PL_FILE_ABSOLUTE) )
3153 fail;
3154
3155 return qlfInfo(name, 0, 0, 0, 0, 0, A2 PASS_LD);
3156 }
3157
3158
3159 /*******************************
3160 * NEW MODULE SUPPORT *
3161 *******************************/
3162
3163 static wic_state *
qlfOpen(term_t file)3164 qlfOpen(term_t file)
3165 { char *name;
3166 char *absname;
3167 char tmp[MAXPATHLEN];
3168 IOSTREAM *out;
3169 wic_state *state;
3170
3171 if ( !PL_get_file_name(file, &name, 0) ||
3172 !(absname = AbsoluteFile(name, tmp)) )
3173 return NULL;
3174
3175 if ( !(out = Sopen_file(name, "wb" TRACK_POS)) )
3176 { PL_error(NULL, 0, NULL, ERR_PERMISSION, ATOM_write, ATOM_file, file);
3177 return NULL;
3178 }
3179
3180 state = allocHeapOrHalt(sizeof(*state));
3181 memset(state, 0, sizeof(*state));
3182 state->wicFile = store_string(name);
3183 state->mkWicFile = store_string(name);
3184 state->wicFd = out;
3185 initXR(state);
3186 initSourceMarks(state);
3187
3188 putMagic(qlfMagic, state->wicFd);
3189 putInt64(PL_QLF_VERSION, state->wicFd);
3190 putInt64(VM_SIGNATURE, state->wicFd);
3191
3192 putString(absname, STR_NOLEN, state->wicFd);
3193
3194 return state;
3195 }
3196
3197
3198 static bool
qlfClose(wic_state * state ARG_LD)3199 qlfClose(wic_state *state ARG_LD)
3200 { int rc;
3201
3202 closePredicateWic(state);
3203 writeSourceMarks(state);
3204 rc = Sclose(state->wicFd);
3205 state->wicFd = NULL;
3206 if ( state->mkWicFile )
3207 { remove_string(state->mkWicFile);
3208 state->mkWicFile = NULL;
3209 }
3210 destroyXR(state);
3211
3212 LD->qlf.current_state = state->parent;
3213 freeHeap(state, sizeof(*state));
3214
3215 return rc == 0;
3216 }
3217
3218
3219 static int
qlfVersion(wic_state * state,const char * exp_magic,int * vp)3220 qlfVersion(wic_state *state, const char *exp_magic, int *vp)
3221 { IOSTREAM *s = state->wicFd;
3222 char mbuf[100];
3223 char *magic;
3224
3225 if ( !(magic = getMagicString(s, mbuf, sizeof(mbuf))) ||
3226 !streq(magic, exp_magic) )
3227 return qlfError(state, "Not a %s", exp_magic);
3228
3229 *vp = getInt(s);
3230
3231 return TRUE;
3232 }
3233
3234
3235 static int
pushPathTranslation(wic_state * state,const char * absloadname,int flags)3236 pushPathTranslation(wic_state *state, const char *absloadname, int flags)
3237 { IOSTREAM *fd = state->wicFd;
3238 char *abssavename;
3239 qlf_state *new = allocHeapOrHalt(sizeof(*new));
3240
3241 memset(new, 0, sizeof(*new));
3242 new->previous = state->load_state;
3243 state->load_state = new;
3244
3245 if ( !(abssavename = getString(fd, NULL)) )
3246 return qlfError(state, "bad string");
3247
3248 if ( absloadname && !streq(absloadname, abssavename) )
3249 { char load[MAXPATHLEN];
3250 char save[MAXPATHLEN];
3251 char *l, *s, *le, *se;
3252
3253 if ( ( strlen(abssavename)+1 > MAXPATHLEN ||
3254 strlen(absloadname)+1 > MAXPATHLEN
3255 ) )
3256 return PL_representation_error("max_path_length");
3257
3258 new->has_moved = TRUE;
3259
3260 if ( (flags & PATH_ISDIR) )
3261 { l = strcpy(load, absloadname);
3262 s = strcpy(save, abssavename);
3263 } else
3264 { l = DirName(absloadname, load);
3265 s = DirName(abssavename, save);
3266 }
3267 le = l+strlen(l);
3268 se = s+strlen(s);
3269 for( ;le>l && se>s && le[-1] == se[-1]; le--, se--)
3270 { if ( le[-1] == '/' )
3271 { *le = EOS;
3272 *se = EOS;
3273 }
3274 }
3275
3276 new->load_dir = store_string(l);
3277 new->save_dir = store_string(s);
3278 DEBUG(MSG_QLF_PATH,
3279 Sdprintf("QLF file has moved; replacing %s --> %s\n",
3280 state->load_state->save_dir,
3281 state->load_state->load_dir));
3282 }
3283
3284 return TRUE;
3285 }
3286
3287
3288 static void
popPathTranslation(wic_state * state)3289 popPathTranslation(wic_state *state)
3290 { if ( state->load_state )
3291 { qlf_state *old = state->load_state;
3292
3293 state->load_state = old->previous;
3294
3295 if ( old->has_moved )
3296 { path_translated *tr;
3297
3298 remove_string(old->load_dir);
3299 remove_string(old->save_dir);
3300
3301 if ( (tr=old->translated) )
3302 { GET_LD
3303 path_translated *n;
3304 static predicate_t pred = NULL;
3305 fid_t fid = PL_open_foreign_frame();
3306 term_t av = PL_new_term_refs(2);
3307
3308 if ( !pred )
3309 pred = PL_predicate("$translated_source", 2, "system");
3310
3311 for(; tr; tr=n)
3312 { n = tr->next;
3313
3314 PL_put_atom(av+0, tr->from);
3315 PL_put_atom(av+1, tr->to);
3316 PL_unregister_atom(tr->from);
3317
3318 if ( !PL_call_predicate(NULL, PL_Q_NORMAL, pred, av) )
3319 Sdprintf("$translated_source/2 failed~n");
3320
3321 PL_free(tr);
3322 }
3323
3324 PL_discard_foreign_frame(fid);
3325 }
3326 }
3327 freeHeap(old, sizeof(*old));
3328 }
3329 }
3330
3331 static int
qlfIsCompatible(wic_state * state,const char * magic)3332 qlfIsCompatible(wic_state *state, const char *magic)
3333 { int lversion;
3334 int vm_signature;
3335
3336 if ( !qlfVersion(state, magic, &lversion) )
3337 return FALSE;
3338 if ( lversion < PL_QLF_LOADVERSION )
3339 return qlfError(state, "incompatible version (file: %d, Prolog: %d)",
3340 lversion, PL_QLF_VERSION);
3341 state->saved_version = lversion;
3342
3343 vm_signature = getInt(state->wicFd);
3344 if ( vm_signature != (int)VM_SIGNATURE )
3345 return qlfError(state, "incompatible VM-signature (file: 0x%x; Prolog: 0x%x)",
3346 (unsigned int)vm_signature, (unsigned int)VM_SIGNATURE);
3347
3348 return TRUE;
3349 }
3350
3351
3352 static bool
qlfLoad(wic_state * state,Module * module ARG_LD)3353 qlfLoad(wic_state *state, Module *module ARG_LD)
3354 { IOSTREAM *fd = state->wicFd;
3355 bool rval;
3356 const char *absloadname;
3357 char tmp[MAXPATHLEN];
3358 atom_t file;
3359
3360 if ( (file = fileNameStream(fd)) )
3361 { PL_chars_t text;
3362
3363 if ( !get_atom_text(file, &text) )
3364 fail;
3365 if ( !PL_mb_text(&text, REP_FN) )
3366 { PL_free_text(&text);
3367 fail;
3368 }
3369 state->wicFile = store_string(text.text.t);
3370 if ( !(absloadname = AbsoluteFile(state->wicFile, tmp)) )
3371 fail;
3372 PL_free_text(&text);
3373 } else
3374 { absloadname = NULL;
3375 }
3376
3377 if ( !qlfIsCompatible(state, qlfMagic) )
3378 return FALSE;
3379
3380 if ( !pushPathTranslation(state, absloadname, 0) )
3381 return FALSE;
3382
3383 pushXrIdTable(state);
3384 for(;;)
3385 { int c = Qgetc(fd);
3386
3387 switch(c)
3388 { case 'Q':
3389 break;
3390 case 'I':
3391 loadInclude(state PASS_LD);
3392 continue;
3393 default:
3394 qlfLoadError(state);
3395 }
3396
3397 break;
3398 }
3399
3400 rval = loadPart(state, module, FALSE PASS_LD);
3401 popXrIdTable(state);
3402 popPathTranslation(state);
3403
3404 if ( state->errors.invalid_wide_chars )
3405 Sdprintf("WARNING: %d wide characters could not be represented as UCS-2\n",
3406 state->errors.invalid_wide_chars);
3407
3408 return rval;
3409 }
3410
3411
3412 static bool
qlfSaveSource(wic_state * state,SourceFile f)3413 qlfSaveSource(wic_state *state, SourceFile f)
3414 { GET_LD
3415 IOSTREAM *fd = state->wicFd;
3416 PL_chars_t text;
3417
3418 PL_STRINGS_MARK();
3419 get_atom_text(f->name, &text);
3420 PL_mb_text(&text, REP_UTF8);
3421
3422 sourceMark(state);
3423 Sputc('F', fd);
3424 putString(text.text.t, text.length, fd);
3425 putFloat(f->mtime, fd);
3426 Sputc(f->system ? 's' : 'u', fd);
3427 PL_STRINGS_RELEASE();
3428
3429 state->currentSource = f;
3430
3431 succeed;
3432 }
3433
3434
3435 static bool
qlfStartModule(wic_state * state,Module m ARG_LD)3436 qlfStartModule(wic_state *state, Module m ARG_LD)
3437 { IOSTREAM *fd = state->wicFd;
3438 ListCell c;
3439 closePredicateWic(state);
3440 Sputc('Q', fd);
3441 Sputc('M', fd);
3442 saveXR(state, m->name);
3443
3444 if ( m->file )
3445 { qlfSaveSource(state, m->file);
3446 putInt64(m->line_no, fd);
3447 } else
3448 { Sputc('-', fd);
3449 }
3450
3451 Sputc('C', fd);
3452 saveXR(state, m->class);
3453 for(c=m->supers; c; c=c->next)
3454 { Module s = c->value;
3455
3456 Sputc('S', fd);
3457 saveXR(state, s->name);
3458 }
3459
3460 DEBUG(MSG_QLF_SECTION, Sdprintf("MODULE %s\n", stringAtom(m->name)));
3461 for_table(m->public, name, value,
3462 { functor_t f = (functor_t)name;
3463
3464 DEBUG(MSG_QLF_EXPORT,
3465 Sdprintf("Exported %s/%d\n",
3466 stringAtom(nameFunctor(f)),
3467 arityFunctor(f)));
3468 Sputc('E', fd);
3469 saveXRFunctor(state, f PASS_LD);
3470 })
3471
3472 Sputc('X', fd);
3473
3474 succeed;
3475 }
3476
3477
3478 static bool
qlfStartSubModule(wic_state * state,Module m ARG_LD)3479 qlfStartSubModule(wic_state *state, Module m ARG_LD)
3480 { IOSTREAM *fd = state->wicFd;
3481
3482 closePredicateWic(state);
3483 Sputc('M', fd);
3484 saveXR(state, m->name);
3485
3486 succeed;
3487 }
3488
3489
3490 static bool
qlfStartFile(wic_state * state,SourceFile f)3491 qlfStartFile(wic_state *state, SourceFile f)
3492 { IOSTREAM *fd = state->wicFd;
3493
3494 closePredicateWic(state);
3495 Sputc('Q', fd);
3496 qlfSaveSource(state, f);
3497
3498 succeed;
3499 }
3500
3501
3502 static bool
qlfEndPart(wic_state * state)3503 qlfEndPart(wic_state *state)
3504 { IOSTREAM *fd = state->wicFd;
3505
3506 closePredicateWic(state);
3507 Sputc('X', fd);
3508
3509 succeed;
3510 }
3511
3512
3513 /** '$qlf_start_module'(+Module)
3514
3515 Start emitting a module.
3516 */
3517
3518 static
3519 PRED_IMPL("$qlf_start_module", 1, qlf_start_module, 0)
3520 { PRED_LD
3521 wic_state *state;
3522
3523 if ( (state=LD->qlf.current_state) )
3524 { Module m;
3525
3526 if ( !PL_get_module_ex(A1, &m) )
3527 fail;
3528
3529 return qlfStartModule(state, m PASS_LD);
3530 }
3531
3532 succeed;
3533 }
3534
3535
3536 static
3537 PRED_IMPL("$qlf_start_sub_module", 1, qlf_start_sub_module, 0)
3538 { PRED_LD
3539 wic_state *state;
3540
3541 if ( (state=LD->qlf.current_state) )
3542 { Module m;
3543
3544 if ( !PL_get_module_ex(A1, &m) )
3545 fail;
3546
3547 return qlfStartSubModule(state, m PASS_LD);
3548 }
3549
3550 succeed;
3551 }
3552
3553
3554 static
3555 PRED_IMPL("$qlf_start_file", 1, qlf_start_file, 0)
3556 { PRED_LD
3557 wic_state *state;
3558
3559 if ( (state=LD->qlf.current_state) )
3560 { atom_t a;
3561
3562 if ( !PL_get_atom_ex(A1, &a) )
3563 fail;
3564
3565 return qlfStartFile(state, lookupSourceFile(a, TRUE));
3566 }
3567
3568 succeed;
3569 }
3570
3571
3572 static
3573 PRED_IMPL("$qlf_current_source", 1, qlf_current_source, 0)
3574 { PRED_LD
3575 wic_state *state;
3576 SourceFile sf;
3577
3578 if ( (state=LD->qlf.current_state) &&
3579 (sf = state->currentSource) )
3580 { return PL_unify_atom(A1, sf->name);
3581 }
3582
3583 return FALSE;
3584 }
3585
3586
3587 static
3588 PRED_IMPL("$qlf_include", 5, qlf_include, 0)
3589 { PRED_LD
3590 atom_t owner, pn, fn;
3591 int line;
3592 double time;
3593 wic_state *state;
3594
3595 if ( PL_get_atom_ex(A1, &owner) &&
3596 PL_get_atom_ex(A2, &pn) &&
3597 PL_get_integer_ex(A3, &line) &&
3598 PL_get_atom_ex(A4, &fn) &&
3599 PL_get_float(A5, &time) &&
3600 (state=LD->qlf.current_state) )
3601 { IOSTREAM *fd = state->wicFd;
3602
3603 Sputc('I', fd);
3604 saveXR(state, owner);
3605 saveXR(state, pn);
3606 putInt64(line, fd);
3607 saveXR(state, fn);
3608 putFloat(time, fd);
3609
3610 return TRUE;
3611 }
3612
3613 return FALSE;
3614 }
3615
3616
3617 static
3618 PRED_IMPL("$qlf_end_part", 0, qlf_end_part, 0)
3619 { PRED_LD
3620 wic_state *state;
3621
3622 if ( (state=LD->qlf.current_state) )
3623 { return qlfEndPart(state);
3624 }
3625
3626 succeed;
3627 }
3628
3629
3630 static
3631 PRED_IMPL("$qlf_open", 1, qlf_open, 0)
3632 { PRED_LD
3633 wic_state *state = qlfOpen(A1);
3634
3635 if ( state )
3636 { state->parent = LD->qlf.current_state;
3637 LD->qlf.current_state = state;
3638
3639 return TRUE;
3640 }
3641
3642 return FALSE;
3643 }
3644
3645
3646 static
3647 PRED_IMPL("$qlf_close", 0, qlf_close, 0)
3648 { PRED_LD
3649 wic_state *state;
3650
3651 if ( (state=LD->qlf.current_state) )
3652 return qlfClose(state PASS_LD);
3653
3654 succeed;
3655 }
3656
3657
3658 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3659 $qlf_load(:Stream, -ModuleOut)
3660
3661 Load QLF data from Stream.
3662
3663 @param ModuleOut is unified to an atom holding the name of the
3664 loaded module or the integer 0 if the loaded object is
3665 not a module.
3666 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
3667
3668 static
3669 PRED_IMPL("$qlf_load", 2, qlf_load, PL_FA_TRANSPARENT)
3670 { GET_LD
3671 term_t qstream = A1;
3672 term_t module = A2;
3673 Module m, oldsrc = LD->modules.source;
3674 bool rval;
3675 term_t stream = PL_new_term_ref();
3676 IOSTREAM *fd;
3677 IOENC saved_enc;
3678 wic_state state;
3679
3680 m = oldsrc;
3681 if ( !PL_strip_module(qstream, &m, stream) )
3682 fail;
3683 if ( !PL_get_stream_handle(stream, &fd) )
3684 fail;
3685
3686 memset(&state, 0, sizeof(state));
3687 state.wicFd = fd;
3688
3689 saved_enc = fd->encoding;
3690 fd->encoding = ENC_OCTET;
3691 LD->modules.source = m;
3692 rval = qlfLoad(&state, &m PASS_LD);
3693 LD->modules.source = oldsrc;
3694 fd->encoding = saved_enc;
3695
3696 if ( state.wicFile )
3697 remove_string(state.wicFile);
3698 PL_release_stream(fd);
3699
3700 if ( rval )
3701 { if ( m )
3702 return PL_unify_atom(module, m->name);
3703
3704 return PL_unify_integer(module, 0);
3705 }
3706
3707 fail;
3708 }
3709
3710
3711 /********************************
3712 * PROLOG SUPPORT *
3713 *********************************/
3714
3715 /** '$open_wic'(+Stream) is det.
3716
3717 Write a header for a QLF-stream
3718 */
3719
3720 static const opt_spec open_wic_options[] =
3721 { { ATOM_obfuscate, OPT_BOOL },
3722 { NULL_ATOM, 0 }
3723 };
3724
3725
3726 static
3727 PRED_IMPL("$open_wic", 2, open_wic, 0)
3728 { GET_LD
3729 IOSTREAM *fd;
3730 int obfuscate = FALSE;
3731
3732 assert(V_LABEL > I_HIGHEST);
3733
3734 if ( !scan_options(A2, 0, ATOM_state_option, open_wic_options,
3735 &obfuscate) )
3736 fail;
3737
3738 if ( PL_get_stream_handle(A1, &fd) )
3739 { wic_state *state = allocHeapOrHalt(sizeof(*state));
3740
3741 memset(state, 0, sizeof(*state));
3742 state->obfuscate = obfuscate;
3743 state->wicFd = fd;
3744 writeWicHeader(state);
3745 state->parent = LD->qlf.current_state;
3746 LD->qlf.current_state = state;
3747
3748 succeed;
3749 }
3750
3751 fail; /* PL_get_stream_handle() */
3752 /* throws exception */
3753 }
3754
3755
3756 static
3757 PRED_IMPL("$close_wic", 0, close_wic, 0)
3758 { PRED_LD
3759 wic_state *state;
3760
3761 if ( (state=LD->qlf.current_state) )
3762 { writeWicTrailer(state);
3763
3764 LD->qlf.current_state = state->parent;
3765 freeHeap(state, sizeof(*state));
3766
3767 succeed;
3768 }
3769
3770 fail;
3771 }
3772
3773 static void
freeMapping(void * name,void * value)3774 freeMapping(void *name, void *value)
3775 { word id_from = (word)name;
3776 word id_to = (word)value;
3777
3778 if ( isAtom(id_from) ) PL_unregister_atom(id_from);
3779 if ( isAtom(id_to) ) PL_unregister_atom(id_to);
3780 }
3781
3782 static int
get_id(term_t t,void ** id)3783 get_id(term_t t, void **id)
3784 { GET_LD
3785 atom_t a;
3786 functor_t f;
3787
3788 if ( PL_get_atom(t, &a) )
3789 { *id = (void *)a;
3790 } else if ( PL_get_functor(t, &f) )
3791 { if ( f == FUNCTOR_colon2 )
3792 { Procedure proc;
3793
3794 if ( get_procedure(t, &proc, 0, GP_FINDHERE|GP_EXISTENCE_ERROR) )
3795 { *id = (void *)proc->definition;
3796 } else
3797 { return FALSE;
3798 }
3799 }
3800 *id = (void *)f;
3801 } else
3802 { return PL_type_error("identifier", t);
3803 }
3804
3805 return TRUE;
3806 }
3807
3808 /** '$map_id'(+IdFrom, +IdTo) is det.
3809
3810 Add a mapping between an identifier when saving a state.
3811 @arg IdFrom, IdTo are either atoms or compound terms. In the
3812 latter case the functor is mapped.
3813 */
3814
3815 static
3816 PRED_IMPL("$map_id", 2, map_id, 0)
3817 { PRED_LD
3818 wic_state *state;
3819
3820 if ( (state=LD->qlf.current_state) )
3821 { void *id_from, *id_to, *old;
3822
3823 if ( !get_id(A1, &id_from) ||
3824 !get_id(A2, &id_to) )
3825 return FALSE;
3826
3827 if ( (isAtom((word)id_from) && !isAtom((word)id_to)) ||
3828 (isFunctor((word)id_from) && !isFunctor((word)id_to)) )
3829 return PL_permission_error("map", "identifier", A1);
3830
3831 if ( !state->idMap )
3832 { state->idMap = newHTable(256);
3833 state->idMap->free_symbol = freeMapping;
3834 }
3835
3836 if ( (old=lookupHTable(state->idMap, id_from)) )
3837 { if ( old == id_to )
3838 return TRUE;
3839 else
3840 return PL_permission_error("map", "identifier", A1);
3841 } else
3842 { addNewHTable(state->idMap, id_from, id_to);
3843 if ( isAtom((word)id_from) )
3844 { PL_register_atom((atom_t)id_from);
3845 PL_register_atom((atom_t)id_to);
3846 }
3847 return TRUE;
3848 }
3849 } else {
3850 return PL_permission_error("map", "identifier", A1);
3851 }
3852 }
3853
3854 static
3855 PRED_IMPL("$unmap_id", 1, unmap_id, 0)
3856 { PRED_LD
3857 wic_state *state;
3858
3859 if ( (state=LD->qlf.current_state) )
3860 { void *id_from;
3861
3862 if ( !get_id(A1, &id_from) )
3863 return FALSE;
3864
3865 if ( state->idMap )
3866 deleteHTable(state->idMap, id_from);
3867 }
3868
3869 return TRUE;
3870 }
3871
3872
3873 static
3874 PRED_IMPL("$add_directive_wic", 1, add_directive_wic, PL_FA_TRANSPARENT)
3875 { PRED_LD
3876 wic_state *state;
3877
3878 if ( (state=LD->qlf.current_state) )
3879 { Module m = MODULE_system;
3880 term_t term = PL_new_term_ref();
3881 term_t qterm = PL_new_term_ref();
3882
3883 if ( !PL_strip_module(A1, &m, term) )
3884 return FALSE;
3885 if ( !(PL_is_callable(term)) )
3886 return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_callable, A1);
3887
3888 if ( !PL_unify_term(qterm,
3889 PL_FUNCTOR, FUNCTOR_colon2,
3890 PL_ATOM, m->name,
3891 PL_TERM, term) )
3892 return FALSE;
3893
3894 return addDirectiveWic(state, qterm PASS_LD);
3895 }
3896
3897 succeed;
3898 }
3899
3900
3901 /** '$import_wic'(+Module, +PredicateIndicator, +Strength)
3902 */
3903
3904 static
3905 PRED_IMPL("$import_wic", 3, import_wic, 0)
3906 { PRED_LD
3907 wic_state *state;
3908
3909 if ( (state=LD->qlf.current_state) )
3910 { Module m = NULL;
3911 functor_t fd;
3912 atom_t strength;
3913
3914 if ( !PL_get_module(A1, &m) ||
3915 !get_functor(A2, &fd, &m, 0, GF_PROCEDURE) ||
3916 !PL_get_atom_ex(A3, &strength) )
3917 fail;
3918
3919 return importWic(state, lookupProcedure(fd, m), strength PASS_LD);
3920 }
3921
3922 succeed;
3923 }
3924
3925
3926 /** '$qlf_assert_clause'(+ClauseRef, +Class) is det.
3927 */
3928
3929 static
3930 PRED_IMPL("$qlf_assert_clause", 2, qlf_assert_clause, 0)
3931 { PRED_LD
3932 wic_state *state;
3933
3934 if ( (state=LD->qlf.current_state) )
3935 { Clause clause;
3936 atom_t sclass;
3937
3938 if ( (PL_get_clref(A1, &clause) != TRUE) ||
3939 !PL_get_atom_ex(A2, &sclass) )
3940 fail;
3941
3942 openPredicateWic(state, clause->predicate, sclass PASS_LD);
3943 saveWicClause(state, clause);
3944 }
3945
3946 succeed;
3947 }
3948
3949
3950 /********************************
3951 * BOOTSTRAP COMPILATION *
3952 *********************************/
3953
3954 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3955 The code below offers a restricted compilation toplevel used for the
3956 bootstrap compilation (-b option). It handles most things the Prolog
3957 defined compiler handles as well, except:
3958
3959 - Be carefull to define a predicate first before using it as a
3960 directive
3961 - It does not offer `consult', `ensure_loaded' or the list notation.
3962 (there is no way to include other files).
3963 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
3964
3965 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3966 Check whether clause is of the form :- directive. If so, put the
3967 directive in directive and succeed. If the term has no explicit module
3968 tag, add one from the current source-module.
3969 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
3970
3971 static int
directiveClause(term_t directive,term_t clause,const char * functor)3972 directiveClause(term_t directive, term_t clause, const char *functor)
3973 { GET_LD
3974 atom_t name;
3975 size_t arity;
3976 term_t d0 = PL_new_term_ref();
3977 functor_t f;
3978
3979 if ( !PL_get_name_arity(clause, &name, &arity) ||
3980 arity != 1 ||
3981 !streq(stringAtom(name), functor) )
3982 fail;
3983
3984 _PL_get_arg(1, clause, d0);
3985 if ( PL_get_functor(d0, &f) && f == FUNCTOR_colon2 )
3986 { PL_put_term(directive, d0);
3987 } else
3988 { term_t m;
3989
3990 if ( !(m = PL_new_term_ref()) )
3991 return FALSE;
3992 PL_put_atom(m, LD->modules.source->name);
3993 return PL_cons_functor(directive, FUNCTOR_colon2, m, d0);
3994 }
3995
3996 succeed;
3997 }
3998
3999 /* Compile an entire file into intermediate code.
4000
4001 ** Thu Apr 28 13:44:43 1988 jan@swivax.UUCP (Jan Wielemaker) */
4002
4003 static bool
compileFile(wic_state * state,const char * file)4004 compileFile(wic_state *state, const char *file)
4005 { GET_LD
4006 char tmp[MAXPATHLEN];
4007 char *path;
4008 term_t f = PL_new_term_ref();
4009 SourceFile sf;
4010 atom_t nf;
4011
4012 DEBUG(MSG_QLF_BOOT, Sdprintf("Boot compilation of %s\n", file));
4013 if ( !(path = AbsoluteFile(file, tmp)) )
4014 fail;
4015 DEBUG(MSG_QLF_PATH, Sdprintf("Expanded to %s\n", path));
4016
4017 if ( PL_unify_chars(f, PL_ATOM|REP_MB, (size_t)-1, path) )
4018 PL_get_atom(f, &nf);
4019 else
4020 fatalError("Could not unify path");
4021 DEBUG(MSG_QLF_BOOT, Sdprintf("Opening\n"));
4022 if ( !pl_see(f) )
4023 { Sdprintf("Failed to open %s\n", path);
4024 return FALSE;
4025 }
4026 DEBUG(MSG_QLF_BOOT, Sdprintf("pl_start_consult()\n"));
4027 sf = lookupSourceFile(nf, TRUE);
4028 startConsult(sf);
4029 if ( !LastModifiedFile(path, &sf->mtime) )
4030 Sdprintf("Failed to get time from %s\n", path);
4031 qlfStartFile(state, sf);
4032
4033 for(;;)
4034 { fid_t cid = PL_open_foreign_frame();
4035 term_t t = PL_new_term_ref();
4036 term_t directive = PL_new_term_ref();
4037 atom_t eof;
4038
4039 DEBUG(2, Sdprintf("pl_read_clause() -> "));
4040 PL_put_variable(t);
4041 if ( !read_clause(Scurin, t, 0 PASS_LD) ) /* syntax error */
4042 { Sdprintf("%s:%d: Syntax error\n",
4043 PL_atom_chars(source_file_name),
4044 source_line_no);
4045 continue;
4046 }
4047 if ( PL_get_atom(t, &eof) && eof == ATOM_end_of_file )
4048 break;
4049
4050 DEBUG(MSG_QLF_BOOT_READ,
4051 PL_write_term(Serror, t, 1200, PL_WRT_NUMBERVARS);
4052 Sdprintf("\n"));
4053
4054 if ( directiveClause(directive, t, ":-") )
4055 { DEBUG(MSG_QLF_DIRECTIVE,
4056 Sdprintf(":- ");
4057 PL_write_term(Serror, directive, 1200, 0);
4058 Sdprintf(".\n") );
4059 addDirectiveWic(state, directive PASS_LD);
4060 if ( !callProlog(MODULE_user, directive, PL_Q_NODEBUG, NULL) )
4061 Sdprintf("%s:%d: directive failed\n",
4062 PL_atom_chars(source_file_name),
4063 source_line_no);
4064 } else if ( directiveClause(directive, t, "$:-") )
4065 { DEBUG(MSG_QLF_DIRECTIVE,
4066 Sdprintf("$:- ");
4067 PL_write_term(Serror, directive, 1200, 0);
4068 Sdprintf(".\n"));
4069 callProlog(MODULE_user, directive, PL_Q_NODEBUG, NULL);
4070 } else
4071 addClauseWic(state, t, nf PASS_LD);
4072
4073 PL_discard_foreign_frame(cid);
4074 }
4075
4076 qlfEndPart(state);
4077 pl_seen();
4078
4079 succeed;
4080 }
4081
4082
4083 bool
compileFileList(IOSTREAM * fd,int argc,char ** argv)4084 compileFileList(IOSTREAM *fd, int argc, char **argv)
4085 { GET_LD
4086 wic_state *state = allocHeapOrHalt(sizeof(*state));
4087 predicate_t pred;
4088 int rc;
4089 access_level_t alevel;
4090
4091 memset(state, 0, sizeof(*state));
4092 state->wicFd = fd;
4093
4094 if ( !writeWicHeader(state) )
4095 return FALSE;
4096
4097 alevel = setAccessLevel(ACCESS_LEVEL_SYSTEM);
4098 PL_set_prolog_flag("autoload", PL_BOOL, FALSE);
4099
4100 LD->qlf.current_state = state; /* make Prolog compilation go into state */
4101 for(;argc > 0; argc--, argv++)
4102 { if ( streq(argv[0], "-c" ) )
4103 break;
4104 if ( !compileFile(state, argv[0]) )
4105 return FALSE;
4106 }
4107
4108 PL_set_prolog_flag("autoload", PL_BOOL, TRUE);
4109 setAccessLevel(alevel);
4110
4111 pred = PL_predicate("$load_additional_boot_files", 0, "user");
4112 rc = PL_call_predicate(MODULE_user, TRUE, pred, 0);
4113 if ( rc )
4114 rc = writeWicTrailer(state);
4115
4116 LD->qlf.current_state = NULL;
4117 freeHeap(state, sizeof(*state));
4118
4119 return rc;
4120 }
4121
4122
4123 /*******************************
4124 * CLEANUP *
4125 *******************************/
4126
4127 void
qlfCleanup(void)4128 qlfCleanup(void)
4129 { GET_LD
4130 wic_state *state;
4131 char *buf;
4132
4133 while ( (state=LD->qlf.current_state) )
4134 { if ( state->mkWicFile )
4135 { if ( !printMessage(ATOM_warning,
4136 PL_FUNCTOR_CHARS, "qlf", 1,
4137 PL_FUNCTOR_CHARS, "removed_after_error", 1,
4138 PL_CHARS, state->mkWicFile) )
4139 PL_clear_exception();
4140 RemoveFile(state->mkWicFile);
4141 remove_string(state->mkWicFile);
4142 state->mkWicFile = NULL;
4143 }
4144
4145 LD->qlf.current_state = state->parent;
4146 freeHeap(state, sizeof(*state));
4147 }
4148
4149 if ( (buf=LD->qlf.getstr_buffer) )
4150 { LD->qlf.getstr_buffer = NULL;
4151 LD->qlf.getstr_buffer_size = 0;
4152 free(buf);
4153 }
4154 }
4155
4156 /*******************************
4157 * PUBLIC FUNCTIONS *
4158 *******************************/
4159
4160 void
wicPutStringW(const pl_wchar_t * w,size_t len,IOSTREAM * fd)4161 wicPutStringW(const pl_wchar_t *w, size_t len, IOSTREAM *fd)
4162 { putStringW(w, len, fd);
4163 }
4164
4165
4166 /*******************************
4167 * PUBLISH PREDICATES *
4168 *******************************/
4169
4170 BeginPredDefs(wic)
4171 PRED_DEF("$qlf_info", 7, qlf_info, 0)
4172 PRED_DEF("$qlf_sources", 2, qlf_sources, 0)
4173 PRED_DEF("$qlf_load", 2, qlf_load, PL_FA_TRANSPARENT)
4174 PRED_DEF("$add_directive_wic", 1, add_directive_wic, PL_FA_TRANSPARENT)
4175 PRED_DEF("$qlf_start_module", 1, qlf_start_module, 0)
4176 PRED_DEF("$qlf_start_sub_module", 1, qlf_start_sub_module, 0)
4177 PRED_DEF("$qlf_start_file", 1, qlf_start_file, 0)
4178 PRED_DEF("$qlf_current_source", 1, qlf_current_source, 0)
4179 PRED_DEF("$qlf_include", 5, qlf_include, 0)
4180 PRED_DEF("$qlf_end_part", 0, qlf_end_part, 0)
4181 PRED_DEF("$qlf_open", 1, qlf_open, 0)
4182 PRED_DEF("$qlf_close", 0, qlf_close, 0)
4183 PRED_DEF("$qlf_assert_clause", 2, qlf_assert_clause, 0)
4184 PRED_DEF("$open_wic", 2, open_wic, 0)
4185 PRED_DEF("$close_wic", 0, close_wic, 0)
4186 PRED_DEF("$map_id", 2, map_id, 0)
4187 PRED_DEF("$unmap_id", 1, unmap_id, 0)
4188 PRED_DEF("$import_wic", 3, import_wic, 0)
4189 EndPredDefs
4190