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

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 ...

*/

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

  286save_options(RC, SaveClass, Options) :-
  287    zipper_open_new_file_in_zip(RC, '$prolog/options.txt', Fd, []),
  288    (   doption(OptionName),
  289            (   OptTerm =.. [OptionName,OptionVal2],
  290                option(OptTerm, Options)
  291            ->  convert_option(OptionName, OptionVal2, OptionVal, FmtVal)
  292            ;   '$cmd_option_val'(OptionName, OptionVal0),
  293                save_option_value(SaveClass, OptionName, OptionVal0, OptionVal1),
  294                OptionVal = OptionVal1,
  295                FmtVal = '~w'
  296            ),
  297            atomics_to_string(['~w=', FmtVal, '~n'], Fmt),
  298            format(Fd, Fmt, [OptionName, OptionVal]),
  299        fail
  300    ;   true
  301    ),
  302    save_init_goals(Fd, Options),
  303    close(Fd).
 save_option_value(+SaveClass, +OptionName, +OptionValue, -FinalValue)
  307save_option_value(Class,   class, _,     Class) :- !.
  308save_option_value(runtime, home,  _,     _) :- !, fail.
  309save_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.
  316save_init_goals(Out, Options) :-
  317    option(goal(Goal), Options),
  318    !,
  319    format(Out, 'goal=~q~n', [Goal]),
  320    save_toplevel_goal(Out, halt, Options).
  321save_init_goals(Out, Options) :-
  322    '$cmd_option_val'(goals, Goals),
  323    forall(member(Goal, Goals),
  324           format(Out, 'goal=~w~n', [Goal])),
  325    (   Goals == []
  326    ->  DefToplevel = default
  327    ;   DefToplevel = halt
  328    ),
  329    save_toplevel_goal(Out, DefToplevel, Options).
  330
  331save_toplevel_goal(Out, _Default, Options) :-
  332    option(toplevel(Goal), Options),
  333    !,
  334    unqualify_reserved_goal(Goal, Goal1),
  335    format(Out, 'toplevel=~q~n', [Goal1]).
  336save_toplevel_goal(Out, _Default, _Options) :-
  337    '$cmd_option_val'(toplevel, Toplevel),
  338    Toplevel \== default,
  339    !,
  340    format(Out, 'toplevel=~w~n', [Toplevel]).
  341save_toplevel_goal(Out, Default, _Options) :-
  342    format(Out, 'toplevel=~q~n', [Default]).
  343
  344unqualify_reserved_goal(_:prolog, prolog) :- !.
  345unqualify_reserved_goal(_:default, default) :- !.
  346unqualify_reserved_goal(Goal, Goal).
  347
  348
  349                 /*******************************
  350                 *           RESOURCES          *
  351                 *******************************/
  352
  353save_resources(_RC, development) :- !.
  354save_resources(RC, _SaveClass) :-
  355    feedback('~nRESOURCES~n~n', []),
  356    copy_resources(RC),
  357    forall(declared_resource(Name, FileSpec, Options),
  358           save_resource(RC, Name, FileSpec, Options)).
  359
  360declared_resource(RcName, FileSpec, []) :-
  361    current_predicate(_, M:resource(_,_)),
  362    M:resource(Name, FileSpec),
  363    mkrcname(M, Name, RcName).
  364declared_resource(RcName, FileSpec, Options) :-
  365    current_predicate(_, M:resource(_,_,_)),
  366    M:resource(Name, A2, A3),
  367    (   is_list(A3)
  368    ->  FileSpec = A2,
  369        Options = A3
  370    ;   FileSpec = A3
  371    ),
  372    mkrcname(M, Name, RcName).
 mkrcname(+Module, +NameSpec, -Name)
Turn a resource name term into a resource name atom.
  378mkrcname(user, Name0, Name) :-
  379    !,
  380    path_segments_to_atom(Name0, Name).
  381mkrcname(M, Name0, RcName) :-
  382    path_segments_to_atom(Name0, Name),
  383    atomic_list_concat([M, :, Name], RcName).
  384
  385path_segments_to_atom(Name0, Name) :-
  386    phrase(segments_to_atom(Name0), Atoms),
  387    atomic_list_concat(Atoms, /, Name).
  388
  389segments_to_atom(Var) -->
  390    { var(Var), !,
  391      instantiation_error(Var)
  392    }.
  393segments_to_atom(A/B) -->
  394    !,
  395    segments_to_atom(A),
  396    segments_to_atom(B).
  397segments_to_atom(A) -->
  398    [A].
 save_resource(+Zipper, +Name, +FileSpec, +Options) is det
Add the content represented by FileSpec to Zipper under Name.
  404save_resource(RC, Name, FileSpec, _Options) :-
  405    absolute_file_name(FileSpec,
  406                       [ access(read),
  407                         file_errors(fail)
  408                       ], File),
  409    !,
  410    feedback('~t~8|~w~t~32|~w~n',
  411             [Name, File]),
  412    zipper_append_file(RC, Name, File, []).
  413save_resource(RC, Name, FileSpec, Options) :-
  414    findall(Dir,
  415            absolute_file_name(FileSpec, Dir,
  416                               [ access(read),
  417                                 file_type(directory),
  418                                 file_errors(fail),
  419                                 solutions(all)
  420                               ]),
  421            Dirs),
  422    Dirs \== [],
  423    !,
  424    forall(member(Dir, Dirs),
  425           ( feedback('~t~8|~w~t~32|~w~n',
  426                      [Name, Dir]),
  427             zipper_append_directory(RC, Name, Dir, Options))).
  428save_resource(RC, Name, _, _Options) :-
  429    '$rc_handle'(SystemRC),
  430    copy_resource(SystemRC, RC, Name),
  431    !.
  432save_resource(_, Name, FileSpec, _Options) :-
  433    print_message(warning,
  434                  error(existence_error(resource,
  435                                        resource(Name, FileSpec)),
  436                        _)).
  437
  438copy_resources(ToRC) :-
  439    '$rc_handle'(FromRC),
  440    zipper_members(FromRC, List),
  441    (   member(Name, List),
  442        \+ declared_resource(Name, _, _),
  443        \+ reserved_resource(Name),
  444        copy_resource(FromRC, ToRC, Name),
  445        fail
  446    ;   true
  447    ).
  448
  449reserved_resource('$prolog/state.qlf').
  450reserved_resource('$prolog/options.txt').
  451
  452copy_resource(FromRC, ToRC, Name) :-
  453    (   zipper_goto(FromRC, file(Name))
  454    ->  true
  455    ;   existence_error(resource, Name)
  456    ),
  457    zipper_file_info(FromRC, _Name, Attrs),
  458    get_dict(time, Attrs, Time),
  459    setup_call_cleanup(
  460        zipper_open_current(FromRC, FdIn,
  461                            [ type(binary),
  462                              time(Time)
  463                            ]),
  464        setup_call_cleanup(
  465            zipper_open_new_file_in_zip(ToRC, Name, FdOut, []),
  466            ( feedback('~t~8|~w~t~24|~w~n',
  467                       [Name, '<Copied from running state>']),
  468              copy_stream_data(FdIn, FdOut)
  469            ),
  470            close(FdOut)),
  471        close(FdIn)).
  472
  473
  474		 /*******************************
  475		 *           OBFUSCATE		*
  476		 *******************************/
 create_mapping(+Options) is det
Call hook to obfuscate symbols.
  482:- multifile prolog:obfuscate_identifiers/1.  483
  484create_mapping(Options) :-
  485    option(obfuscate(true), Options),
  486    !,
  487    (   predicate_property(prolog:obfuscate_identifiers(_), number_of_clauses(N)),
  488        N > 0
  489    ->  true
  490    ;   use_module(library(obfuscate))
  491    ),
  492    (   catch(prolog:obfuscate_identifiers(Options), E,
  493              print_message(error, E))
  494    ->  true
  495    ;   print_message(warning, failed(obfuscate_identifiers))
  496    ).
  497create_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?
  507lock_files(runtime) :-
  508    !,
  509    '$set_source_files'(system).                % implies from_state
  510lock_files(_) :-
  511    '$set_source_files'(from_state).
 save_program(+Zipper, +SaveClass, +Options) is det
Save the program itself as virtual machine code to Zipper.
  517save_program(RC, SaveClass, Options) :-
  518    setup_call_cleanup(
  519        ( zipper_open_new_file_in_zip(RC, '$prolog/state.qlf', StateFd,
  520                                      [ zip64(true)
  521                                      ]),
  522          current_prolog_flag(access_level, OldLevel),
  523          set_prolog_flag(access_level, system), % generate system modules
  524          '$open_wic'(StateFd, Options)
  525        ),
  526        ( create_mapping(Options),
  527          save_modules(SaveClass),
  528          save_records,
  529          save_flags,
  530          save_prompt,
  531          save_imports,
  532          save_prolog_flags(Options),
  533          save_operators(Options),
  534          save_format_predicates
  535        ),
  536        ( '$close_wic',
  537          set_prolog_flag(access_level, OldLevel),
  538          close(StateFd)
  539        )).
  540
  541
  542                 /*******************************
  543                 *            MODULES           *
  544                 *******************************/
  545
  546save_modules(SaveClass) :-
  547    forall(special_module(X),
  548           save_module(X, SaveClass)),
  549    forall((current_module(X), \+ special_module(X)),
  550           save_module(X, SaveClass)).
  551
  552special_module(system).
  553special_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.
  562prepare_entry_points(Options) :-
  563    define_init_goal(Options),
  564    define_toplevel_goal(Options).
  565
  566define_init_goal(Options) :-
  567    option(goal(Goal), Options),
  568    !,
  569    entry_point(Goal).
  570define_init_goal(_).
  571
  572define_toplevel_goal(Options) :-
  573    option(toplevel(Goal), Options),
  574    !,
  575    entry_point(Goal).
  576define_toplevel_goal(_).
  577
  578entry_point(Goal) :-
  579    define_predicate(Goal),
  580    (   \+ predicate_property(Goal, built_in),
  581        \+ predicate_property(Goal, imported_from(_))
  582    ->  goal_pi(Goal, PI),
  583        public(PI)
  584    ;   true
  585    ).
  586
  587define_predicate(Head) :-
  588    '$define_predicate'(Head),
  589    !.   % autoloader
  590define_predicate(Head) :-
  591    strip_module(Head, _, Term),
  592    functor(Term, Name, Arity),
  593    throw(error(existence_error(procedure, Name/Arity), _)).
  594
  595goal_pi(M:G, QPI) :-
  596    !,
  597    strip_module(M:G, Module, Goal),
  598    functor(Goal, Name, Arity),
  599    QPI = Module:Name/Arity.
  600goal_pi(Goal, Name/Arity) :-
  601    functor(Goal, Name, Arity).
 prepare_state(+Options) is det
Prepare the executable by running the prepare_state registered initialization hooks.
  608prepare_state(_) :-
  609    forall('$init_goal'(when(prepare_state), Goal, Ctx),
  610           run_initialize(Goal, Ctx)).
  611
  612run_initialize(Goal, Ctx) :-
  613    (   catch(Goal, E, true),
  614        (   var(E)
  615        ->  true
  616        ;   throw(error(initialization_error(E, Goal, Ctx), _))
  617        )
  618    ;   throw(error(initialization_error(failed, Goal, Ctx), _))
  619    ).
  620
  621
  622                 /*******************************
  623                 *            AUTOLOAD          *
  624                 *******************************/
 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.
  633save_autoload(Options) :-
  634    option(autoload(true),  Options, true),
  635    !,
  636    setup_call_cleanup(
  637        current_prolog_flag(autoload, Old),
  638        autoload_all(Options),
  639        set_prolog_flag(autoload, Old)).
  640save_autoload(_).
  641
  642
  643                 /*******************************
  644                 *             MODULES          *
  645                 *******************************/
 save_module(+Module, +SaveClass)
Saves a module
  651save_module(M, SaveClass) :-
  652    '$qlf_start_module'(M),
  653    feedback('~n~nMODULE ~w~n', [M]),
  654    save_unknown(M),
  655    (   P = (M:_H),
  656        current_predicate(_, P),
  657        \+ predicate_property(P, imported_from(_)),
  658        save_predicate(P, SaveClass),
  659        fail
  660    ;   '$qlf_end_part',
  661        feedback('~n', [])
  662    ).
  663
  664save_predicate(P, _SaveClass) :-
  665    predicate_property(P, foreign),
  666    !,
  667    P = (M:H),
  668    functor(H, Name, Arity),
  669    feedback('~npre-defining foreign ~w/~d ', [Name, Arity]),
  670    '$add_directive_wic'('$predefine_foreign'(M:Name/Arity)).
  671save_predicate(P, SaveClass) :-
  672    P = (M:H),
  673    functor(H, F, A),
  674    feedback('~nsaving ~w/~d ', [F, A]),
  675    (   (   H = resource(_,_)
  676        ;   H = resource(_,_,_)
  677        ),
  678        SaveClass \== development
  679    ->  save_attribute(P, (dynamic)),
  680        (   M == user
  681        ->  save_attribute(P, (multifile))
  682        ),
  683        feedback('(Skipped clauses)', []),
  684        fail
  685    ;   true
  686    ),
  687    (   no_save(P)
  688    ->  true
  689    ;   save_attributes(P),
  690        \+ predicate_property(P, (volatile)),
  691        (   nth_clause(P, _, Ref),
  692            feedback('.', []),
  693            '$qlf_assert_clause'(Ref, SaveClass),
  694            fail
  695        ;   true
  696        )
  697    ).
  698
  699no_save(P) :-
  700    predicate_property(P, volatile),
  701    \+ predicate_property(P, dynamic),
  702    \+ predicate_property(P, multifile).
  703
  704pred_attrib(meta_predicate(Term), Head, meta_predicate(M:Term)) :-
  705    !,
  706    strip_module(Head, M, _).
  707pred_attrib(Attrib, Head,
  708            '$set_predicate_attribute'(M:Name/Arity, AttName, Val)) :-
  709    attrib_name(Attrib, AttName, Val),
  710    strip_module(Head, M, Term),
  711    functor(Term, Name, Arity).
  712
  713attrib_name(dynamic,                dynamic,                true).
  714attrib_name(volatile,               volatile,               true).
  715attrib_name(thread_local,           thread_local,           true).
  716attrib_name(multifile,              multifile,              true).
  717attrib_name(public,                 public,                 true).
  718attrib_name(transparent,            transparent,            true).
  719attrib_name(discontiguous,          discontiguous,          true).
  720attrib_name(notrace,                trace,                  false).
  721attrib_name(show_childs,            hide_childs,            false).
  722attrib_name(built_in,               system,                 true).
  723attrib_name(nodebug,                hide_childs,            true).
  724attrib_name(quasi_quotation_syntax, quasi_quotation_syntax, true).
  725attrib_name(iso,                    iso,                    true).
  726
  727
  728save_attribute(P, Attribute) :-
  729    pred_attrib(Attribute, P, D),
  730    (   Attribute == built_in       % no need if there are clauses
  731    ->  (   predicate_property(P, number_of_clauses(0))
  732        ->  true
  733        ;   predicate_property(P, volatile)
  734        )
  735    ;   Attribute == (dynamic)      % no need if predicate is thread_local
  736    ->  \+ predicate_property(P, thread_local)
  737    ;   true
  738    ),
  739    '$add_directive_wic'(D),
  740    feedback('(~w) ', [Attribute]).
  741
  742save_attributes(P) :-
  743    (   predicate_property(P, Attribute),
  744        save_attribute(P, Attribute),
  745        fail
  746    ;   true
  747    ).
  748
  749%       Save status of the unknown flag
  750
  751save_unknown(M) :-
  752    current_prolog_flag(M:unknown, Unknown),
  753    (   Unknown == error
  754    ->  true
  755    ;   '$add_directive_wic'(set_prolog_flag(M:unknown, Unknown))
  756    ).
  757
  758                 /*******************************
  759                 *            RECORDS           *
  760                 *******************************/
  761
  762save_records :-
  763    feedback('~nRECORDS~n', []),
  764    (   current_key(X),
  765        X \== '$topvar',                        % do not safe toplevel variables
  766        feedback('~n~t~8|~w ', [X]),
  767        recorded(X, V, _),
  768        feedback('.', []),
  769        '$add_directive_wic'(recordz(X, V, _)),
  770        fail
  771    ;   true
  772    ).
  773
  774
  775                 /*******************************
  776                 *            FLAGS             *
  777                 *******************************/
  778
  779save_flags :-
  780    feedback('~nFLAGS~n~n', []),
  781    (   current_flag(X),
  782        flag(X, V, V),
  783        feedback('~t~8|~w = ~w~n', [X, V]),
  784        '$add_directive_wic'(set_flag(X, V)),
  785        fail
  786    ;   true
  787    ).
  788
  789save_prompt :-
  790    feedback('~nPROMPT~n~n', []),
  791    prompt(Prompt, Prompt),
  792    '$add_directive_wic'(prompt(_, Prompt)).
  793
  794
  795                 /*******************************
  796                 *           IMPORTS            *
  797                 *******************************/
 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.
  807save_imports :-
  808    feedback('~nIMPORTS~n~n', []),
  809    (   predicate_property(M:H, imported_from(I)),
  810        \+ default_import(M, H, I),
  811        functor(H, F, A),
  812        feedback('~t~8|~w:~w/~d <-- ~w~n', [M, F, A, I]),
  813        '$add_directive_wic'(qsave:restore_import(M, I, F/A)),
  814        fail
  815    ;   true
  816    ).
  817
  818default_import(To, Head, From) :-
  819    '$get_predicate_attribute'(To:Head, (dynamic), 1),
  820    predicate_property(From:Head, exported),
  821    !,
  822    fail.
  823default_import(Into, _, From) :-
  824    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.
  832restore_import(To, user, PI) :-
  833    !,
  834    export(user:PI),
  835    To:import(user:PI).
  836restore_import(To, From, PI) :-
  837    To:import(From:PI).
  838
  839                 /*******************************
  840                 *         PROLOG FLAGS         *
  841                 *******************************/
  842
  843save_prolog_flags(Options) :-
  844    feedback('~nPROLOG FLAGS~n~n', []),
  845    '$current_prolog_flag'(Flag, Value0, _Scope, write, Type),
  846    \+ no_save_flag(Flag),
  847    map_flag(Flag, Value0, Value, Options),
  848    feedback('~t~8|~w: ~w (type ~q)~n', [Flag, Value, Type]),
  849    '$add_directive_wic'(qsave:restore_prolog_flag(Flag, Value, Type)),
  850    fail.
  851save_prolog_flags(_).
  852
  853no_save_flag(argv).
  854no_save_flag(os_argv).
  855no_save_flag(access_level).
  856no_save_flag(tty_control).
  857no_save_flag(readline).
  858no_save_flag(associated_file).
  859no_save_flag(cpu_count).
  860no_save_flag(tmp_dir).
  861no_save_flag(file_name_case_handling).
  862no_save_flag(hwnd).                     % should be read-only, but comes
  863                                        % from user-code
  864map_flag(autoload, true, false, Options) :-
  865    option(class(runtime), Options, runtime),
  866    option(autoload(true), Options, true),
  867    !.
  868map_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).
  876restore_prolog_flag(Flag, Value, _Type) :-
  877    current_prolog_flag(Flag, Value),
  878    !.
  879restore_prolog_flag(Flag, Value, _Type) :-
  880    current_prolog_flag(Flag, _),
  881    !,
  882    catch(set_prolog_flag(Flag, Value), _, true).
  883restore_prolog_flag(Flag, Value, Type) :-
  884    create_prolog_flag(Flag, Value, [type(Type)]).
  885
  886
  887                 /*******************************
  888                 *           OPERATORS          *
  889                 *******************************/
 save_operators(+Options) is det
Save operators for all modules. Operators for system are not saved because these are read-only anyway.
  896save_operators(Options) :-
  897    !,
  898    option(op(save), Options, save),
  899    feedback('~nOPERATORS~n', []),
  900    forall(current_module(M), save_module_operators(M)),
  901    feedback('~n', []).
  902save_operators(_).
  903
  904save_module_operators(system) :- !.
  905save_module_operators(M) :-
  906    forall('$local_op'(P,T,M:N),
  907           (   feedback('~n~t~8|~w ', [op(P,T,M:N)]),
  908               '$add_directive_wic'(op(P,T,M:N))
  909           )).
  910
  911
  912                 /*******************************
  913                 *       FORMAT PREDICATES      *
  914                 *******************************/
  915
  916save_format_predicates :-
  917    feedback('~nFORMAT PREDICATES~n', []),
  918    current_format_predicate(Code, Head),
  919    qualify_head(Head, QHead),
  920    D = format_predicate(Code, QHead),
  921    feedback('~n~t~8|~w ', [D]),
  922    '$add_directive_wic'(D),
  923    fail.
  924save_format_predicates.
  925
  926qualify_head(T, T) :-
  927    functor(T, :, 2),
  928    !.
  929qualify_head(T, user:T).
  930
  931
  932                 /*******************************
  933                 *       FOREIGN LIBRARIES      *
  934                 *******************************/
 save_foreign_libraries(+Archive, +Options) is det
Save current foreign libraries into the archive.
  940save_foreign_libraries(RC, Options) :-
  941    option(foreign(save), Options),
  942    !,
  943    current_prolog_flag(arch, HostArch),
  944    feedback('~nHOST(~w) FOREIGN LIBRARIES~n', [HostArch]),
  945    save_foreign_libraries1(HostArch, RC, Options).
  946save_foreign_libraries(RC, Options) :-
  947    option(foreign(arch(Archs)), Options),
  948    !,
  949    forall(member(Arch, Archs),
  950           ( feedback('~n~w FOREIGN LIBRARIES~n', [Arch]),
  951             save_foreign_libraries1(Arch, RC, Options)
  952           )).
  953save_foreign_libraries(_, _).
  954
  955save_foreign_libraries1(Arch, RC, _Options) :-
  956    forall(current_foreign_library(FileSpec, _Predicates),
  957           ( find_foreign_library(Arch, FileSpec, EntryName, File, Time),
  958             term_to_atom(EntryName, Name),
  959             zipper_append_file(RC, Name, File, [time(Time)])
  960           )).
 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
  974find_foreign_library(Arch, FileSpec, shlib(Arch,Name), SharedObject, Time) :-
  975    FileSpec = foreign(Name),
  976    (   catch(arch_find_shlib(Arch, FileSpec, File),
  977              E,
  978              print_message(error, E)),
  979        exists_file(File)
  980    ->  true
  981    ;   throw(error(existence_error(architecture_shlib(Arch), FileSpec),_))
  982    ),
  983    time_file(File, Time),
  984    strip_file(File, SharedObject).
 strip_file(+File, -Stripped) is det
Try to strip File. Unify Stripped with File if stripping fails for some reason.
  991strip_file(File, Stripped) :-
  992    absolute_file_name(path(strip), Strip,
  993                       [ access(execute),
  994                         file_errors(fail)
  995                       ]),
  996    tmp_file(shared, Stripped),
  997    (   catch(do_strip_file(Strip, File, Stripped), E,
  998              (print_message(warning, E), fail))
  999    ->  true
 1000    ;   print_message(warning, qsave(strip_failed(File))),
 1001        fail
 1002    ),
 1003    !.
 1004strip_file(File, File).
 1005
 1006do_strip_file(Strip, File, Stripped) :-
 1007    format(atom(Cmd), '"~w" -o "~w" "~w"',
 1008           [Strip, Stripped, File]),
 1009    shell(Cmd),
 1010    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.

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