View source with formatted comments or as raw
    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-2019, 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 Prolog's
  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    zipper_open_new_file_in_zip(RC, '$prolog/state.qlf', StateFd, []),
  513    setup_call_cleanup(
  514        ( current_prolog_flag(access_level, OldLevel),
  515          set_prolog_flag(access_level, system), % generate system modules
  516          '$open_wic'(StateFd, Options)
  517        ),
  518        ( create_mapping(Options),
  519          save_modules(SaveClass),
  520          save_records,
  521          save_flags,
  522          save_prompt,
  523          save_imports,
  524          save_prolog_flags,
  525          save_operators(Options),
  526          save_format_predicates
  527        ),
  528        ( '$close_wic',
  529          set_prolog_flag(access_level, OldLevel)
  530        )),
  531    close(StateFd).
  532
  533
  534                 /*******************************
  535                 *            MODULES           *
  536                 *******************************/
  537
  538save_modules(SaveClass) :-
  539    forall(special_module(X),
  540           save_module(X, SaveClass)),
  541    forall((current_module(X), \+ special_module(X)),
  542           save_module(X, SaveClass)).
  543
  544special_module(system).
  545special_module(user).
  546
  547
  548%!  prepare_entry_points(+Options)
  549%
  550%   Prepare  the  --goal=Goal  and  --toplevel=Goal  options.  Preparing
  551%   implies autoloading the definition and declaring it _public_ such at
  552%   it doesn't get obfuscated.
  553
  554prepare_entry_points(Options) :-
  555    define_init_goal(Options),
  556    define_toplevel_goal(Options).
  557
  558define_init_goal(Options) :-
  559    option(goal(Goal), Options),
  560    !,
  561    entry_point(Goal).
  562define_init_goal(_).
  563
  564define_toplevel_goal(Options) :-
  565    option(toplevel(Goal), Options),
  566    !,
  567    entry_point(Goal).
  568define_toplevel_goal(_).
  569
  570entry_point(Goal) :-
  571    define_predicate(Goal),
  572    (   \+ predicate_property(Goal, built_in),
  573        \+ predicate_property(Goal, imported_from(_))
  574    ->  goal_pi(Goal, PI),
  575        public(PI)
  576    ;   true
  577    ).
  578
  579define_predicate(Head) :-
  580    '$define_predicate'(Head),
  581    !.   % autoloader
  582define_predicate(Head) :-
  583    strip_module(Head, _, Term),
  584    functor(Term, Name, Arity),
  585    throw(error(existence_error(procedure, Name/Arity), _)).
  586
  587goal_pi(M:G, QPI) :-
  588    !,
  589    strip_module(M:G, Module, Goal),
  590    functor(Goal, Name, Arity),
  591    QPI = Module:Name/Arity.
  592goal_pi(Goal, Name/Arity) :-
  593    functor(Goal, Name, Arity).
  594
  595%!  prepare_state(+Options) is det.
  596%
  597%   Prepare the executable by  running   the  `prepare_state` registered
  598%   initialization hooks.
  599
  600prepare_state(_) :-
  601    forall('$init_goal'(when(prepare_state), Goal, Ctx),
  602           run_initialize(Goal, Ctx)).
  603
  604run_initialize(Goal, Ctx) :-
  605    (   catch(Goal, E, true),
  606        (   var(E)
  607        ->  true
  608        ;   throw(error(initialization_error(E, Goal, Ctx), _))
  609        )
  610    ;   throw(error(initialization_error(failed, Goal, Ctx), _))
  611    ).
  612
  613
  614                 /*******************************
  615                 *            AUTOLOAD          *
  616                 *******************************/
  617
  618%!  save_autoload(+Options) is det.
  619%
  620%   Resolve all autoload dependencies.
  621%
  622%   @error existence_error(procedures, List) if undefined(true) is
  623%   in Options and there are undefined predicates.
  624
  625save_autoload(Options) :-
  626    option(autoload(true),  Options, true),
  627    !,
  628    autoload_all(Options).
  629save_autoload(_).
  630
  631
  632                 /*******************************
  633                 *             MODULES          *
  634                 *******************************/
  635
  636%!  save_module(+Module, +SaveClass)
  637%
  638%   Saves a module
  639
  640save_module(M, SaveClass) :-
  641    '$qlf_start_module'(M),
  642    feedback('~n~nMODULE ~w~n', [M]),
  643    save_unknown(M),
  644    (   P = (M:_H),
  645        current_predicate(_, P),
  646        \+ predicate_property(P, imported_from(_)),
  647        save_predicate(P, SaveClass),
  648        fail
  649    ;   '$qlf_end_part',
  650        feedback('~n', [])
  651    ).
  652
  653save_predicate(P, _SaveClass) :-
  654    predicate_property(P, foreign),
  655    !,
  656    P = (M:H),
  657    functor(H, Name, Arity),
  658    feedback('~npre-defining foreign ~w/~d ', [Name, Arity]),
  659    '$add_directive_wic'('$predefine_foreign'(M:Name/Arity)).
  660save_predicate(P, SaveClass) :-
  661    P = (M:H),
  662    functor(H, F, A),
  663    feedback('~nsaving ~w/~d ', [F, A]),
  664    (   (   H = resource(_,_)
  665        ;   H = resource(_,_,_)
  666        ),
  667        SaveClass \== development
  668    ->  save_attribute(P, (dynamic)),
  669        (   M == user
  670        ->  save_attribute(P, (multifile))
  671        ),
  672        feedback('(Skipped clauses)', []),
  673        fail
  674    ;   true
  675    ),
  676    (   no_save(P)
  677    ->  true
  678    ;   save_attributes(P),
  679        \+ predicate_property(P, (volatile)),
  680        (   nth_clause(P, _, Ref),
  681            feedback('.', []),
  682            '$qlf_assert_clause'(Ref, SaveClass),
  683            fail
  684        ;   true
  685        )
  686    ).
  687
  688no_save(P) :-
  689    predicate_property(P, volatile),
  690    \+ predicate_property(P, dynamic),
  691    \+ predicate_property(P, multifile).
  692
  693pred_attrib(meta_predicate(Term), Head, meta_predicate(M:Term)) :-
  694    !,
  695    strip_module(Head, M, _).
  696pred_attrib(Attrib, Head,
  697            '$set_predicate_attribute'(M:Name/Arity, AttName, Val)) :-
  698    attrib_name(Attrib, AttName, Val),
  699    strip_module(Head, M, Term),
  700    functor(Term, Name, Arity).
  701
  702attrib_name(dynamic,                dynamic,                true).
  703attrib_name(volatile,               volatile,               true).
  704attrib_name(thread_local,           thread_local,           true).
  705attrib_name(multifile,              multifile,              true).
  706attrib_name(public,                 public,                 true).
  707attrib_name(transparent,            transparent,            true).
  708attrib_name(discontiguous,          discontiguous,          true).
  709attrib_name(notrace,                trace,                  false).
  710attrib_name(show_childs,            hide_childs,            false).
  711attrib_name(built_in,               system,                 true).
  712attrib_name(nodebug,                hide_childs,            true).
  713attrib_name(quasi_quotation_syntax, quasi_quotation_syntax, true).
  714attrib_name(iso,                    iso,                    true).
  715
  716
  717save_attribute(P, Attribute) :-
  718    pred_attrib(Attribute, P, D),
  719    (   Attribute == built_in       % no need if there are clauses
  720    ->  (   predicate_property(P, number_of_clauses(0))
  721        ->  true
  722        ;   predicate_property(P, volatile)
  723        )
  724    ;   Attribute == (dynamic)      % no need if predicate is thread_local
  725    ->  \+ predicate_property(P, thread_local)
  726    ;   true
  727    ),
  728    '$add_directive_wic'(D),
  729    feedback('(~w) ', [Attribute]).
  730
  731save_attributes(P) :-
  732    (   predicate_property(P, Attribute),
  733        save_attribute(P, Attribute),
  734        fail
  735    ;   true
  736    ).
  737
  738%       Save status of the unknown flag
  739
  740save_unknown(M) :-
  741    current_prolog_flag(M:unknown, Unknown),
  742    (   Unknown == error
  743    ->  true
  744    ;   '$add_directive_wic'(set_prolog_flag(M:unknown, Unknown))
  745    ).
  746
  747                 /*******************************
  748                 *            RECORDS           *
  749                 *******************************/
  750
  751save_records :-
  752    feedback('~nRECORDS~n', []),
  753    (   current_key(X),
  754        X \== '$topvar',                        % do not safe toplevel variables
  755        feedback('~n~t~8|~w ', [X, V]),
  756        recorded(X, V, _),
  757        feedback('.', []),
  758        '$add_directive_wic'(recordz(X, V, _)),
  759        fail
  760    ;   true
  761    ).
  762
  763
  764                 /*******************************
  765                 *            FLAGS             *
  766                 *******************************/
  767
  768save_flags :-
  769    feedback('~nFLAGS~n~n', []),
  770    (   current_flag(X),
  771        flag(X, V, V),
  772        feedback('~t~8|~w = ~w~n', [X, V]),
  773        '$add_directive_wic'(set_flag(X, V)),
  774        fail
  775    ;   true
  776    ).
  777
  778save_prompt :-
  779    feedback('~nPROMPT~n~n', []),
  780    prompt(Prompt, Prompt),
  781    '$add_directive_wic'(prompt(_, Prompt)).
  782
  783
  784                 /*******************************
  785                 *           IMPORTS            *
  786                 *******************************/
  787
  788%!  save_imports
  789%
  790%   Save  import  relations.  An  import  relation  is  saved  if  a
  791%   predicate is imported from a module that is not a default module
  792%   for the destination module. If  the   predicate  is  dynamic, we
  793%   always define the explicit import relation to make clear that an
  794%   assert must assert on the imported predicate.
  795
  796save_imports :-
  797    feedback('~nIMPORTS~n~n', []),
  798    (   predicate_property(M:H, imported_from(I)),
  799        \+ default_import(M, H, I),
  800        functor(H, F, A),
  801        feedback('~t~8|~w:~w/~d <-- ~w~n', [M, F, A, I]),
  802        '$add_directive_wic'(qsave:restore_import(M, I, F/A)),
  803        fail
  804    ;   true
  805    ).
  806
  807default_import(To, Head, From) :-
  808    '$get_predicate_attribute'(To:Head, (dynamic), 1),
  809    predicate_property(From:Head, exported),
  810    !,
  811    fail.
  812default_import(Into, _, From) :-
  813    default_module(Into, From).
  814
  815%!  restore_import(+TargetModule, +SourceModule, +PI) is det.
  816%
  817%   Restore import relation. This notably   deals  with imports from
  818%   the module =user=, avoiding a message  that the predicate is not
  819%   exported.
  820
  821restore_import(To, user, PI) :-
  822    !,
  823    export(user:PI),
  824    To:import(user:PI).
  825restore_import(To, From, PI) :-
  826    To:import(From:PI).
  827
  828                 /*******************************
  829                 *         PROLOG FLAGS         *
  830                 *******************************/
  831
  832save_prolog_flags :-
  833    feedback('~nPROLOG FLAGS~n~n', []),
  834    '$current_prolog_flag'(Flag, Value, _Scope, write, Type),
  835    \+ no_save_flag(Flag),
  836    feedback('~t~8|~w: ~w (type ~q)~n', [Flag, Value, Type]),
  837    '$add_directive_wic'(qsave:restore_prolog_flag(Flag, Value, Type)),
  838    fail.
  839save_prolog_flags.
  840
  841no_save_flag(argv).
  842no_save_flag(os_argv).
  843no_save_flag(access_level).
  844no_save_flag(tty_control).
  845no_save_flag(readline).
  846no_save_flag(associated_file).
  847no_save_flag(cpu_count).
  848no_save_flag(tmp_dir).
  849no_save_flag(hwnd).                     % should be read-only, but comes
  850                                        % from user-code
  851
  852%!  restore_prolog_flag(+Name, +Value, +Type)
  853%
  854%   Deal  with  possibly   protected    flags   (debug_on_error  and
  855%   report_error are protected flags for the runtime kernel).
  856
  857restore_prolog_flag(Flag, Value, _Type) :-
  858    current_prolog_flag(Flag, Value),
  859    !.
  860restore_prolog_flag(Flag, Value, _Type) :-
  861    current_prolog_flag(Flag, _),
  862    !,
  863    catch(set_prolog_flag(Flag, Value), _, true).
  864restore_prolog_flag(Flag, Value, Type) :-
  865    create_prolog_flag(Flag, Value, [type(Type)]).
  866
  867
  868                 /*******************************
  869                 *           OPERATORS          *
  870                 *******************************/
  871
  872%!  save_operators(+Options) is det.
  873%
  874%   Save operators for all modules.   Operators for =system= are
  875%   not saved because these are read-only anyway.
  876
  877save_operators(Options) :-
  878    !,
  879    option(op(save), Options, save),
  880    feedback('~nOPERATORS~n', []),
  881    forall(current_module(M), save_module_operators(M)),
  882    feedback('~n', []).
  883save_operators(_).
  884
  885save_module_operators(system) :- !.
  886save_module_operators(M) :-
  887    forall('$local_op'(P,T,M:N),
  888           (   feedback('~n~t~8|~w ', [op(P,T,M:N)]),
  889               '$add_directive_wic'(op(P,T,M:N))
  890           )).
  891
  892
  893                 /*******************************
  894                 *       FORMAT PREDICATES      *
  895                 *******************************/
  896
  897save_format_predicates :-
  898    feedback('~nFORMAT PREDICATES~n', []),
  899    current_format_predicate(Code, Head),
  900    qualify_head(Head, QHead),
  901    D = format_predicate(Code, QHead),
  902    feedback('~n~t~8|~w ', [D]),
  903    '$add_directive_wic'(D),
  904    fail.
  905save_format_predicates.
  906
  907qualify_head(T, T) :-
  908    functor(T, :, 2),
  909    !.
  910qualify_head(T, user:T).
  911
  912
  913                 /*******************************
  914                 *       FOREIGN LIBRARIES      *
  915                 *******************************/
  916
  917%!  save_foreign_libraries(+Archive, +Options) is det.
  918%
  919%   Save current foreign libraries into the archive.
  920
  921save_foreign_libraries(RC, Options) :-
  922    option(foreign(save), Options),
  923    !,
  924    current_prolog_flag(arch, HostArch),
  925    feedback('~nHOST(~w) FOREIGN LIBRARIES~n', [HostArch]),
  926    save_foreign_libraries1(HostArch, RC, Options).
  927save_foreign_libraries(RC, Options) :-
  928    option(foreign(arch(Archs)), Options),
  929    !,
  930    forall(member(Arch, Archs),
  931           ( feedback('~n~w FOREIGN LIBRARIES~n', [Arch]),
  932             save_foreign_libraries1(Arch, RC, Options)
  933           )).
  934save_foreign_libraries(_, _).
  935
  936save_foreign_libraries1(Arch, RC, _Options) :-
  937    forall(current_foreign_library(FileSpec, _Predicates),
  938           ( find_foreign_library(Arch, FileSpec, EntryName, File, Time),
  939             term_to_atom(EntryName, Name),
  940             zipper_append_file(RC, Name, File, [time(Time)])
  941           )).
  942
  943%!  find_foreign_library(+Architecture, +FileSpec, -EntryName, -File, -Time)
  944%!								is det.
  945%
  946%   Find  the  shared  object  specified  by   FileSpec  for  the  named
  947%   Architecture. EntryName will be the  name   of  the  file within the
  948%   saved state archive. If posible, the   shared  object is stripped to
  949%   reduce its size. This  is  achieved   by  calling  =|strip  -o <tmp>
  950%   <shared-object>|=. Note that (if stripped) the  file is a Prolog tmp
  951%   file and will be deleted on halt.
  952%
  953%   @bug    Should perform OS search on failure
  954
  955find_foreign_library(Arch, FileSpec, shlib(Arch,Name), SharedObject, Time) :-
  956    FileSpec = foreign(Name),
  957    (   catch(arch_find_shlib(Arch, FileSpec, File),
  958              E,
  959              print_message(error, E)),
  960        exists_file(File)
  961    ->  true
  962    ;   throw(error(existence_error(architecture_shlib(Arch), FileSpec),_))
  963    ),
  964    time_file(File, Time),
  965    strip_file(File, SharedObject).
  966
  967%!  strip_file(+File, -Stripped) is det.
  968%
  969%   Try to strip File. Unify Stripped with   File if stripping fails for
  970%   some reason.
  971
  972strip_file(File, Stripped) :-
  973    absolute_file_name(path(strip), Strip,
  974                       [ access(execute),
  975                         file_errors(fail)
  976                       ]),
  977    tmp_file(shared, Stripped),
  978    (   catch(do_strip_file(Strip, File, Stripped), E,
  979              (print_message(warning, E), fail))
  980    ->  true
  981    ;   print_message(warning, qsave(strip_failed(File))),
  982        fail
  983    ),
  984    !.
  985strip_file(File, File).
  986
  987do_strip_file(Strip, File, Stripped) :-
  988    format(atom(Cmd), '"~w" -o "~w" "~w"',
  989           [Strip, Stripped, File]),
  990    shell(Cmd),
  991    exists_file(Stripped).
  992
  993%!  qsave:arch_shlib(+Architecture, +FileSpec, -File) is det.
  994%
  995%   This is a user defined hook called by qsave_program/2. It is used to
  996%   find a shared library  for  the   specified  Architecture,  named by
  997%   FileSpec. FileSpec is of  the   form  foreign(Name), a specification
  998%   usable by absolute_file_name/2. The predicate should unify File with
  999%   the absolute path for the  shared   library  that corresponds to the
 1000%   specified Architecture.
 1001%
 1002%   If  this  predicate  fails  to  find    a  file  for  the  specified
 1003%   architecture an `existence_error` is thrown.
 1004
 1005:- multifile arch_shlib/3. 1006
 1007arch_find_shlib(Arch, FileSpec, File) :-
 1008    arch_shlib(Arch, FileSpec, File),
 1009    !.
 1010arch_find_shlib(Arch, FileSpec, File) :-
 1011    current_prolog_flag(arch, Arch),
 1012    absolute_file_name(FileSpec,
 1013                       [ file_type(executable),
 1014                         access(read),
 1015                         file_errors(fail)
 1016                       ], File),
 1017    !.
 1018arch_find_shlib(Arch, foreign(Base), File) :-
 1019    current_prolog_flag(arch, Arch),
 1020    current_prolog_flag(windows, true),
 1021    current_prolog_flag(executable, WinExe),
 1022    prolog_to_os_filename(Exe, WinExe),
 1023    file_directory_name(Exe, BinDir),
 1024    file_name_extension(Base, dll, DllFile),
 1025    atomic_list_concat([BinDir, /, DllFile], File),
 1026    exists_file(File).
 1027
 1028
 1029                 /*******************************
 1030                 *             UTIL             *
 1031                 *******************************/
 1032
 1033open_map(Options) :-
 1034    option(map(Map), Options),
 1035    !,
 1036    open(Map, write, Fd),
 1037    asserta(verbose(Fd)).
 1038open_map(_) :-
 1039    retractall(verbose(_)).
 1040
 1041close_map :-
 1042    retract(verbose(Fd)),
 1043    close(Fd),
 1044    !.
 1045close_map.
 1046
 1047feedback(Fmt, Args) :-
 1048    verbose(Fd),
 1049    !,
 1050    format(Fd, Fmt, Args).
 1051feedback(_, _).
 1052
 1053
 1054check_options([]) :- !.
 1055check_options([Var|_]) :-
 1056    var(Var),
 1057    !,
 1058    throw(error(domain_error(save_options, Var), _)).
 1059check_options([Name=Value|T]) :-
 1060    !,
 1061    (   save_option(Name, Type, _Comment)
 1062    ->  (   must_be(Type, Value)
 1063        ->  check_options(T)
 1064        ;   throw(error(domain_error(Type, Value), _))
 1065        )
 1066    ;   throw(error(domain_error(save_option, Name), _))
 1067    ).
 1068check_options([Term|T]) :-
 1069    Term =.. [Name,Arg],
 1070    !,
 1071    check_options([Name=Arg|T]).
 1072check_options([Var|_]) :-
 1073    throw(error(domain_error(save_options, Var), _)).
 1074check_options(Opt) :-
 1075    throw(error(domain_error(list, Opt), _)).
 1076
 1077
 1078%!  zipper_append_file(+Zipper, +Name, +File, +Options) is det.
 1079%
 1080%   Append the content of File under Name to the open Zipper.
 1081
 1082zipper_append_file(_, Name, _, _) :-
 1083    saved_resource_file(Name),
 1084    !.
 1085zipper_append_file(_, _, File, _) :-
 1086    source_file(File),
 1087    !.
 1088zipper_append_file(Zipper, Name, File, Options) :-
 1089    (   option(time(_), Options)
 1090    ->  Options1 = Options
 1091    ;   time_file(File, Stamp),
 1092        Options1 = [time(Stamp)|Options]
 1093    ),
 1094    setup_call_cleanup(
 1095        open(File, read, In, [type(binary)]),
 1096        setup_call_cleanup(
 1097            zipper_open_new_file_in_zip(Zipper, Name, Out, Options1),
 1098            copy_stream_data(In, Out),
 1099            close(Out)),
 1100        close(In)),
 1101    assertz(saved_resource_file(Name)).
 1102
 1103%!  zipper_add_directory(+Zipper, +Name, +Dir, +Options) is det.
 1104%
 1105%   Add a directory entry. Dir  is  only   used  if  there  is no option
 1106%   time(Stamp).
 1107
 1108zipper_add_directory(Zipper, Name, Dir, Options) :-
 1109    (   option(time(Stamp), Options)
 1110    ->  true
 1111    ;   time_file(Dir, Stamp)
 1112    ),
 1113    atom_concat(Name, /, DirName),
 1114    (   saved_resource_file(DirName)
 1115    ->  true
 1116    ;   setup_call_cleanup(
 1117            zipper_open_new_file_in_zip(Zipper, DirName, Out,
 1118                                        [ method(store),
 1119                                          time(Stamp)
 1120                                        | Options
 1121                                        ]),
 1122            true,
 1123            close(Out)),
 1124        assertz(saved_resource_file(DirName))
 1125    ).
 1126
 1127add_parent_dirs(Zipper, Name, Dir, Options) :-
 1128    (   option(time(Stamp), Options)
 1129    ->  true
 1130    ;   time_file(Dir, Stamp)
 1131    ),
 1132    file_directory_name(Name, Parent),
 1133    (   Parent \== Name
 1134    ->  add_parent_dirs(Zipper, Parent, [time(Stamp)|Options])
 1135    ;   true
 1136    ).
 1137
 1138add_parent_dirs(_, '.', _) :-
 1139    !.
 1140add_parent_dirs(Zipper, Name, Options) :-
 1141    zipper_add_directory(Zipper, Name, _, Options),
 1142    file_directory_name(Name, Parent),
 1143    (   Parent \== Name
 1144    ->  add_parent_dirs(Zipper, Parent, Options)
 1145    ;   true
 1146    ).
 1147
 1148
 1149%!  zipper_append_directory(+Zipper, +Name, +Dir, +Options) is det.
 1150%
 1151%   Append the content of  Dir  below   Name  in  the  resource archive.
 1152%   Options:
 1153%
 1154%     - include(+Patterns)
 1155%     Only add entries that match an element from Patterns using
 1156%     wildcard_match/2.
 1157%     - exclude(+Patterns)
 1158%     Ignore entries that match an element from Patterns using
 1159%     wildcard_match/2.
 1160%
 1161%   @tbd Process .gitignore.  There also seem to exists other
 1162%   standards for this.
 1163
 1164zipper_append_directory(Zipper, Name, Dir, Options) :-
 1165    exists_directory(Dir),
 1166    !,
 1167    add_parent_dirs(Zipper, Name, Dir, Options),
 1168    zipper_add_directory(Zipper, Name, Dir, Options),
 1169    directory_files(Dir, Members),
 1170    forall(member(M, Members),
 1171           (   reserved(M)
 1172           ->  true
 1173           ;   ignored(M, Options)
 1174           ->  true
 1175           ;   atomic_list_concat([Dir,M], /, Entry),
 1176               atomic_list_concat([Name,M], /, Store),
 1177               catch(zipper_append_directory(Zipper, Store, Entry, Options),
 1178                     E,
 1179                     print_message(warning, E))
 1180           )).
 1181zipper_append_directory(Zipper, Name, File, Options) :-
 1182    zipper_append_file(Zipper, Name, File, Options).
 1183
 1184reserved(.).
 1185reserved(..).
 1186
 1187%!  ignored(+File, +Options) is semidet.
 1188%
 1189%   Ignore File if there is an  include(Patterns) option that does *not*
 1190%   match File or an exclude(Patterns) that does match File.
 1191
 1192ignored(File, Options) :-
 1193    option(include(Patterns), Options),
 1194    \+ ( (   is_list(Patterns)
 1195         ->  member(Pattern, Patterns)
 1196         ;   Pattern = Patterns
 1197         ),
 1198         wildcard_match(Pattern, File)
 1199       ),
 1200    !.
 1201ignored(File, Options) :-
 1202    option(exclude(Patterns), Options),
 1203    (   is_list(Patterns)
 1204    ->  member(Pattern, Patterns)
 1205    ;   Pattern = Patterns
 1206    ),
 1207    wildcard_match(Pattern, File),
 1208    !.
 1209
 1210
 1211                /********************************
 1212                *     SAVED STATE GENERATION    *
 1213                *********************************/
 1214
 1215%!  qsave_toplevel
 1216%
 1217%   Called to handle `-c file` compilaton.
 1218
 1219:- public
 1220    qsave_toplevel/0. 1221
 1222qsave_toplevel :-
 1223    current_prolog_flag(os_argv, Argv),
 1224    qsave_options(Argv, Files, Options),
 1225    '$cmd_option_val'(compileout, Out),
 1226    user:consult(Files),
 1227    qsave_program(Out, user:Options).
 1228
 1229qsave_options([], [], []).
 1230qsave_options([--|_], [], []) :-
 1231    !.
 1232qsave_options(['-c'|T0], Files, Options) :-
 1233    !,
 1234    argv_files(T0, T1, Files, FilesT),
 1235    qsave_options(T1, FilesT, Options).
 1236qsave_options([O|T0], Files, [Option|T]) :-
 1237    string_concat(--, Opt, O),
 1238    split_string(Opt, =, '', [NameS|Rest]),
 1239    atom_string(Name, NameS),
 1240    qsave_option(Name, OptName, Rest, Value),
 1241    !,
 1242    Option =.. [OptName, Value],
 1243    qsave_options(T0, Files, T).
 1244qsave_options([_|T0], Files, T) :-
 1245    qsave_options(T0, Files, T).
 1246
 1247argv_files([], [], Files, Files).
 1248argv_files([H|T], [H|T], Files, Files) :-
 1249    sub_atom(H, 0, _, _, -),
 1250    !.
 1251argv_files([H|T0], T, [H|Files0], Files) :-
 1252    argv_files(T0, T, Files0, Files).
 1253
 1254%!  qsave_option(+Name, +ValueStrings, -Value) is semidet.
 1255
 1256qsave_option(Name, Name, [], true) :-
 1257    save_option(Name, boolean, _),
 1258    !.
 1259qsave_option(NoName, Name, [], false) :-
 1260    atom_concat('no-', Name, NoName),
 1261    save_option(Name, boolean, _),
 1262    !.
 1263qsave_option(Name, Name, ValueStrings, Value) :-
 1264    save_option(Name, Type, _),
 1265    !,
 1266    atomics_to_string(ValueStrings, "=", ValueString),
 1267    convert_option_value(Type, ValueString, Value).
 1268qsave_option(Name, Name, _Chars, _Value) :-
 1269    existence_error(save_option, Name).
 1270
 1271convert_option_value(integer, String, Value) :-
 1272    (   number_string(Value, String)
 1273    ->  true
 1274    ;   sub_string(String, 0, _, 1, SubString),
 1275        sub_string(String, _, 1, 0, Suffix0),
 1276        downcase_atom(Suffix0, Suffix),
 1277        number_string(Number, SubString),
 1278        suffix_multiplier(Suffix, Multiplier)
 1279    ->  Value is Number * Multiplier
 1280    ;   domain_error(integer, String)
 1281    ).
 1282convert_option_value(callable, String, Value) :-
 1283    term_string(Value, String).
 1284convert_option_value(atom, String, Value) :-
 1285    atom_string(Value, String).
 1286convert_option_value(boolean, String, Value) :-
 1287    atom_string(Value, String).
 1288convert_option_value(oneof(_), String, Value) :-
 1289    atom_string(Value, String).
 1290convert_option_value(ground, String, Value) :-
 1291    atom_string(Value, String).
 1292convert_option_value(qsave_foreign_option, "save", save).
 1293convert_option_value(qsave_foreign_option, StrArchList, arch(ArchList)) :-
 1294    split_string(StrArchList, ",", ", \t", StrArchList1),
 1295    maplist(atom_string, ArchList, StrArchList1).
 1296
 1297suffix_multiplier(b, 1).
 1298suffix_multiplier(k, 1024).
 1299suffix_multiplier(m, 1024 * 1024).
 1300suffix_multiplier(g, 1024 * 1024 * 1024).
 1301
 1302
 1303                 /*******************************
 1304                 *            MESSAGES          *
 1305                 *******************************/
 1306
 1307:- multifile prolog:message/3. 1308
 1309prolog:message(no_resource(Name, File)) -->
 1310    [ 'Could not find resource ~w on ~w or system resources'-
 1311      [Name, File] ].
 1312prolog:message(qsave(nondet)) -->
 1313    [ 'qsave_program/2 succeeded with a choice point'-[] ]