View source with raw 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-2021, University of Amsterdam
    7                              VU University Amsterdam
    8                              CWI, Amsterdam
    9                              SWI-Prolog Solutions b.v.
   10    All rights reserved.
   11
   12    Redistribution and use in source and binary forms, with or without
   13    modification, are permitted provided that the following conditions
   14    are met:
   15
   16    1. Redistributions of source code must retain the above copyright
   17       notice, this list of conditions and the following disclaimer.
   18
   19    2. Redistributions in binary form must reproduce the above copyright
   20       notice, this list of conditions and the following disclaimer in
   21       the documentation and/or other materials provided with the
   22       distribution.
   23
   24    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   25    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   26    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
   27    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
   28    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
   29    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
   30    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
   31    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
   32    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
   33    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
   34    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
   35    POSSIBILITY OF SUCH DAMAGE.
   36*/
   37
   38:- module(qsave,
   39          [ qsave_program/1,                    % +File
   40            qsave_program/2                     % +File, +Options
   41          ]).   42:- use_module(library(zip)).   43:- use_module(library(lists)).   44:- use_module(library(option)).   45:- use_module(library(error)).   46:- use_module(library(apply)).   47:- autoload(library(shlib), [current_foreign_library/2]).   48:- autoload(library(prolog_autoload), [autoload_all/1]).

Save current program as a state or executable

This library provides qsave_program/1 and qsave_program/2, which are also used by the commandline sequence below.

swipl -o exe -c file.pl ...

*/

   60:- meta_predicate
   61    qsave_program(+, :).   62
   63:- multifile error:has_type/2.   64error:has_type(qsave_foreign_option, Term) :-
   65    is_of_type(oneof([save, no_save]), Term),
   66    !.
   67error:has_type(qsave_foreign_option, arch(Archs)) :-
   68    is_of_type(list(atom), Archs),
   69    !.
   70
   71save_option(stack_limit, integer,
   72            "Stack limit (bytes)").
   73save_option(goal,        callable,
   74            "Main initialization goal").
   75save_option(toplevel,    callable,
   76            "Toplevel goal").
   77save_option(init_file,   atom,
   78            "Application init file").
   79save_option(pce,         boolean,
   80            "Do (not) include the xpce graphics subsystem").
   81save_option(packs,       boolean,
   82            "Do (not) attach packs").
   83save_option(class,       oneof([runtime,development,prolog]),
   84            "Development state").
   85save_option(op,          oneof([save,standard]),
   86            "Save operators").
   87save_option(autoload,    boolean,
   88            "Resolve autoloadable predicates").
   89save_option(map,         atom,
   90            "File to report content of the state").
   91save_option(stand_alone, boolean,
   92            "Add emulator at start").
   93save_option(traditional, boolean,
   94            "Use traditional mode").
   95save_option(emulator,    ground,
   96            "Emulator to use").
   97save_option(foreign,     qsave_foreign_option,
   98            "Include foreign code in state").
   99save_option(obfuscate,   boolean,
  100            "Obfuscate identifiers").
  101save_option(verbose,     boolean,
  102            "Be more verbose about the state creation").
  103save_option(undefined,   oneof([ignore,error]),
  104            "How to handle undefined predicates").
  105save_option(on_error,    oneof([print,halt,status]),
  106            "How to handle errors").
  107save_option(on_warning,  oneof([print,halt,status]),
  108            "How to handle warnings").
  109
  110term_expansion(save_pred_options,
  111               (:- predicate_options(qsave_program/2, 2, Options))) :-
  112    findall(O,
  113            ( save_option(Name, Type, _),
  114              O =.. [Name,Type]
  115            ),
  116            Options).
  117
  118save_pred_options.
  119
  120:- set_prolog_flag(generate_debug_info, false).  121
  122:- dynamic
  123    verbose/1,
  124    saved_resource_file/1.  125:- volatile
  126    verbose/1,                  % contains a stream-handle
  127    saved_resource_file/1.
 qsave_program(+File) is det
 qsave_program(+File, :Options) is det
Make a saved state in file `File'.
  134qsave_program(File) :-
  135    qsave_program(File, []).
  136
  137qsave_program(FileBase, Options0) :-
  138    meta_options(is_meta, Options0, Options1),
  139    check_options(Options1),
  140    exe_file(FileBase, File, Options1),
  141    option(class(SaveClass), Options1, runtime),
  142    qsave_init_file_option(SaveClass, Options1, Options),
  143    prepare_entry_points(Options),
  144    save_autoload(Options),
  145    setup_call_cleanup(
  146        open_map(Options),
  147        ( prepare_state(Options),
  148          create_prolog_flag(saved_program, true, []),
  149          create_prolog_flag(saved_program_class, SaveClass, []),
  150          delete_if_exists(File),    % truncate will crash a Prolog
  151                                     % running on this state
  152          setup_call_catcher_cleanup(
  153              open(File, write, StateOut, [type(binary)]),
  154              write_state(StateOut, SaveClass, Options),
  155              Reason,
  156              finalize_state(Reason, StateOut, File))
  157        ),
  158        close_map),
  159    cleanup,
  160    !.
  161
  162write_state(StateOut, SaveClass, Options) :-
  163    make_header(StateOut, SaveClass, Options),
  164    setup_call_cleanup(
  165        zip_open_stream(StateOut, RC, []),
  166        write_zip_state(RC, SaveClass, Options),
  167        zip_close(RC, [comment('SWI-Prolog saved state')])),
  168    flush_output(StateOut).
  169
  170write_zip_state(RC, SaveClass, Options) :-
  171    save_options(RC, SaveClass, Options),
  172    save_resources(RC, SaveClass),
  173    lock_files(SaveClass),
  174    save_program(RC, SaveClass, Options),
  175    save_foreign_libraries(RC, Options).
  176
  177finalize_state(exit, StateOut, File) :-
  178    close(StateOut),
  179    '$mark_executable'(File).
  180finalize_state(!, StateOut, File) :-
  181    print_message(warning, qsave(nondet)),
  182    finalize_state(exit, StateOut, File).
  183finalize_state(_, StateOut, File) :-
  184    close(StateOut, [force(true)]),
  185    catch(delete_file(File),
  186          Error,
  187          print_message(error, Error)).
  188
  189cleanup :-
  190    retractall(saved_resource_file(_)).
  191
  192is_meta(goal).
  193is_meta(toplevel).
  194
  195exe_file(Base, Exe, Options) :-
  196    current_prolog_flag(windows, true),
  197    option(stand_alone(true), Options, true),
  198    file_name_extension(_, '', Base),
  199    !,
  200    file_name_extension(Base, exe, Exe).
  201exe_file(Exe, Exe, _).
  202
  203delete_if_exists(File) :-
  204    (   exists_file(File)
  205    ->  delete_file(File)
  206    ;   true
  207    ).
  208
  209qsave_init_file_option(runtime, Options1, Options) :-
  210    \+ option(init_file(_), Options1),
  211    !,
  212    Options = [init_file(none)|Options1].
  213qsave_init_file_option(_, Options, Options).
  214
  215
  216                 /*******************************
  217                 *           HEADER             *
  218                 *******************************/
 make_header(+Out:stream, +SaveClass, +Options) is det
  222make_header(Out, _, Options) :-
  223    option(emulator(OptVal), Options),
  224    !,
  225    absolute_file_name(OptVal, [access(read)], Emulator),
  226    setup_call_cleanup(
  227        open(Emulator, read, In, [type(binary)]),
  228        copy_stream_data(In, Out),
  229        close(In)).
  230make_header(Out, _, Options) :-
  231    (   current_prolog_flag(windows, true)
  232    ->  DefStandAlone = true
  233    ;   DefStandAlone = false
  234    ),
  235    option(stand_alone(true), Options, DefStandAlone),
  236    !,
  237    current_prolog_flag(executable, Executable),
  238    setup_call_cleanup(
  239        open(Executable, read, In, [type(binary)]),
  240        copy_stream_data(In, Out),
  241        close(In)).
  242make_header(Out, SaveClass, _Options) :-
  243    current_prolog_flag(unix, true),
  244    !,
  245    current_prolog_flag(executable, Executable),
  246    current_prolog_flag(posix_shell, Shell),
  247    format(Out, '#!~w~n', [Shell]),
  248    format(Out, '# SWI-Prolog saved state~n', []),
  249    (   SaveClass == runtime
  250    ->  ArgSep = ' -- '
  251    ;   ArgSep = ' '
  252    ),
  253    format(Out, 'exec ${SWIPL-~w} -x "$0"~w"$@"~n~n', [Executable, ArgSep]).
  254make_header(_, _, _).
  255
  256
  257                 /*******************************
  258                 *           OPTIONS            *
  259                 *******************************/
  260
  261min_stack(stack_limit, 100_000).
  262
  263convert_option(Stack, Val, NewVal, '~w') :-     % stack-sizes are in K-bytes
  264    min_stack(Stack, Min),
  265    !,
  266    (   Val == 0
  267    ->  NewVal = Val
  268    ;   NewVal is max(Min, Val)
  269    ).
  270convert_option(toplevel, Callable, Callable, '~q') :- !.
  271convert_option(_, Value, Value, '~w').
  272
  273doption(Name) :- min_stack(Name, _).
  274doption(init_file).
  275doption(system_init_file).
  276doption(class).
  277doption(home).
  278doption(nosignals).
 save_options(+ArchiveHandle, +SaveClass, +Options)
Save the options in the '$options' resource. The home directory is saved for development states to make it keep refering to the development home.

The script files (-s script) are not saved at all. I think this is fine to avoid a save-script loading itself.

  289save_options(RC, SaveClass, Options) :-
  290    zipper_open_new_file_in_zip(RC, '$prolog/options.txt', Fd, []),
  291    (   doption(OptionName),
  292            (   OptTerm =.. [OptionName,OptionVal2],
  293                option(OptTerm, Options)
  294            ->  convert_option(OptionName, OptionVal2, OptionVal, FmtVal)
  295            ;   '$cmd_option_val'(OptionName, OptionVal0),
  296                save_option_value(SaveClass, OptionName, OptionVal0, OptionVal1),
  297                OptionVal = OptionVal1,
  298                FmtVal = '~w'
  299            ),
  300            atomics_to_string(['~w=', FmtVal, '~n'], Fmt),
  301            format(Fd, Fmt, [OptionName, OptionVal]),
  302        fail
  303    ;   true
  304    ),
  305    save_init_goals(Fd, Options),
  306    close(Fd).
 save_option_value(+SaveClass, +OptionName, +OptionValue, -FinalValue)
  310save_option_value(Class,   class, _,     Class) :- !.
  311save_option_value(runtime, home,  _,     _) :- !, fail.
  312save_option_value(_,       _,     Value, Value).
 save_init_goals(+Stream, +Options)
Save initialization goals. If there is a goal(Goal) option, use that, else save the goals from '$cmd_option_val'/2.
  319save_init_goals(Out, Options) :-
  320    option(goal(Goal), Options),
  321    !,
  322    format(Out, 'goal=~q~n', [Goal]),
  323    save_toplevel_goal(Out, halt, Options).
  324save_init_goals(Out, Options) :-
  325    '$cmd_option_val'(goals, Goals),
  326    forall(member(Goal, Goals),
  327           format(Out, 'goal=~w~n', [Goal])),
  328    (   Goals == []
  329    ->  DefToplevel = default
  330    ;   DefToplevel = halt
  331    ),
  332    save_toplevel_goal(Out, DefToplevel, Options).
  333
  334save_toplevel_goal(Out, _Default, Options) :-
  335    option(toplevel(Goal), Options),
  336    !,
  337    unqualify_reserved_goal(Goal, Goal1),
  338    format(Out, 'toplevel=~q~n', [Goal1]).
  339save_toplevel_goal(Out, _Default, _Options) :-
  340    '$cmd_option_val'(toplevel, Toplevel),
  341    Toplevel \== default,
  342    !,
  343    format(Out, 'toplevel=~w~n', [Toplevel]).
  344save_toplevel_goal(Out, Default, _Options) :-
  345    format(Out, 'toplevel=~q~n', [Default]).
  346
  347unqualify_reserved_goal(_:prolog, prolog) :- !.
  348unqualify_reserved_goal(_:default, default) :- !.
  349unqualify_reserved_goal(Goal, Goal).
  350
  351
  352                 /*******************************
  353                 *           RESOURCES          *
  354                 *******************************/
  355
  356save_resources(_RC, development) :- !.
  357save_resources(RC, _SaveClass) :-
  358    feedback('~nRESOURCES~n~n', []),
  359    copy_resources(RC),
  360    forall(declared_resource(Name, FileSpec, Options),
  361           save_resource(RC, Name, FileSpec, Options)).
  362
  363declared_resource(RcName, FileSpec, []) :-
  364    current_predicate(_, M:resource(_,_)),
  365    M:resource(Name, FileSpec),
  366    mkrcname(M, Name, RcName).
  367declared_resource(RcName, FileSpec, Options) :-
  368    current_predicate(_, M:resource(_,_,_)),
  369    M:resource(Name, A2, A3),
  370    (   is_list(A3)
  371    ->  FileSpec = A2,
  372        Options = A3
  373    ;   FileSpec = A3
  374    ),
  375    mkrcname(M, Name, RcName).
 mkrcname(+Module, +NameSpec, -Name)
Turn a resource name term into a resource name atom.
  381mkrcname(user, Name0, Name) :-
  382    !,
  383    path_segments_to_atom(Name0, Name).
  384mkrcname(M, Name0, RcName) :-
  385    path_segments_to_atom(Name0, Name),
  386    atomic_list_concat([M, :, Name], RcName).
  387
  388path_segments_to_atom(Name0, Name) :-
  389    phrase(segments_to_atom(Name0), Atoms),
  390    atomic_list_concat(Atoms, /, Name).
  391
  392segments_to_atom(Var) -->
  393    { var(Var), !,
  394      instantiation_error(Var)
  395    }.
  396segments_to_atom(A/B) -->
  397    !,
  398    segments_to_atom(A),
  399    segments_to_atom(B).
  400segments_to_atom(A) -->
  401    [A].
 save_resource(+Zipper, +Name, +FileSpec, +Options) is det
Add the content represented by FileSpec to Zipper under Name.
  407save_resource(RC, Name, FileSpec, _Options) :-
  408    absolute_file_name(FileSpec,
  409                       [ access(read),
  410                         file_errors(fail)
  411                       ], File),
  412    !,
  413    feedback('~t~8|~w~t~32|~w~n',
  414             [Name, File]),
  415    zipper_append_file(RC, Name, File, []).
  416save_resource(RC, Name, FileSpec, Options) :-
  417    findall(Dir,
  418            absolute_file_name(FileSpec, Dir,
  419                               [ access(read),
  420                                 file_type(directory),
  421                                 file_errors(fail),
  422                                 solutions(all)
  423                               ]),
  424            Dirs),
  425    Dirs \== [],
  426    !,
  427    forall(member(Dir, Dirs),
  428           ( feedback('~t~8|~w~t~32|~w~n',
  429                      [Name, Dir]),
  430             zipper_append_directory(RC, Name, Dir, Options))).
  431save_resource(RC, Name, _, _Options) :-
  432    '$rc_handle'(SystemRC),
  433    copy_resource(SystemRC, RC, Name),
  434    !.
  435save_resource(_, Name, FileSpec, _Options) :-
  436    print_message(warning,
  437                  error(existence_error(resource,
  438                                        resource(Name, FileSpec)),
  439                        _)).
  440
  441copy_resources(ToRC) :-
  442    '$rc_handle'(FromRC),
  443    zipper_members(FromRC, List),
  444    (   member(Name, List),
  445        \+ declared_resource(Name, _, _),
  446        \+ reserved_resource(Name),
  447        copy_resource(FromRC, ToRC, Name),
  448        fail
  449    ;   true
  450    ).
  451
  452reserved_resource('$prolog/state.qlf').
  453reserved_resource('$prolog/options.txt').
  454
  455copy_resource(FromRC, ToRC, Name) :-
  456    (   zipper_goto(FromRC, file(Name))
  457    ->  true
  458    ;   existence_error(resource, Name)
  459    ),
  460    zipper_file_info(FromRC, _Name, Attrs),
  461    get_dict(time, Attrs, Time),
  462    setup_call_cleanup(
  463        zipper_open_current(FromRC, FdIn,
  464                            [ type(binary),
  465                              time(Time)
  466                            ]),
  467        setup_call_cleanup(
  468            zipper_open_new_file_in_zip(ToRC, Name, FdOut, []),
  469            ( feedback('~t~8|~w~t~24|~w~n',
  470                       [Name, '<Copied from running state>']),
  471              copy_stream_data(FdIn, FdOut)
  472            ),
  473            close(FdOut)),
  474        close(FdIn)).
  475
  476
  477		 /*******************************
  478		 *           OBFUSCATE		*
  479		 *******************************/
 create_mapping(+Options) is det
Call hook to obfuscate symbols.
  485:- multifile prolog:obfuscate_identifiers/1.  486
  487create_mapping(Options) :-
  488    option(obfuscate(true), Options),
  489    !,
  490    (   predicate_property(prolog:obfuscate_identifiers(_), number_of_clauses(N)),
  491        N > 0
  492    ->  true
  493    ;   use_module(library(obfuscate))
  494    ),
  495    (   catch(prolog:obfuscate_identifiers(Options), E,
  496              print_message(error, E))
  497    ->  true
  498    ;   print_message(warning, failed(obfuscate_identifiers))
  499    ).
  500create_mapping(_).
 lock_files(+SaveClass) is det
When saving as runtime, lock all files such that when running the program the system stops checking existence and modification time on the filesystem.
To be done
- system is a poor name. Maybe use resource?
  510lock_files(runtime) :-
  511    !,
  512    '$set_source_files'(system).                % implies from_state
  513lock_files(_) :-
  514    '$set_source_files'(from_state).
 save_program(+Zipper, +SaveClass, +Options) is det
Save the program itself as virtual machine code to Zipper.
  520save_program(RC, SaveClass, Options) :-
  521    setup_call_cleanup(
  522        ( zipper_open_new_file_in_zip(RC, '$prolog/state.qlf', StateFd,
  523                                      [ zip64(true)
  524                                      ]),
  525          current_prolog_flag(access_level, OldLevel),
  526          set_prolog_flag(access_level, system), % generate system modules
  527          '$open_wic'(StateFd, Options)
  528        ),
  529        ( create_mapping(Options),
  530          save_modules(SaveClass),
  531          save_records,
  532          save_flags,
  533          save_prompt,
  534          save_imports,
  535          save_prolog_flags(Options),
  536          save_operators(Options),
  537          save_format_predicates
  538        ),
  539        ( '$close_wic',
  540          set_prolog_flag(access_level, OldLevel),
  541          close(StateFd)
  542        )).
  543
  544
  545                 /*******************************
  546                 *            MODULES           *
  547                 *******************************/
  548
  549save_modules(SaveClass) :-
  550    forall(special_module(X),
  551           save_module(X, SaveClass)),
  552    forall((current_module(X), \+ special_module(X)),
  553           save_module(X, SaveClass)).
  554
  555special_module(system).
  556special_module(user).
 prepare_entry_points(+Options)
Prepare the --goal=Goal and --toplevel=Goal options. Preparing implies autoloading the definition and declaring it public such at it doesn't get obfuscated.
  565prepare_entry_points(Options) :-
  566    define_init_goal(Options),
  567    define_toplevel_goal(Options).
  568
  569define_init_goal(Options) :-
  570    option(goal(Goal), Options),
  571    !,
  572    entry_point(Goal).
  573define_init_goal(_).
  574
  575define_toplevel_goal(Options) :-
  576    option(toplevel(Goal), Options),
  577    !,
  578    entry_point(Goal).
  579define_toplevel_goal(_).
  580
  581entry_point(Goal) :-
  582    define_predicate(Goal),
  583    (   \+ predicate_property(Goal, built_in),
  584        \+ predicate_property(Goal, imported_from(_))
  585    ->  goal_pi(Goal, PI),
  586        public(PI)
  587    ;   true
  588    ).
  589
  590define_predicate(Head) :-
  591    '$define_predicate'(Head),
  592    !.   % autoloader
  593define_predicate(Head) :-
  594    strip_module(Head, _, Term),
  595    functor(Term, Name, Arity),
  596    throw(error(existence_error(procedure, Name/Arity), _)).
  597
  598goal_pi(M:G, QPI) :-
  599    !,
  600    strip_module(M:G, Module, Goal),
  601    functor(Goal, Name, Arity),
  602    QPI = Module:Name/Arity.
  603goal_pi(Goal, Name/Arity) :-
  604    functor(Goal, Name, Arity).
 prepare_state(+Options) is det
Prepare the executable by running the prepare_state registered initialization hooks.
  611prepare_state(_) :-
  612    forall('$init_goal'(when(prepare_state), Goal, Ctx),
  613           run_initialize(Goal, Ctx)).
  614
  615run_initialize(Goal, Ctx) :-
  616    (   catch(Goal, E, true),
  617        (   var(E)
  618        ->  true
  619        ;   throw(error(initialization_error(E, Goal, Ctx), _))
  620        )
  621    ;   throw(error(initialization_error(failed, Goal, Ctx), _))
  622    ).
  623
  624
  625                 /*******************************
  626                 *            AUTOLOAD          *
  627                 *******************************/
 save_autoload(+Options) is det
Resolve all autoload dependencies.
Errors
- existence_error(procedures, List) if undefined(true) is in Options and there are undefined predicates.
  636save_autoload(Options) :-
  637    option(autoload(true),  Options, true),
  638    !,
  639    setup_call_cleanup(
  640        current_prolog_flag(autoload, Old),
  641        autoload_all(Options),
  642        set_prolog_flag(autoload, Old)).
  643save_autoload(_).
  644
  645
  646                 /*******************************
  647                 *             MODULES          *
  648                 *******************************/
 save_module(+Module, +SaveClass)
Saves a module
  654save_module(M, SaveClass) :-
  655    '$qlf_start_module'(M),
  656    feedback('~n~nMODULE ~w~n', [M]),
  657    save_unknown(M),
  658    (   P = (M:_H),
  659        current_predicate(_, P),
  660        \+ predicate_property(P, imported_from(_)),
  661        save_predicate(P, SaveClass),
  662        fail
  663    ;   '$qlf_end_part',
  664        feedback('~n', [])
  665    ).
  666
  667save_predicate(P, _SaveClass) :-
  668    predicate_property(P, foreign),
  669    !,
  670    P = (M:H),
  671    functor(H, Name, Arity),
  672    feedback('~npre-defining foreign ~w/~d ', [Name, Arity]),
  673    '$add_directive_wic'('$predefine_foreign'(M:Name/Arity)).
  674save_predicate(P, SaveClass) :-
  675    P = (M:H),
  676    functor(H, F, A),
  677    feedback('~nsaving ~w/~d ', [F, A]),
  678    (   (   H = resource(_,_)
  679        ;   H = resource(_,_,_)
  680        )
  681    ->  (   SaveClass == development
  682        ->  true
  683        ;   save_attribute(P, (dynamic)),
  684            (   M == user
  685            ->  save_attribute(P, (multifile))
  686            ),
  687            feedback('(Skipped clauses)', []),
  688            fail
  689        )
  690    ;   true
  691    ),
  692    (   no_save(P)
  693    ->  true
  694    ;   save_attributes(P),
  695        \+ predicate_property(P, (volatile)),
  696        (   nth_clause(P, _, Ref),
  697            feedback('.', []),
  698            '$qlf_assert_clause'(Ref, SaveClass),
  699            fail
  700        ;   true
  701        )
  702    ).
  703
  704no_save(P) :-
  705    predicate_property(P, volatile),
  706    \+ predicate_property(P, dynamic),
  707    \+ predicate_property(P, multifile).
  708
  709pred_attrib(meta_predicate(Term), Head, meta_predicate(M:Term)) :-
  710    !,
  711    strip_module(Head, M, _).
  712pred_attrib(Attrib, Head,
  713            '$set_predicate_attribute'(M:Name/Arity, AttName, Val)) :-
  714    attrib_name(Attrib, AttName, Val),
  715    strip_module(Head, M, Term),
  716    functor(Term, Name, Arity).
  717
  718attrib_name(dynamic,                dynamic,                true).
  719attrib_name(volatile,               volatile,               true).
  720attrib_name(thread_local,           thread_local,           true).
  721attrib_name(multifile,              multifile,              true).
  722attrib_name(public,                 public,                 true).
  723attrib_name(transparent,            transparent,            true).
  724attrib_name(discontiguous,          discontiguous,          true).
  725attrib_name(notrace,                trace,                  false).
  726attrib_name(show_childs,            hide_childs,            false).
  727attrib_name(built_in,               system,                 true).
  728attrib_name(nodebug,                hide_childs,            true).
  729attrib_name(quasi_quotation_syntax, quasi_quotation_syntax, true).
  730attrib_name(iso,                    iso,                    true).
  731
  732
  733save_attribute(P, Attribute) :-
  734    pred_attrib(Attribute, P, D),
  735    (   Attribute == built_in       % no need if there are clauses
  736    ->  (   predicate_property(P, number_of_clauses(0))
  737        ->  true
  738        ;   predicate_property(P, volatile)
  739        )
  740    ;   Attribute == (dynamic)      % no need if predicate is thread_local
  741    ->  \+ predicate_property(P, thread_local)
  742    ;   true
  743    ),
  744    '$add_directive_wic'(D),
  745    feedback('(~w) ', [Attribute]).
  746
  747save_attributes(P) :-
  748    (   predicate_property(P, Attribute),
  749        save_attribute(P, Attribute),
  750        fail
  751    ;   true
  752    ).
  753
  754%       Save status of the unknown flag
  755
  756save_unknown(M) :-
  757    current_prolog_flag(M:unknown, Unknown),
  758    (   Unknown == error
  759    ->  true
  760    ;   '$add_directive_wic'(set_prolog_flag(M:unknown, Unknown))
  761    ).
  762
  763                 /*******************************
  764                 *            RECORDS           *
  765                 *******************************/
  766
  767save_records :-
  768    feedback('~nRECORDS~n', []),
  769    (   current_key(X),
  770        X \== '$topvar',                        % do not safe toplevel variables
  771        feedback('~n~t~8|~w ', [X]),
  772        recorded(X, V, _),
  773        feedback('.', []),
  774        '$add_directive_wic'(recordz(X, V, _)),
  775        fail
  776    ;   true
  777    ).
  778
  779
  780                 /*******************************
  781                 *            FLAGS             *
  782                 *******************************/
  783
  784save_flags :-
  785    feedback('~nFLAGS~n~n', []),
  786    (   current_flag(X),
  787        flag(X, V, V),
  788        feedback('~t~8|~w = ~w~n', [X, V]),
  789        '$add_directive_wic'(set_flag(X, V)),
  790        fail
  791    ;   true
  792    ).
  793
  794save_prompt :-
  795    feedback('~nPROMPT~n~n', []),
  796    prompt(Prompt, Prompt),
  797    '$add_directive_wic'(prompt(_, Prompt)).
  798
  799
  800                 /*******************************
  801                 *           IMPORTS            *
  802                 *******************************/
 save_imports
Save import relations. An import relation is saved if a predicate is imported from a module that is not a default module for the destination module. If the predicate is dynamic, we always define the explicit import relation to make clear that an assert must assert on the imported predicate.
  812save_imports :-
  813    feedback('~nIMPORTS~n~n', []),
  814    (   predicate_property(M:H, imported_from(I)),
  815        \+ default_import(M, H, I),
  816        functor(H, F, A),
  817        feedback('~t~8|~w:~w/~d <-- ~w~n', [M, F, A, I]),
  818        '$add_directive_wic'(qsave:restore_import(M, I, F/A)),
  819        fail
  820    ;   true
  821    ).
  822
  823default_import(To, Head, From) :-
  824    '$get_predicate_attribute'(To:Head, (dynamic), 1),
  825    predicate_property(From:Head, exported),
  826    !,
  827    fail.
  828default_import(Into, _, From) :-
  829    default_module(Into, From).
 restore_import(+TargetModule, +SourceModule, +PI) is det
Restore import relation. This notably deals with imports from the module user, avoiding a message that the predicate is not exported.
  837restore_import(To, user, PI) :-
  838    !,
  839    export(user:PI),
  840    To:import(user:PI).
  841restore_import(To, From, PI) :-
  842    To:import(From:PI).
  843
  844                 /*******************************
  845                 *         PROLOG FLAGS         *
  846                 *******************************/
  847
  848save_prolog_flags(Options) :-
  849    feedback('~nPROLOG FLAGS~n~n', []),
  850    '$current_prolog_flag'(Flag, Value0, _Scope, write, Type),
  851    \+ no_save_flag(Flag),
  852    map_flag(Flag, Value0, Value, Options),
  853    feedback('~t~8|~w: ~w (type ~q)~n', [Flag, Value, Type]),
  854    '$add_directive_wic'(qsave:restore_prolog_flag(Flag, Value, Type)),
  855    fail.
  856save_prolog_flags(_).
  857
  858no_save_flag(argv).
  859no_save_flag(os_argv).
  860no_save_flag(access_level).
  861no_save_flag(tty_control).
  862no_save_flag(readline).
  863no_save_flag(associated_file).
  864no_save_flag(cpu_count).
  865no_save_flag(tmp_dir).
  866no_save_flag(file_name_case_handling).
  867no_save_flag(hwnd).                     % should be read-only, but comes
  868                                        % from user-code
  869map_flag(autoload, true, false, Options) :-
  870    option(class(runtime), Options, runtime),
  871    option(autoload(true), Options, true),
  872    !.
  873map_flag(_, Value, Value, _).
 restore_prolog_flag(+Name, +Value, +Type)
Deal with possibly protected flags (debug_on_error and report_error are protected flags for the runtime kernel).
  881restore_prolog_flag(Flag, Value, _Type) :-
  882    current_prolog_flag(Flag, Value),
  883    !.
  884restore_prolog_flag(Flag, Value, _Type) :-
  885    current_prolog_flag(Flag, _),
  886    !,
  887    catch(set_prolog_flag(Flag, Value), _, true).
  888restore_prolog_flag(Flag, Value, Type) :-
  889    create_prolog_flag(Flag, Value, [type(Type)]).
  890
  891
  892                 /*******************************
  893                 *           OPERATORS          *
  894                 *******************************/
 save_operators(+Options) is det
Save operators for all modules. Operators for system are not saved because these are read-only anyway.
  901save_operators(Options) :-
  902    !,
  903    option(op(save), Options, save),
  904    feedback('~nOPERATORS~n', []),
  905    forall(current_module(M), save_module_operators(M)),
  906    feedback('~n', []).
  907save_operators(_).
  908
  909save_module_operators(system) :- !.
  910save_module_operators(M) :-
  911    forall('$local_op'(P,T,M:N),
  912           (   feedback('~n~t~8|~w ', [op(P,T,M:N)]),
  913               '$add_directive_wic'(op(P,T,M:N))
  914           )).
  915
  916
  917                 /*******************************
  918                 *       FORMAT PREDICATES      *
  919                 *******************************/
  920
  921save_format_predicates :-
  922    feedback('~nFORMAT PREDICATES~n', []),
  923    current_format_predicate(Code, Head),
  924    qualify_head(Head, QHead),
  925    D = format_predicate(Code, QHead),
  926    feedback('~n~t~8|~w ', [D]),
  927    '$add_directive_wic'(D),
  928    fail.
  929save_format_predicates.
  930
  931qualify_head(T, T) :-
  932    functor(T, :, 2),
  933    !.
  934qualify_head(T, user:T).
  935
  936
  937                 /*******************************
  938                 *       FOREIGN LIBRARIES      *
  939                 *******************************/
 save_foreign_libraries(+Archive, +Options) is det
Save current foreign libraries into the archive.
  945save_foreign_libraries(RC, Options) :-
  946    option(foreign(save), Options),
  947    !,
  948    current_prolog_flag(arch, HostArch),
  949    feedback('~nHOST(~w) FOREIGN LIBRARIES~n', [HostArch]),
  950    save_foreign_libraries1(HostArch, RC, Options).
  951save_foreign_libraries(RC, Options) :-
  952    option(foreign(arch(Archs)), Options),
  953    !,
  954    forall(member(Arch, Archs),
  955           ( feedback('~n~w FOREIGN LIBRARIES~n', [Arch]),
  956             save_foreign_libraries1(Arch, RC, Options)
  957           )).
  958save_foreign_libraries(_, _).
  959
  960save_foreign_libraries1(Arch, RC, _Options) :-
  961    forall(current_foreign_library(FileSpec, _Predicates),
  962           ( find_foreign_library(Arch, FileSpec, EntryName, File, Time),
  963             term_to_atom(EntryName, Name),
  964             zipper_append_file(RC, Name, File, [time(Time)])
  965           )).
 find_foreign_library(+Architecture, +FileSpec, -EntryName, -File, -Time) is det
Find the shared object specified by FileSpec for the named Architecture. EntryName will be the name of the file within the saved state archive. If posible, the shared object is stripped to reduce its size. This is achieved by calling strip -o <tmp> <shared-object>. Note that (if stripped) the file is a Prolog tmp file and will be deleted on halt.
bug
- Should perform OS search on failure
  979find_foreign_library(Arch, FileSpec, shlib(Arch,Name), SharedObject, Time) :-
  980    FileSpec = foreign(Name),
  981    (   catch(arch_find_shlib(Arch, FileSpec, File),
  982              E,
  983              print_message(error, E)),
  984        exists_file(File)
  985    ->  true
  986    ;   throw(error(existence_error(architecture_shlib(Arch), FileSpec),_))
  987    ),
  988    time_file(File, Time),
  989    strip_file(File, SharedObject).
 strip_file(+File, -Stripped) is det
Try to strip File. Unify Stripped with File if stripping fails for some reason.
  996strip_file(File, Stripped) :-
  997    absolute_file_name(path(strip), Strip,
  998                       [ access(execute),
  999                         file_errors(fail)
 1000                       ]),
 1001    tmp_file(shared, Stripped),
 1002    (   catch(do_strip_file(Strip, File, Stripped), E,
 1003              (print_message(warning, E), fail))
 1004    ->  true
 1005    ;   print_message(warning, qsave(strip_failed(File))),
 1006        fail
 1007    ),
 1008    !.
 1009strip_file(File, File).
 1010
 1011do_strip_file(Strip, File, Stripped) :-
 1012    format(atom(Cmd), '"~w" -x -o "~w" "~w"',
 1013           [Strip, Stripped, File]),
 1014    shell(Cmd),
 1015    exists_file(Stripped).
 qsave:arch_shlib(+Architecture, +FileSpec, -File) is det
This is a user defined hook called by qsave_program/2. It is used to find a shared library for the specified Architecture, named by FileSpec. FileSpec is of the form foreign(Name), a specification usable by absolute_file_name/2. The predicate should unify File with the absolute path for the shared library that corresponds to the specified Architecture.

If this predicate fails to find a file for the specified architecture an existence_error is thrown.

 1029:- multifile arch_shlib/3. 1030
 1031arch_find_shlib(Arch, FileSpec, File) :-
 1032    arch_shlib(Arch, FileSpec, File),
 1033    !.
 1034arch_find_shlib(Arch, FileSpec, File) :-
 1035    current_prolog_flag(arch, Arch),
 1036    absolute_file_name(FileSpec,
 1037                       [ file_type(executable),
 1038                         access(read),
 1039                         file_errors(fail)
 1040                       ], File),
 1041    !.
 1042arch_find_shlib(Arch, foreign(Base), File) :-
 1043    current_prolog_flag(arch, Arch),
 1044    current_prolog_flag(windows, true),
 1045    current_prolog_flag(executable, WinExe),
 1046    prolog_to_os_filename(Exe, WinExe),
 1047    file_directory_name(Exe, BinDir),
 1048    file_name_extension(Base, dll, DllFile),
 1049    atomic_list_concat([BinDir, /, DllFile], File),
 1050    exists_file(File).
 1051
 1052
 1053                 /*******************************
 1054                 *             UTIL             *
 1055                 *******************************/
 1056
 1057open_map(Options) :-
 1058    option(map(Map), Options),
 1059    !,
 1060    open(Map, write, Fd),
 1061    asserta(verbose(Fd)).
 1062open_map(_) :-
 1063    retractall(verbose(_)).
 1064
 1065close_map :-
 1066    retract(verbose(Fd)),
 1067    close(Fd),
 1068    !.
 1069close_map.
 1070
 1071feedback(Fmt, Args) :-
 1072    verbose(Fd),
 1073    !,
 1074    format(Fd, Fmt, Args).
 1075feedback(_, _).
 1076
 1077
 1078check_options([]) :- !.
 1079check_options([Var|_]) :-
 1080    var(Var),
 1081    !,
 1082    throw(error(domain_error(save_options, Var), _)).
 1083check_options([Name=Value|T]) :-
 1084    !,
 1085    (   save_option(Name, Type, _Comment)
 1086    ->  (   must_be(Type, Value)
 1087        ->  check_options(T)
 1088        ;   throw(error(domain_error(Type, Value), _))
 1089        )
 1090    ;   throw(error(domain_error(save_option, Name), _))
 1091    ).
 1092check_options([Term|T]) :-
 1093    Term =.. [Name,Arg],
 1094    !,
 1095    check_options([Name=Arg|T]).
 1096check_options([Var|_]) :-
 1097    throw(error(domain_error(save_options, Var), _)).
 1098check_options(Opt) :-
 1099    throw(error(domain_error(list, Opt), _)).
 zipper_append_file(+Zipper, +Name, +File, +Options) is det
Append the content of File under Name to the open Zipper.
 1106zipper_append_file(_, Name, _, _) :-
 1107    saved_resource_file(Name),
 1108    !.
 1109zipper_append_file(_, _, File, _) :-
 1110    source_file(File),
 1111    !.
 1112zipper_append_file(Zipper, Name, File, Options) :-
 1113    (   option(time(_), Options)
 1114    ->  Options1 = Options
 1115    ;   time_file(File, Stamp),
 1116        Options1 = [time(Stamp)|Options]
 1117    ),
 1118    setup_call_cleanup(
 1119        open(File, read, In, [type(binary)]),
 1120        setup_call_cleanup(
 1121            zipper_open_new_file_in_zip(Zipper, Name, Out, Options1),
 1122            copy_stream_data(In, Out),
 1123            close(Out)),
 1124        close(In)),
 1125    assertz(saved_resource_file(Name)).
 zipper_add_directory(+Zipper, +Name, +Dir, +Options) is det
Add a directory entry. Dir is only used if there is no option time(Stamp).
 1132zipper_add_directory(Zipper, Name, Dir, Options) :-
 1133    (   option(time(Stamp), Options)
 1134    ->  true
 1135    ;   time_file(Dir, Stamp)
 1136    ),
 1137    atom_concat(Name, /, DirName),
 1138    (   saved_resource_file(DirName)
 1139    ->  true
 1140    ;   setup_call_cleanup(
 1141            zipper_open_new_file_in_zip(Zipper, DirName, Out,
 1142                                        [ method(store),
 1143                                          time(Stamp)
 1144                                        | Options
 1145                                        ]),
 1146            true,
 1147            close(Out)),
 1148        assertz(saved_resource_file(DirName))
 1149    ).
 1150
 1151add_parent_dirs(Zipper, Name, Dir, Options) :-
 1152    (   option(time(Stamp), Options)
 1153    ->  true
 1154    ;   time_file(Dir, Stamp)
 1155    ),
 1156    file_directory_name(Name, Parent),
 1157    (   Parent \== Name
 1158    ->  add_parent_dirs(Zipper, Parent, [time(Stamp)|Options])
 1159    ;   true
 1160    ).
 1161
 1162add_parent_dirs(_, '.', _) :-
 1163    !.
 1164add_parent_dirs(Zipper, Name, Options) :-
 1165    zipper_add_directory(Zipper, Name, _, Options),
 1166    file_directory_name(Name, Parent),
 1167    (   Parent \== Name
 1168    ->  add_parent_dirs(Zipper, Parent, Options)
 1169    ;   true
 1170    ).
 zipper_append_directory(+Zipper, +Name, +Dir, +Options) is det
Append the content of Dir below Name in the resource archive. Options:
include(+Patterns)
Only add entries that match an element from Patterns using wildcard_match/2.
exclude(+Patterns)
Ignore entries that match an element from Patterns using wildcard_match/2.
To be done
- Process .gitignore. There also seem to exists other standards for this.
 1188zipper_append_directory(Zipper, Name, Dir, Options) :-
 1189    exists_directory(Dir),
 1190    !,
 1191    add_parent_dirs(Zipper, Name, Dir, Options),
 1192    zipper_add_directory(Zipper, Name, Dir, Options),
 1193    directory_files(Dir, Members),
 1194    forall(member(M, Members),
 1195           (   reserved(M)
 1196           ->  true
 1197           ;   ignored(M, Options)
 1198           ->  true
 1199           ;   atomic_list_concat([Dir,M], /, Entry),
 1200               atomic_list_concat([Name,M], /, Store),
 1201               catch(zipper_append_directory(Zipper, Store, Entry, Options),
 1202                     E,
 1203                     print_message(warning, E))
 1204           )).
 1205zipper_append_directory(Zipper, Name, File, Options) :-
 1206    zipper_append_file(Zipper, Name, File, Options).
 1207
 1208reserved(.).
 1209reserved(..).
 ignored(+File, +Options) is semidet
Ignore File if there is an include(Patterns) option that does not match File or an exclude(Patterns) that does match File.
 1216ignored(File, Options) :-
 1217    option(include(Patterns), Options),
 1218    \+ ( (   is_list(Patterns)
 1219         ->  member(Pattern, Patterns)
 1220         ;   Pattern = Patterns
 1221         ),
 1222         glob_match(Pattern, File)
 1223       ),
 1224    !.
 1225ignored(File, Options) :-
 1226    option(exclude(Patterns), Options),
 1227    (   is_list(Patterns)
 1228    ->  member(Pattern, Patterns)
 1229    ;   Pattern = Patterns
 1230    ),
 1231    glob_match(Pattern, File),
 1232    !.
 1233
 1234glob_match(Pattern, File) :-
 1235    current_prolog_flag(file_name_case_handling, case_sensitive),
 1236    !,
 1237    wildcard_match(Pattern, File).
 1238glob_match(Pattern, File) :-
 1239    wildcard_match(Pattern, File, [case_sensitive(false)]).
 1240
 1241
 1242                /********************************
 1243                *     SAVED STATE GENERATION    *
 1244                *********************************/
 qsave_toplevel
Called to handle `-c file` compilaton.
 1250:- public
 1251    qsave_toplevel/0. 1252
 1253qsave_toplevel :-
 1254    current_prolog_flag(os_argv, Argv),
 1255    qsave_options(Argv, Files, Options),
 1256    set_on_error(Options),
 1257    '$cmd_option_val'(compileout, Out),
 1258    user:consult(Files),
 1259    maybe_exit_on_errors,
 1260    qsave_program(Out, user:Options).
 1261
 1262set_on_error(Options) :-
 1263    option(on_error(_), Options), !.
 1264set_on_error(_Options) :-
 1265    set_prolog_flag(on_error, status).
 1266
 1267maybe_exit_on_errors :-
 1268    '$exit_code'(Code),
 1269    (   Code =\= 0
 1270    ->  halt
 1271    ;   true
 1272    ).
 1273
 1274qsave_options([], [], []).
 1275qsave_options([--|_], [], []) :-
 1276    !.
 1277qsave_options(['-c'|T0], Files, Options) :-
 1278    !,
 1279    argv_files(T0, T1, Files, FilesT),
 1280    qsave_options(T1, FilesT, Options).
 1281qsave_options([O|T0], Files, [Option|T]) :-
 1282    string_concat(--, Opt, O),
 1283    split_string(Opt, =, '', [NameS|Rest]),
 1284    split_string(NameS, '-', '', NameParts),
 1285    atomic_list_concat(NameParts, '_', Name),
 1286    qsave_option(Name, OptName, Rest, Value),
 1287    !,
 1288    Option =.. [OptName, Value],
 1289    qsave_options(T0, Files, T).
 1290qsave_options([_|T0], Files, T) :-
 1291    qsave_options(T0, Files, T).
 1292
 1293argv_files([], [], Files, Files).
 1294argv_files([H|T], [H|T], Files, Files) :-
 1295    sub_atom(H, 0, _, _, -),
 1296    !.
 1297argv_files([H|T0], T, [H|Files0], Files) :-
 1298    argv_files(T0, T, Files0, Files).
 qsave_option(+Name, +ValueStrings, -Value) is semidet
 1302qsave_option(Name, Name, [], true) :-
 1303    save_option(Name, boolean, _),
 1304    !.
 1305qsave_option(NoName, Name, [], false) :-
 1306    atom_concat('no_', Name, NoName),
 1307    save_option(Name, boolean, _),
 1308    !.
 1309qsave_option(Name, Name, ValueStrings, Value) :-
 1310    save_option(Name, Type, _),
 1311    !,
 1312    atomics_to_string(ValueStrings, "=", ValueString),
 1313    convert_option_value(Type, ValueString, Value).
 1314qsave_option(Name, Name, _Chars, _Value) :-
 1315    existence_error(save_option, Name).
 1316
 1317convert_option_value(integer, String, Value) :-
 1318    (   number_string(Value, String)
 1319    ->  true
 1320    ;   sub_string(String, 0, _, 1, SubString),
 1321        sub_string(String, _, 1, 0, Suffix0),
 1322        downcase_atom(Suffix0, Suffix),
 1323        number_string(Number, SubString),
 1324        suffix_multiplier(Suffix, Multiplier)
 1325    ->  Value is Number * Multiplier
 1326    ;   domain_error(integer, String)
 1327    ).
 1328convert_option_value(callable, String, Value) :-
 1329    term_string(Value, String).
 1330convert_option_value(atom, String, Value) :-
 1331    atom_string(Value, String).
 1332convert_option_value(boolean, String, Value) :-
 1333    atom_string(Value, String).
 1334convert_option_value(oneof(_), String, Value) :-
 1335    atom_string(Value, String).
 1336convert_option_value(ground, String, Value) :-
 1337    atom_string(Value, String).
 1338convert_option_value(qsave_foreign_option, "save", save).
 1339convert_option_value(qsave_foreign_option, StrArchList, arch(ArchList)) :-
 1340    split_string(StrArchList, ",", ", \t", StrArchList1),
 1341    maplist(atom_string, ArchList, StrArchList1).
 1342
 1343suffix_multiplier(b, 1).
 1344suffix_multiplier(k, 1024).
 1345suffix_multiplier(m, 1024 * 1024).
 1346suffix_multiplier(g, 1024 * 1024 * 1024).
 1347
 1348
 1349                 /*******************************
 1350                 *            MESSAGES          *
 1351                 *******************************/
 1352
 1353:- multifile prolog:message/3. 1354
 1355prolog:message(no_resource(Name, File)) -->
 1356    [ 'Could not find resource ~w on ~w or system resources'-
 1357      [Name, File] ].
 1358prolog:message(qsave(nondet)) -->
 1359    [ 'qsave_program/2 succeeded with a choice point'-[] ]