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)  1995-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:- module(qsave,
38          [ qsave_program/1,                    % +File
39            qsave_program/2                     % +File, +Options
40          ]).
41:- use_module(library(zip)).
42:- use_module(library(lists)).
43:- use_module(library(option)).
44:- use_module(library(error)).
45:- use_module(library(apply)).
46
47/** <module> Save current program as a state or executable
48
49This library provides qsave_program/1  and   qsave_program/2,  which are
50also used by the commandline sequence below.
51
52  ==
53  swipl -o exe -c file.pl ...
54  ==
55*/
56
57:- meta_predicate
58    qsave_program(+, :).
59
60:- multifile error:has_type/2.
61error:has_type(qsave_foreign_option, Term) :-
62    is_of_type(oneof([save, no_save]), Term),
63    !.
64error:has_type(qsave_foreign_option, arch(Archs)) :-
65    is_of_type(list(atom), Archs),
66    !.
67
68save_option(stack_limit, integer,
69            "Stack limit (bytes)").
70save_option(goal,        callable,
71            "Main initialization goal").
72save_option(toplevel,    callable,
73            "Toplevel goal").
74save_option(init_file,   atom,
75            "Application init file").
76save_option(packs,       boolean,
77            "Do (not) attach packs").
78save_option(class,       oneof([runtime,development]),
79            "Development state").
80save_option(op,          oneof([save,standard]),
81            "Save operators").
82save_option(autoload,    boolean,
83            "Resolve autoloadable predicates").
84save_option(map,         atom,
85            "File to report content of the state").
86save_option(stand_alone, boolean,
87            "Add emulator at start").
88save_option(traditional, boolean,
89            "Use traditional mode").
90save_option(emulator,    ground,
91            "Emulator to use").
92save_option(foreign,     qsave_foreign_option,
93            "Include foreign code in state").
94save_option(obfuscate,   boolean,
95            "Obfuscate identifiers").
96save_option(verbose,     boolean,
97            "Be more verbose about the state creation").
98save_option(undefined,   oneof([ignore,error]),
99            "How to handle undefined predicates").
100
101term_expansion(save_pred_options,
102               (:- predicate_options(qsave_program/2, 2, Options))) :-
103    findall(O,
104            ( save_option(Name, Type, _),
105              O =.. [Name,Type]
106            ),
107            Options).
108
109save_pred_options.
110
111:- set_prolog_flag(generate_debug_info, false).
112
113:- dynamic
114    verbose/1,
115    saved_resource_file/1.
116:- volatile
117    verbose/1,                  % contains a stream-handle
118    saved_resource_file/1.
119
120%!  qsave_program(+File) is det.
121%!  qsave_program(+File, :Options) is det.
122%
123%   Make a saved state in file `File'.
124
125qsave_program(File) :-
126    qsave_program(File, []).
127
128qsave_program(FileBase, Options0) :-
129    meta_options(is_meta, Options0, Options),
130    check_options(Options),
131    exe_file(FileBase, File, Options),
132    option(class(SaveClass),    Options, runtime),
133    option(init_file(InitFile), Options, DefInit),
134    default_init_file(SaveClass, DefInit),
135    prepare_entry_points(Options),
136    save_autoload(Options),
137    setup_call_cleanup(
138        open_map(Options),
139        ( prepare_state(Options),
140          create_prolog_flag(saved_program, true, []),
141          create_prolog_flag(saved_program_class, SaveClass, []),
142          delete_if_exists(File),    % truncate will crash a Prolog
143                                     % running on this state
144          setup_call_catcher_cleanup(
145              open(File, write, StateOut, [type(binary)]),
146              write_state(StateOut, SaveClass, InitFile, Options),
147              Reason,
148              finalize_state(Reason, StateOut, File))
149        ),
150        close_map),
151    cleanup,
152    !.
153
154write_state(StateOut, SaveClass, InitFile, Options) :-
155    make_header(StateOut, SaveClass, Options),
156    setup_call_cleanup(
157        zip_open_stream(StateOut, RC, []),
158        write_zip_state(RC, SaveClass, InitFile, Options),
159        zip_close(RC, [comment('SWI-Prolog saved state')])),
160    flush_output(StateOut).
161
162write_zip_state(RC, SaveClass, InitFile, Options) :-
163    save_options(RC, SaveClass,
164                 [ init_file(InitFile)
165                 | Options
166                 ]),
167    save_resources(RC, SaveClass),
168    lock_files(SaveClass),
169    save_program(RC, SaveClass, Options),
170    save_foreign_libraries(RC, Options).
171
172finalize_state(exit, StateOut, File) :-
173    close(StateOut),
174    '$mark_executable'(File).
175finalize_state(!, StateOut, File) :-
176    print_message(warning, qsave(nondet)),
177    finalize_state(exit, StateOut, File).
178finalize_state(_, StateOut, File) :-
179    close(StateOut, [force(true)]),
180    catch(delete_file(File),
181          Error,
182          print_message(error, Error)).
183
184cleanup :-
185    retractall(saved_resource_file(_)).
186
187is_meta(goal).
188is_meta(toplevel).
189
190exe_file(Base, Exe, Options) :-
191    current_prolog_flag(windows, true),
192    option(stand_alone(true), Options, true),
193    file_name_extension(_, '', Base),
194    !,
195    file_name_extension(Base, exe, Exe).
196exe_file(Exe, Exe, _).
197
198default_init_file(runtime, none) :- !.
199default_init_file(_,       InitFile) :-
200    '$cmd_option_val'(init_file, InitFile).
201
202delete_if_exists(File) :-
203    (   exists_file(File)
204    ->  delete_file(File)
205    ;   true
206    ).
207
208                 /*******************************
209                 *           HEADER             *
210                 *******************************/
211
212%!  make_header(+Out:stream, +SaveClass, +Options) is det.
213
214make_header(Out, _, Options) :-
215    option(emulator(OptVal), Options),
216    !,
217    absolute_file_name(OptVal, [access(read)], Emulator),
218    setup_call_cleanup(
219        open(Emulator, read, In, [type(binary)]),
220        copy_stream_data(In, Out),
221        close(In)).
222make_header(Out, _, Options) :-
223    (   current_prolog_flag(windows, true)
224    ->  DefStandAlone = true
225    ;   DefStandAlone = false
226    ),
227    option(stand_alone(true), Options, DefStandAlone),
228    !,
229    current_prolog_flag(executable, Executable),
230    setup_call_cleanup(
231        open(Executable, read, In, [type(binary)]),
232        copy_stream_data(In, Out),
233        close(In)).
234make_header(Out, SaveClass, _Options) :-
235    current_prolog_flag(unix, true),
236    !,
237    current_prolog_flag(executable, Executable),
238    current_prolog_flag(posix_shell, Shell),
239    format(Out, '#!~w~n', [Shell]),
240    format(Out, '# SWI-Prolog saved state~n', []),
241    (   SaveClass == runtime
242    ->  ArgSep = ' -- '
243    ;   ArgSep = ' '
244    ),
245    format(Out, 'exec ${SWIPL-~w} -x "$0"~w"$@"~n~n', [Executable, ArgSep]).
246make_header(_, _, _).
247
248
249                 /*******************************
250                 *           OPTIONS            *
251                 *******************************/
252
253min_stack(stack_limit, 100_000).
254
255convert_option(Stack, Val, NewVal, '~w') :-     % stack-sizes are in K-bytes
256    min_stack(Stack, Min),
257    !,
258    (   Val == 0
259    ->  NewVal = Val
260    ;   NewVal is max(Min, Val)
261    ).
262convert_option(toplevel, Callable, Callable, '~q') :- !.
263convert_option(_, Value, Value, '~w').
264
265doption(Name) :- min_stack(Name, _).
266doption(init_file).
267doption(system_init_file).
268doption(class).
269doption(home).
270
271%!  save_options(+ArchiveHandle, +SaveClass, +Options)
272%
273%   Save the options in the '$options'   resource. The home directory is
274%   saved for development  states  to  make   it  keep  refering  to the
275%   development home.
276%
277%   The script files (-s script) are not saved   at all. I think this is
278%   fine to avoid a save-script loading itself.
279
280save_options(RC, SaveClass, Options) :-
281    zipper_open_new_file_in_zip(RC, '$prolog/options.txt', Fd, []),
282    (   doption(OptionName),
283            '$cmd_option_val'(OptionName, OptionVal0),
284            save_option_value(SaveClass, OptionName, OptionVal0, OptionVal1),
285            OptTerm =.. [OptionName,OptionVal2],
286            (   option(OptTerm, Options)
287            ->  convert_option(OptionName, OptionVal2, OptionVal, FmtVal)
288            ;   OptionVal = OptionVal1,
289                FmtVal = '~w'
290            ),
291            atomics_to_string(['~w=', FmtVal, '~n'], Fmt),
292            format(Fd, Fmt, [OptionName, OptionVal]),
293        fail
294    ;   true
295    ),
296    save_init_goals(Fd, Options),
297    close(Fd).
298
299%!  save_option_value(+SaveClass, +OptionName, +OptionValue, -FinalValue)
300
301save_option_value(Class,   class, _,     Class) :- !.
302save_option_value(runtime, home,  _,     _) :- !, fail.
303save_option_value(_,       _,     Value, Value).
304
305%!  save_init_goals(+Stream, +Options)
306%
307%   Save initialization goals. If there  is   a  goal(Goal)  option, use
308%   that, else save the goals from '$cmd_option_val'/2.
309
310save_init_goals(Out, Options) :-
311    option(goal(Goal), Options),
312    !,
313    format(Out, 'goal=~q~n', [Goal]),
314    save_toplevel_goal(Out, halt, Options).
315save_init_goals(Out, Options) :-
316    '$cmd_option_val'(goals, Goals),
317    forall(member(Goal, Goals),
318           format(Out, 'goal=~w~n', [Goal])),
319    (   Goals == []
320    ->  DefToplevel = default
321    ;   DefToplevel = halt
322    ),
323    save_toplevel_goal(Out, DefToplevel, Options).
324
325save_toplevel_goal(Out, _Default, Options) :-
326    option(toplevel(Goal), Options),
327    !,
328    unqualify_reserved_goal(Goal, Goal1),
329    format(Out, 'toplevel=~q~n', [Goal1]).
330save_toplevel_goal(Out, _Default, _Options) :-
331    '$cmd_option_val'(toplevel, Toplevel),
332    Toplevel \== default,
333    !,
334    format(Out, 'toplevel=~w~n', [Toplevel]).
335save_toplevel_goal(Out, Default, _Options) :-
336    format(Out, 'toplevel=~q~n', [Default]).
337
338unqualify_reserved_goal(_:prolog, prolog) :- !.
339unqualify_reserved_goal(_:default, default) :- !.
340unqualify_reserved_goal(Goal, Goal).
341
342
343                 /*******************************
344                 *           RESOURCES          *
345                 *******************************/
346
347save_resources(_RC, development) :- !.
348save_resources(RC, _SaveClass) :-
349    feedback('~nRESOURCES~n~n', []),
350    copy_resources(RC),
351    forall(declared_resource(Name, FileSpec, Options),
352           save_resource(RC, Name, FileSpec, Options)).
353
354declared_resource(RcName, FileSpec, []) :-
355    current_predicate(_, M:resource(_,_)),
356    M:resource(Name, FileSpec),
357    mkrcname(M, Name, RcName).
358declared_resource(RcName, FileSpec, Options) :-
359    current_predicate(_, M:resource(_,_,_)),
360    M:resource(Name, A2, A3),
361    (   is_list(A3)
362    ->  FileSpec = A2,
363        Options = A3
364    ;   FileSpec = A3
365    ),
366    mkrcname(M, Name, RcName).
367
368%!  mkrcname(+Module, +NameSpec, -Name)
369%
370%   Turn a resource name term into a resource name atom.
371
372mkrcname(user, Name0, Name) :-
373    !,
374    path_segments_to_atom(Name0, Name).
375mkrcname(M, Name0, RcName) :-
376    path_segments_to_atom(Name0, Name),
377    atomic_list_concat([M, :, Name], RcName).
378
379path_segments_to_atom(Name0, Name) :-
380    phrase(segments_to_atom(Name0), Atoms),
381    atomic_list_concat(Atoms, /, Name).
382
383segments_to_atom(Var) -->
384    { var(Var), !,
385      instantiation_error(Var)
386    }.
387segments_to_atom(A/B) -->
388    !,
389    segments_to_atom(A),
390    segments_to_atom(B).
391segments_to_atom(A) -->
392    [A].
393
394%!  save_resource(+Zipper, +Name, +FileSpec, +Options) is det.
395%
396%   Add the content represented by FileSpec to Zipper under Name.
397
398save_resource(RC, Name, FileSpec, _Options) :-
399    absolute_file_name(FileSpec,
400                       [ access(read),
401                         file_errors(fail)
402                       ], File),
403    !,
404    feedback('~t~8|~w~t~32|~w~n',
405             [Name, File]),
406    zipper_append_file(RC, Name, File, []).
407save_resource(RC, Name, FileSpec, Options) :-
408    findall(Dir,
409            absolute_file_name(FileSpec, Dir,
410                               [ access(read),
411                                 file_type(directory),
412                                 file_errors(fail),
413                                 solutions(all)
414                               ]),
415            Dirs),
416    Dirs \== [],
417    !,
418    forall(member(Dir, Dirs),
419           ( feedback('~t~8|~w~t~32|~w~n',
420                      [Name, Dir]),
421             zipper_append_directory(RC, Name, Dir, Options))).
422save_resource(RC, Name, _, _Options) :-
423    '$rc_handle'(SystemRC),
424    copy_resource(SystemRC, RC, Name),
425    !.
426save_resource(_, Name, FileSpec, _Options) :-
427    print_message(warning,
428                  error(existence_error(resource,
429                                        resource(Name, FileSpec)),
430                        _)).
431
432copy_resources(ToRC) :-
433    '$rc_handle'(FromRC),
434    zipper_members(FromRC, List),
435    (   member(Name, List),
436        \+ declared_resource(Name, _, _),
437        \+ reserved_resource(Name),
438        copy_resource(FromRC, ToRC, Name),
439        fail
440    ;   true
441    ).
442
443reserved_resource('$prolog/state.qlf').
444reserved_resource('$prolog/options.txt').
445
446copy_resource(FromRC, ToRC, Name) :-
447    (   zipper_goto(FromRC, file(Name))
448    ->  true
449    ;   existence_error(resource, Name)
450    ),
451    zipper_file_info(FromRC, _Name, Attrs),
452    get_dict(time, Attrs, Time),
453    setup_call_cleanup(
454        zipper_open_current(FromRC, FdIn,
455                            [ type(binary),
456                              time(Time)
457                            ]),
458        setup_call_cleanup(
459            zipper_open_new_file_in_zip(ToRC, Name, FdOut, []),
460            ( feedback('~t~8|~w~t~24|~w~n',
461                       [Name, '<Copied from running state>']),
462              copy_stream_data(FdIn, FdOut)
463            ),
464            close(FdOut)),
465        close(FdIn)).
466
467
468		 /*******************************
469		 *           OBFUSCATE		*
470		 *******************************/
471
472%!  create_mapping(+Options) is det.
473%
474%   Call hook to obfuscate symbols.
475
476:- multifile prolog:obfuscate_identifiers/1.
477
478create_mapping(Options) :-
479    option(obfuscate(true), Options),
480    !,
481    (   predicate_property(prolog:obfuscate_identifiers(_), number_of_clauses(N)),
482        N > 0
483    ->  true
484    ;   use_module(library(obfuscate))
485    ),
486    (   catch(prolog:obfuscate_identifiers(Options), E,
487              print_message(error, E))
488    ->  true
489    ;   print_message(warning, failed(obfuscate_identifiers))
490    ).
491create_mapping(_).
492
493%!  lock_files(+SaveClass) is det.
494%
495%   When saving as `runtime`, lock all files  such that when running the
496%   program the system stops checking existence and modification time on
497%   the filesystem.
498%
499%   @tbd `system` is a poor name.  Maybe use `resource`?
500
501lock_files(runtime) :-
502    !,
503    '$set_source_files'(system).                % implies from_state
504lock_files(_) :-
505    '$set_source_files'(from_state).
506
507%!  save_program(+Zipper, +SaveClass, +Options) is det.
508%
509%   Save the program itself as virtual machine code to Zipper.
510
511save_program(RC, SaveClass, Options) :-
512    setup_call_cleanup(
513        ( zipper_open_new_file_in_zip(RC, '$prolog/state.qlf', StateFd,
514                                      [ zip64(true)
515                                      ]),
516          current_prolog_flag(access_level, OldLevel),
517          set_prolog_flag(access_level, system), % generate system modules
518          '$open_wic'(StateFd, Options)
519        ),
520        ( create_mapping(Options),
521          save_modules(SaveClass),
522          save_records,
523          save_flags,
524          save_prompt,
525          save_imports,
526          save_prolog_flags(Options),
527          save_operators(Options),
528          save_format_predicates
529        ),
530        ( '$close_wic',
531          set_prolog_flag(access_level, OldLevel),
532          close(StateFd)
533        )).
534
535
536                 /*******************************
537                 *            MODULES           *
538                 *******************************/
539
540save_modules(SaveClass) :-
541    forall(special_module(X),
542           save_module(X, SaveClass)),
543    forall((current_module(X), \+ special_module(X)),
544           save_module(X, SaveClass)).
545
546special_module(system).
547special_module(user).
548
549
550%!  prepare_entry_points(+Options)
551%
552%   Prepare  the  --goal=Goal  and  --toplevel=Goal  options.  Preparing
553%   implies autoloading the definition and declaring it _public_ such at
554%   it doesn't get obfuscated.
555
556prepare_entry_points(Options) :-
557    define_init_goal(Options),
558    define_toplevel_goal(Options).
559
560define_init_goal(Options) :-
561    option(goal(Goal), Options),
562    !,
563    entry_point(Goal).
564define_init_goal(_).
565
566define_toplevel_goal(Options) :-
567    option(toplevel(Goal), Options),
568    !,
569    entry_point(Goal).
570define_toplevel_goal(_).
571
572entry_point(Goal) :-
573    define_predicate(Goal),
574    (   \+ predicate_property(Goal, built_in),
575        \+ predicate_property(Goal, imported_from(_))
576    ->  goal_pi(Goal, PI),
577        public(PI)
578    ;   true
579    ).
580
581define_predicate(Head) :-
582    '$define_predicate'(Head),
583    !.   % autoloader
584define_predicate(Head) :-
585    strip_module(Head, _, Term),
586    functor(Term, Name, Arity),
587    throw(error(existence_error(procedure, Name/Arity), _)).
588
589goal_pi(M:G, QPI) :-
590    !,
591    strip_module(M:G, Module, Goal),
592    functor(Goal, Name, Arity),
593    QPI = Module:Name/Arity.
594goal_pi(Goal, Name/Arity) :-
595    functor(Goal, Name, Arity).
596
597%!  prepare_state(+Options) is det.
598%
599%   Prepare the executable by  running   the  `prepare_state` registered
600%   initialization hooks.
601
602prepare_state(_) :-
603    forall('$init_goal'(when(prepare_state), Goal, Ctx),
604           run_initialize(Goal, Ctx)).
605
606run_initialize(Goal, Ctx) :-
607    (   catch(Goal, E, true),
608        (   var(E)
609        ->  true
610        ;   throw(error(initialization_error(E, Goal, Ctx), _))
611        )
612    ;   throw(error(initialization_error(failed, Goal, Ctx), _))
613    ).
614
615
616                 /*******************************
617                 *            AUTOLOAD          *
618                 *******************************/
619
620%!  save_autoload(+Options) is det.
621%
622%   Resolve all autoload dependencies.
623%
624%   @error existence_error(procedures, List) if undefined(true) is
625%   in Options and there are undefined predicates.
626
627save_autoload(Options) :-
628    option(autoload(true),  Options, true),
629    !,
630    setup_call_cleanup(
631        current_prolog_flag(autoload, Old),
632        autoload_all(Options),
633        set_prolog_flag(autoload, Old)).
634save_autoload(_).
635
636
637                 /*******************************
638                 *             MODULES          *
639                 *******************************/
640
641%!  save_module(+Module, +SaveClass)
642%
643%   Saves a module
644
645save_module(M, SaveClass) :-
646    '$qlf_start_module'(M),
647    feedback('~n~nMODULE ~w~n', [M]),
648    save_unknown(M),
649    (   P = (M:_H),
650        current_predicate(_, P),
651        \+ predicate_property(P, imported_from(_)),
652        save_predicate(P, SaveClass),
653        fail
654    ;   '$qlf_end_part',
655        feedback('~n', [])
656    ).
657
658save_predicate(P, _SaveClass) :-
659    predicate_property(P, foreign),
660    !,
661    P = (M:H),
662    functor(H, Name, Arity),
663    feedback('~npre-defining foreign ~w/~d ', [Name, Arity]),
664    '$add_directive_wic'('$predefine_foreign'(M:Name/Arity)).
665save_predicate(P, SaveClass) :-
666    P = (M:H),
667    functor(H, F, A),
668    feedback('~nsaving ~w/~d ', [F, A]),
669    (   (   H = resource(_,_)
670        ;   H = resource(_,_,_)
671        ),
672        SaveClass \== development
673    ->  save_attribute(P, (dynamic)),
674        (   M == user
675        ->  save_attribute(P, (multifile))
676        ),
677        feedback('(Skipped clauses)', []),
678        fail
679    ;   true
680    ),
681    (   no_save(P)
682    ->  true
683    ;   save_attributes(P),
684        \+ predicate_property(P, (volatile)),
685        (   nth_clause(P, _, Ref),
686            feedback('.', []),
687            '$qlf_assert_clause'(Ref, SaveClass),
688            fail
689        ;   true
690        )
691    ).
692
693no_save(P) :-
694    predicate_property(P, volatile),
695    \+ predicate_property(P, dynamic),
696    \+ predicate_property(P, multifile).
697
698pred_attrib(meta_predicate(Term), Head, meta_predicate(M:Term)) :-
699    !,
700    strip_module(Head, M, _).
701pred_attrib(Attrib, Head,
702            '$set_predicate_attribute'(M:Name/Arity, AttName, Val)) :-
703    attrib_name(Attrib, AttName, Val),
704    strip_module(Head, M, Term),
705    functor(Term, Name, Arity).
706
707attrib_name(dynamic,                dynamic,                true).
708attrib_name(volatile,               volatile,               true).
709attrib_name(thread_local,           thread_local,           true).
710attrib_name(multifile,              multifile,              true).
711attrib_name(public,                 public,                 true).
712attrib_name(transparent,            transparent,            true).
713attrib_name(discontiguous,          discontiguous,          true).
714attrib_name(notrace,                trace,                  false).
715attrib_name(show_childs,            hide_childs,            false).
716attrib_name(built_in,               system,                 true).
717attrib_name(nodebug,                hide_childs,            true).
718attrib_name(quasi_quotation_syntax, quasi_quotation_syntax, true).
719attrib_name(iso,                    iso,                    true).
720
721
722save_attribute(P, Attribute) :-
723    pred_attrib(Attribute, P, D),
724    (   Attribute == built_in       % no need if there are clauses
725    ->  (   predicate_property(P, number_of_clauses(0))
726        ->  true
727        ;   predicate_property(P, volatile)
728        )
729    ;   Attribute == (dynamic)      % no need if predicate is thread_local
730    ->  \+ predicate_property(P, thread_local)
731    ;   true
732    ),
733    '$add_directive_wic'(D),
734    feedback('(~w) ', [Attribute]).
735
736save_attributes(P) :-
737    (   predicate_property(P, Attribute),
738        save_attribute(P, Attribute),
739        fail
740    ;   true
741    ).
742
743%       Save status of the unknown flag
744
745save_unknown(M) :-
746    current_prolog_flag(M:unknown, Unknown),
747    (   Unknown == error
748    ->  true
749    ;   '$add_directive_wic'(set_prolog_flag(M:unknown, Unknown))
750    ).
751
752                 /*******************************
753                 *            RECORDS           *
754                 *******************************/
755
756save_records :-
757    feedback('~nRECORDS~n', []),
758    (   current_key(X),
759        X \== '$topvar',                        % do not safe toplevel variables
760        feedback('~n~t~8|~w ', [X]),
761        recorded(X, V, _),
762        feedback('.', []),
763        '$add_directive_wic'(recordz(X, V, _)),
764        fail
765    ;   true
766    ).
767
768
769                 /*******************************
770                 *            FLAGS             *
771                 *******************************/
772
773save_flags :-
774    feedback('~nFLAGS~n~n', []),
775    (   current_flag(X),
776        flag(X, V, V),
777        feedback('~t~8|~w = ~w~n', [X, V]),
778        '$add_directive_wic'(set_flag(X, V)),
779        fail
780    ;   true
781    ).
782
783save_prompt :-
784    feedback('~nPROMPT~n~n', []),
785    prompt(Prompt, Prompt),
786    '$add_directive_wic'(prompt(_, Prompt)).
787
788
789                 /*******************************
790                 *           IMPORTS            *
791                 *******************************/
792
793%!  save_imports
794%
795%   Save  import  relations.  An  import  relation  is  saved  if  a
796%   predicate is imported from a module that is not a default module
797%   for the destination module. If  the   predicate  is  dynamic, we
798%   always define the explicit import relation to make clear that an
799%   assert must assert on the imported predicate.
800
801save_imports :-
802    feedback('~nIMPORTS~n~n', []),
803    (   predicate_property(M:H, imported_from(I)),
804        \+ default_import(M, H, I),
805        functor(H, F, A),
806        feedback('~t~8|~w:~w/~d <-- ~w~n', [M, F, A, I]),
807        '$add_directive_wic'(qsave:restore_import(M, I, F/A)),
808        fail
809    ;   true
810    ).
811
812default_import(To, Head, From) :-
813    '$get_predicate_attribute'(To:Head, (dynamic), 1),
814    predicate_property(From:Head, exported),
815    !,
816    fail.
817default_import(Into, _, From) :-
818    default_module(Into, From).
819
820%!  restore_import(+TargetModule, +SourceModule, +PI) is det.
821%
822%   Restore import relation. This notably   deals  with imports from
823%   the module =user=, avoiding a message  that the predicate is not
824%   exported.
825
826restore_import(To, user, PI) :-
827    !,
828    export(user:PI),
829    To:import(user:PI).
830restore_import(To, From, PI) :-
831    To:import(From:PI).
832
833                 /*******************************
834                 *         PROLOG FLAGS         *
835                 *******************************/
836
837save_prolog_flags(Options) :-
838    feedback('~nPROLOG FLAGS~n~n', []),
839    '$current_prolog_flag'(Flag, Value0, _Scope, write, Type),
840    \+ no_save_flag(Flag),
841    map_flag(Flag, Value0, Value, Options),
842    feedback('~t~8|~w: ~w (type ~q)~n', [Flag, Value, Type]),
843    '$add_directive_wic'(qsave:restore_prolog_flag(Flag, Value, Type)),
844    fail.
845save_prolog_flags(_).
846
847no_save_flag(argv).
848no_save_flag(os_argv).
849no_save_flag(access_level).
850no_save_flag(tty_control).
851no_save_flag(readline).
852no_save_flag(associated_file).
853no_save_flag(cpu_count).
854no_save_flag(tmp_dir).
855no_save_flag(file_name_case_handling).
856no_save_flag(hwnd).                     % should be read-only, but comes
857                                        % from user-code
858map_flag(autoload, true, false, Options) :-
859    option(class(runtime), Options, runtime),
860    option(autoload(true), Options, true),
861    !.
862map_flag(_, Value, Value, _).
863
864
865%!  restore_prolog_flag(+Name, +Value, +Type)
866%
867%   Deal  with  possibly   protected    flags   (debug_on_error  and
868%   report_error are protected flags for the runtime kernel).
869
870restore_prolog_flag(Flag, Value, _Type) :-
871    current_prolog_flag(Flag, Value),
872    !.
873restore_prolog_flag(Flag, Value, _Type) :-
874    current_prolog_flag(Flag, _),
875    !,
876    catch(set_prolog_flag(Flag, Value), _, true).
877restore_prolog_flag(Flag, Value, Type) :-
878    create_prolog_flag(Flag, Value, [type(Type)]).
879
880
881                 /*******************************
882                 *           OPERATORS          *
883                 *******************************/
884
885%!  save_operators(+Options) is det.
886%
887%   Save operators for all modules.   Operators for =system= are
888%   not saved because these are read-only anyway.
889
890save_operators(Options) :-
891    !,
892    option(op(save), Options, save),
893    feedback('~nOPERATORS~n', []),
894    forall(current_module(M), save_module_operators(M)),
895    feedback('~n', []).
896save_operators(_).
897
898save_module_operators(system) :- !.
899save_module_operators(M) :-
900    forall('$local_op'(P,T,M:N),
901           (   feedback('~n~t~8|~w ', [op(P,T,M:N)]),
902               '$add_directive_wic'(op(P,T,M:N))
903           )).
904
905
906                 /*******************************
907                 *       FORMAT PREDICATES      *
908                 *******************************/
909
910save_format_predicates :-
911    feedback('~nFORMAT PREDICATES~n', []),
912    current_format_predicate(Code, Head),
913    qualify_head(Head, QHead),
914    D = format_predicate(Code, QHead),
915    feedback('~n~t~8|~w ', [D]),
916    '$add_directive_wic'(D),
917    fail.
918save_format_predicates.
919
920qualify_head(T, T) :-
921    functor(T, :, 2),
922    !.
923qualify_head(T, user:T).
924
925
926                 /*******************************
927                 *       FOREIGN LIBRARIES      *
928                 *******************************/
929
930%!  save_foreign_libraries(+Archive, +Options) is det.
931%
932%   Save current foreign libraries into the archive.
933
934save_foreign_libraries(RC, Options) :-
935    option(foreign(save), Options),
936    !,
937    current_prolog_flag(arch, HostArch),
938    feedback('~nHOST(~w) FOREIGN LIBRARIES~n', [HostArch]),
939    save_foreign_libraries1(HostArch, RC, Options).
940save_foreign_libraries(RC, Options) :-
941    option(foreign(arch(Archs)), Options),
942    !,
943    forall(member(Arch, Archs),
944           ( feedback('~n~w FOREIGN LIBRARIES~n', [Arch]),
945             save_foreign_libraries1(Arch, RC, Options)
946           )).
947save_foreign_libraries(_, _).
948
949save_foreign_libraries1(Arch, RC, _Options) :-
950    forall(current_foreign_library(FileSpec, _Predicates),
951           ( find_foreign_library(Arch, FileSpec, EntryName, File, Time),
952             term_to_atom(EntryName, Name),
953             zipper_append_file(RC, Name, File, [time(Time)])
954           )).
955
956%!  find_foreign_library(+Architecture, +FileSpec, -EntryName, -File, -Time)
957%!								is det.
958%
959%   Find  the  shared  object  specified  by   FileSpec  for  the  named
960%   Architecture. EntryName will be the  name   of  the  file within the
961%   saved state archive. If posible, the   shared  object is stripped to
962%   reduce its size. This  is  achieved   by  calling  =|strip  -o <tmp>
963%   <shared-object>|=. Note that (if stripped) the  file is a Prolog tmp
964%   file and will be deleted on halt.
965%
966%   @bug    Should perform OS search on failure
967
968find_foreign_library(Arch, FileSpec, shlib(Arch,Name), SharedObject, Time) :-
969    FileSpec = foreign(Name),
970    (   catch(arch_find_shlib(Arch, FileSpec, File),
971              E,
972              print_message(error, E)),
973        exists_file(File)
974    ->  true
975    ;   throw(error(existence_error(architecture_shlib(Arch), FileSpec),_))
976    ),
977    time_file(File, Time),
978    strip_file(File, SharedObject).
979
980%!  strip_file(+File, -Stripped) is det.
981%
982%   Try to strip File. Unify Stripped with   File if stripping fails for
983%   some reason.
984
985strip_file(File, Stripped) :-
986    absolute_file_name(path(strip), Strip,
987                       [ access(execute),
988                         file_errors(fail)
989                       ]),
990    tmp_file(shared, Stripped),
991    (   catch(do_strip_file(Strip, File, Stripped), E,
992              (print_message(warning, E), fail))
993    ->  true
994    ;   print_message(warning, qsave(strip_failed(File))),
995        fail
996    ),
997    !.
998strip_file(File, File).
999
1000do_strip_file(Strip, File, Stripped) :-
1001    format(atom(Cmd), '"~w" -o "~w" "~w"',
1002           [Strip, Stripped, File]),
1003    shell(Cmd),
1004    exists_file(Stripped).
1005
1006%!  qsave:arch_shlib(+Architecture, +FileSpec, -File) is det.
1007%
1008%   This is a user defined hook called by qsave_program/2. It is used to
1009%   find a shared library  for  the   specified  Architecture,  named by
1010%   FileSpec. FileSpec is of  the   form  foreign(Name), a specification
1011%   usable by absolute_file_name/2. The predicate should unify File with
1012%   the absolute path for the  shared   library  that corresponds to the
1013%   specified Architecture.
1014%
1015%   If  this  predicate  fails  to  find    a  file  for  the  specified
1016%   architecture an `existence_error` is thrown.
1017
1018:- multifile arch_shlib/3.
1019
1020arch_find_shlib(Arch, FileSpec, File) :-
1021    arch_shlib(Arch, FileSpec, File),
1022    !.
1023arch_find_shlib(Arch, FileSpec, File) :-
1024    current_prolog_flag(arch, Arch),
1025    absolute_file_name(FileSpec,
1026                       [ file_type(executable),
1027                         access(read),
1028                         file_errors(fail)
1029                       ], File),
1030    !.
1031arch_find_shlib(Arch, foreign(Base), File) :-
1032    current_prolog_flag(arch, Arch),
1033    current_prolog_flag(windows, true),
1034    current_prolog_flag(executable, WinExe),
1035    prolog_to_os_filename(Exe, WinExe),
1036    file_directory_name(Exe, BinDir),
1037    file_name_extension(Base, dll, DllFile),
1038    atomic_list_concat([BinDir, /, DllFile], File),
1039    exists_file(File).
1040
1041
1042                 /*******************************
1043                 *             UTIL             *
1044                 *******************************/
1045
1046open_map(Options) :-
1047    option(map(Map), Options),
1048    !,
1049    open(Map, write, Fd),
1050    asserta(verbose(Fd)).
1051open_map(_) :-
1052    retractall(verbose(_)).
1053
1054close_map :-
1055    retract(verbose(Fd)),
1056    close(Fd),
1057    !.
1058close_map.
1059
1060feedback(Fmt, Args) :-
1061    verbose(Fd),
1062    !,
1063    format(Fd, Fmt, Args).
1064feedback(_, _).
1065
1066
1067check_options([]) :- !.
1068check_options([Var|_]) :-
1069    var(Var),
1070    !,
1071    throw(error(domain_error(save_options, Var), _)).
1072check_options([Name=Value|T]) :-
1073    !,
1074    (   save_option(Name, Type, _Comment)
1075    ->  (   must_be(Type, Value)
1076        ->  check_options(T)
1077        ;   throw(error(domain_error(Type, Value), _))
1078        )
1079    ;   throw(error(domain_error(save_option, Name), _))
1080    ).
1081check_options([Term|T]) :-
1082    Term =.. [Name,Arg],
1083    !,
1084    check_options([Name=Arg|T]).
1085check_options([Var|_]) :-
1086    throw(error(domain_error(save_options, Var), _)).
1087check_options(Opt) :-
1088    throw(error(domain_error(list, Opt), _)).
1089
1090
1091%!  zipper_append_file(+Zipper, +Name, +File, +Options) is det.
1092%
1093%   Append the content of File under Name to the open Zipper.
1094
1095zipper_append_file(_, Name, _, _) :-
1096    saved_resource_file(Name),
1097    !.
1098zipper_append_file(_, _, File, _) :-
1099    source_file(File),
1100    !.
1101zipper_append_file(Zipper, Name, File, Options) :-
1102    (   option(time(_), Options)
1103    ->  Options1 = Options
1104    ;   time_file(File, Stamp),
1105        Options1 = [time(Stamp)|Options]
1106    ),
1107    setup_call_cleanup(
1108        open(File, read, In, [type(binary)]),
1109        setup_call_cleanup(
1110            zipper_open_new_file_in_zip(Zipper, Name, Out, Options1),
1111            copy_stream_data(In, Out),
1112            close(Out)),
1113        close(In)),
1114    assertz(saved_resource_file(Name)).
1115
1116%!  zipper_add_directory(+Zipper, +Name, +Dir, +Options) is det.
1117%
1118%   Add a directory entry. Dir  is  only   used  if  there  is no option
1119%   time(Stamp).
1120
1121zipper_add_directory(Zipper, Name, Dir, Options) :-
1122    (   option(time(Stamp), Options)
1123    ->  true
1124    ;   time_file(Dir, Stamp)
1125    ),
1126    atom_concat(Name, /, DirName),
1127    (   saved_resource_file(DirName)
1128    ->  true
1129    ;   setup_call_cleanup(
1130            zipper_open_new_file_in_zip(Zipper, DirName, Out,
1131                                        [ method(store),
1132                                          time(Stamp)
1133                                        | Options
1134                                        ]),
1135            true,
1136            close(Out)),
1137        assertz(saved_resource_file(DirName))
1138    ).
1139
1140add_parent_dirs(Zipper, Name, Dir, Options) :-
1141    (   option(time(Stamp), Options)
1142    ->  true
1143    ;   time_file(Dir, Stamp)
1144    ),
1145    file_directory_name(Name, Parent),
1146    (   Parent \== Name
1147    ->  add_parent_dirs(Zipper, Parent, [time(Stamp)|Options])
1148    ;   true
1149    ).
1150
1151add_parent_dirs(_, '.', _) :-
1152    !.
1153add_parent_dirs(Zipper, Name, Options) :-
1154    zipper_add_directory(Zipper, Name, _, Options),
1155    file_directory_name(Name, Parent),
1156    (   Parent \== Name
1157    ->  add_parent_dirs(Zipper, Parent, Options)
1158    ;   true
1159    ).
1160
1161
1162%!  zipper_append_directory(+Zipper, +Name, +Dir, +Options) is det.
1163%
1164%   Append the content of  Dir  below   Name  in  the  resource archive.
1165%   Options:
1166%
1167%     - include(+Patterns)
1168%     Only add entries that match an element from Patterns using
1169%     wildcard_match/2.
1170%     - exclude(+Patterns)
1171%     Ignore entries that match an element from Patterns using
1172%     wildcard_match/2.
1173%
1174%   @tbd Process .gitignore.  There also seem to exists other
1175%   standards for this.
1176
1177zipper_append_directory(Zipper, Name, Dir, Options) :-
1178    exists_directory(Dir),
1179    !,
1180    add_parent_dirs(Zipper, Name, Dir, Options),
1181    zipper_add_directory(Zipper, Name, Dir, Options),
1182    directory_files(Dir, Members),
1183    forall(member(M, Members),
1184           (   reserved(M)
1185           ->  true
1186           ;   ignored(M, Options)
1187           ->  true
1188           ;   atomic_list_concat([Dir,M], /, Entry),
1189               atomic_list_concat([Name,M], /, Store),
1190               catch(zipper_append_directory(Zipper, Store, Entry, Options),
1191                     E,
1192                     print_message(warning, E))
1193           )).
1194zipper_append_directory(Zipper, Name, File, Options) :-
1195    zipper_append_file(Zipper, Name, File, Options).
1196
1197reserved(.).
1198reserved(..).
1199
1200%!  ignored(+File, +Options) is semidet.
1201%
1202%   Ignore File if there is an  include(Patterns) option that does *not*
1203%   match File or an exclude(Patterns) that does match File.
1204
1205ignored(File, Options) :-
1206    option(include(Patterns), Options),
1207    \+ ( (   is_list(Patterns)
1208         ->  member(Pattern, Patterns)
1209         ;   Pattern = Patterns
1210         ),
1211         glob_match(Pattern, File)
1212       ),
1213    !.
1214ignored(File, Options) :-
1215    option(exclude(Patterns), Options),
1216    (   is_list(Patterns)
1217    ->  member(Pattern, Patterns)
1218    ;   Pattern = Patterns
1219    ),
1220    glob_match(Pattern, File),
1221    !.
1222
1223glob_match(Pattern, File) :-
1224    current_prolog_flag(file_name_case_handling, case_sensitive),
1225    !,
1226    wildcard_match(Pattern, File).
1227glob_match(Pattern, File) :-
1228    wildcard_match(Pattern, File, [case_sensitive(false)]).
1229
1230
1231                /********************************
1232                *     SAVED STATE GENERATION    *
1233                *********************************/
1234
1235%!  qsave_toplevel
1236%
1237%   Called to handle `-c file` compilaton.
1238
1239:- public
1240    qsave_toplevel/0.
1241
1242qsave_toplevel :-
1243    current_prolog_flag(os_argv, Argv),
1244    qsave_options(Argv, Files, Options),
1245    '$cmd_option_val'(compileout, Out),
1246    user:consult(Files),
1247    qsave_program(Out, user:Options).
1248
1249qsave_options([], [], []).
1250qsave_options([--|_], [], []) :-
1251    !.
1252qsave_options(['-c'|T0], Files, Options) :-
1253    !,
1254    argv_files(T0, T1, Files, FilesT),
1255    qsave_options(T1, FilesT, Options).
1256qsave_options([O|T0], Files, [Option|T]) :-
1257    string_concat(--, Opt, O),
1258    split_string(Opt, =, '', [NameS|Rest]),
1259    atom_string(Name, NameS),
1260    qsave_option(Name, OptName, Rest, Value),
1261    !,
1262    Option =.. [OptName, Value],
1263    qsave_options(T0, Files, T).
1264qsave_options([_|T0], Files, T) :-
1265    qsave_options(T0, Files, T).
1266
1267argv_files([], [], Files, Files).
1268argv_files([H|T], [H|T], Files, Files) :-
1269    sub_atom(H, 0, _, _, -),
1270    !.
1271argv_files([H|T0], T, [H|Files0], Files) :-
1272    argv_files(T0, T, Files0, Files).
1273
1274%!  qsave_option(+Name, +ValueStrings, -Value) is semidet.
1275
1276qsave_option(Name, Name, [], true) :-
1277    save_option(Name, boolean, _),
1278    !.
1279qsave_option(NoName, Name, [], false) :-
1280    atom_concat('no-', Name, NoName),
1281    save_option(Name, boolean, _),
1282    !.
1283qsave_option(Name, Name, ValueStrings, Value) :-
1284    save_option(Name, Type, _),
1285    !,
1286    atomics_to_string(ValueStrings, "=", ValueString),
1287    convert_option_value(Type, ValueString, Value).
1288qsave_option(Name, Name, _Chars, _Value) :-
1289    existence_error(save_option, Name).
1290
1291convert_option_value(integer, String, Value) :-
1292    (   number_string(Value, String)
1293    ->  true
1294    ;   sub_string(String, 0, _, 1, SubString),
1295        sub_string(String, _, 1, 0, Suffix0),
1296        downcase_atom(Suffix0, Suffix),
1297        number_string(Number, SubString),
1298        suffix_multiplier(Suffix, Multiplier)
1299    ->  Value is Number * Multiplier
1300    ;   domain_error(integer, String)
1301    ).
1302convert_option_value(callable, String, Value) :-
1303    term_string(Value, String).
1304convert_option_value(atom, String, Value) :-
1305    atom_string(Value, String).
1306convert_option_value(boolean, String, Value) :-
1307    atom_string(Value, String).
1308convert_option_value(oneof(_), String, Value) :-
1309    atom_string(Value, String).
1310convert_option_value(ground, String, Value) :-
1311    atom_string(Value, String).
1312convert_option_value(qsave_foreign_option, "save", save).
1313convert_option_value(qsave_foreign_option, StrArchList, arch(ArchList)) :-
1314    split_string(StrArchList, ",", ", \t", StrArchList1),
1315    maplist(atom_string, ArchList, StrArchList1).
1316
1317suffix_multiplier(b, 1).
1318suffix_multiplier(k, 1024).
1319suffix_multiplier(m, 1024 * 1024).
1320suffix_multiplier(g, 1024 * 1024 * 1024).
1321
1322
1323                 /*******************************
1324                 *            MESSAGES          *
1325                 *******************************/
1326
1327:- multifile prolog:message/3.
1328
1329prolog:message(no_resource(Name, File)) -->
1330    [ 'Could not find resource ~w on ~w or system resources'-
1331      [Name, File] ].
1332prolog:message(qsave(nondet)) -->
1333    [ 'qsave_program/2 succeeded with a choice point'-[] ].
1334