/* Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: J.Wielemaker@vu.nl
WWW: http://www.swi-prolog.org
Copyright (c) 1995-2016, University of Amsterdam
VU University Amsterdam
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in
the documentation and/or other materials provided with the
distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
*/
:- module(qsave,
[ qsave_program/1, % +File
qsave_program/2 % +File, +Options
]).
:- use_module(library(lists)).
:- use_module(library(option)).
:- use_module(library(error)).
/** <module> 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 ...
==
*/
:- meta_predicate
qsave_program(+, :).
:- predicate_options(qsave_program/2, 2,
[ local(integer),
global(integer),
trail(integer),
goal(callable),
toplevel(callable),
init_file(atom),
class(oneof([runtime,kernel,development])),
autoload(boolean),
map(atom),
op(oneof([save,standard])),
stand_alone(boolean),
foreign(oneof([save,no_save])),
emulator(atom)
]).
:- set_prolog_flag(generate_debug_info, false).
:- dynamic verbose/1.
:- volatile verbose/1. % contains a stream-handle
%! qsave_program(+File) is det.
%! qsave_program(+File, :Options) is det.
%
% Make a saved state in file `File'.
qsave_program(File) :-
qsave_program(File, []).
qsave_program(FileBase, Options0) :-
meta_options(is_meta, Options0, Options),
check_options(Options),
exe_file(FileBase, File),
option(class(SaveClass), Options, runtime),
option(init_file(InitFile), Options, DefInit),
default_init_file(SaveClass, DefInit),
save_autoload(Options),
open_map(Options),
create_prolog_flag(saved_program, true, []),
create_prolog_flag(saved_program_class, SaveClass, []),
( exists_file(File)
-> delete_file(File)
; true
),
'$rc_open_archive'(File, RC),
make_header(RC, SaveClass, Options),
save_options(RC, SaveClass,
[ init_file(InitFile)
| Options
]),
save_resources(RC, SaveClass),
'$rc_open'(RC, '$state', '$prolog', write, StateFd),
'$open_wic'(StateFd),
setup_call_cleanup(
( current_prolog_flag(access_level, OldLevel),
set_prolog_flag(access_level, system) % generate system modules
),
( save_modules(SaveClass),
save_records,
save_flags,
save_prompt,
save_imports,
save_prolog_flags,
save_operators(Options),
save_format_predicates
),
set_prolog_flag(access_level, OldLevel)),
'$close_wic',
close(StateFd),
save_foreign_libraries(RC, Options),
'$rc_close_archive'(RC),
'$mark_executable'(File),
close_map.
is_meta(goal).
is_meta(toplevel).
exe_file(Base, Exe) :-
current_prolog_flag(windows, true),
file_name_extension(_, '', Base),
!,
file_name_extension(Base, exe, Exe).
exe_file(Exe, Exe).
default_init_file(runtime, none) :- !.
default_init_file(_, InitFile) :-
'$cmd_option_val'(init_file, InitFile).
/*******************************
* HEADER *
*******************************/
make_header(RC, _, Options) :-
option(emulator(OptVal), Options),
!,
absolute_file_name(OptVal, [access(read)], Emulator),
'$rc_append_file'(RC, '$header', '$rc', none, Emulator).
make_header(RC, _, Options) :-
( current_prolog_flag(windows, true)
-> DefStandAlone = true
; DefStandAlone = false
),
option(stand_alone(true), Options, DefStandAlone),
!,
current_prolog_flag(executable, Executable),
'$rc_append_file'(RC, '$header', '$rc', none, Executable).
make_header(RC, SaveClass, _Options) :-
current_prolog_flag(unix, true),
!,
current_prolog_flag(executable, Executable),
'$rc_open'(RC, '$header', '$rc', write, Fd),
format(Fd, '#!/bin/sh~n', []),
format(Fd, '# SWI-Prolog saved state~n', []),
( SaveClass == runtime
-> ArgSep = ' -- '
; ArgSep = ' '
),
format(Fd, 'exec ${SWIPL-~w} -x "$0"~w"$@"~n~n', [Executable, ArgSep]),
close(Fd).
make_header(_, _, _).
/*******************************
* OPTIONS *
*******************************/
min_stack(local, 32).
min_stack(global, 16).
min_stack(trail, 16).
convert_option(Stack, Val, NewVal, "~w") :- % stack-sizes are in K-bytes
min_stack(Stack, Min),
!,
( Val == 0
-> NewVal = Val
; NewVal is max(Min, Val*1024)
).
convert_option(toplevel, Callable, Callable, "~q") :- !.
convert_option(_, Value, Value, "~w").
doption(Name) :- min_stack(Name, _).
doption(toplevel).
doption(init_file).
doption(system_init_file).
doption(class).
doption(home).
%! 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.
save_options(RC, SaveClass, Options) :-
'$rc_open'(RC, '$options', '$prolog', write, Fd),
( doption(OptionName),
'$cmd_option_val'(OptionName, OptionVal0),
save_option_value(SaveClass, OptionName, OptionVal0, OptionVal1),
OptTerm =.. [OptionName,OptionVal2],
( option(OptTerm, Options)
-> convert_option(OptionName, OptionVal2, OptionVal, FmtVal)
; OptionVal = OptionVal1,
FmtVal = "~w"
),
atomics_to_string(["~w=", FmtVal, "~n"], Fmt),
format(Fd, Fmt, [OptionName, OptionVal]),
fail
; true
),
save_init_goals(Fd, Options),
close(Fd).
%! save_option_value(+SaveClass, +OptionName, +OptionValue, -FinalValue)
save_option_value(Class, class, _, Class) :- !.
save_option_value(runtime, home, _, _) :- !, fail.
save_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.
save_init_goals(Out, Options) :-
option(goal(Goal), Options),
!,
format(Out, 'goal=~q~n', [Goal]).
save_init_goals(Out, _) :-
'$cmd_option_val'(goals, Goals),
forall(member(Goal, Goals),
format(Out, 'goal=~w~n', [Goal])).
/*******************************
* RESOURCES *
*******************************/
save_resources(_RC, development) :- !.
save_resources(RC, _SaveClass) :-
feedback('~nRESOURCES~n~n', []),
copy_resources(RC),
( current_predicate(_, M:resource(_,_,_)),
forall(M:resource(Name, Class, FileSpec),
( mkrcname(M, Name, RcName),
save_resource(RC, RcName, Class, FileSpec)
)),
fail
; true
).
mkrcname(user, Name, Name) :- !.
mkrcname(M, Name, RcName) :-
atomic_list_concat([M, :, Name], RcName).
save_resource(RC, Name, Class, FileSpec) :-
absolute_file_name(FileSpec,
[ access(read),
file_errors(fail)
], File),
!,
feedback('~t~8|~w~t~32|~w~t~48|~w~n',
[Name, Class, File]),
'$rc_append_file'(RC, Name, Class, none, File).
save_resource(RC, Name, Class, _) :-
'$rc_handle'(SystemRC),
copy_resource(SystemRC, RC, Name, Class),
!.
save_resource(_, Name, Class, FileSpec) :-
print_message(warning,
error(existence_error(resource,
resource(Name, Class, FileSpec)),
_)).
copy_resources(ToRC) :-
'$rc_handle'(FromRC),
'$rc_members'(FromRC, List),
( member(rc(Name, Class), List),
\+ user:resource(Name, Class, _),
\+ reserved_resource(Name, Class),
copy_resource(FromRC, ToRC, Name, Class),
fail
; true
).
reserved_resource('$header', '$rc').
reserved_resource('$state', '$prolog').
reserved_resource('$options', '$prolog').
copy_resource(FromRC, ToRC, Name, Class) :-
setup_call_cleanup(
'$rc_open'(FromRC, Name, Class, read, FdIn),
setup_call_cleanup(
'$rc_open'(ToRC, Name, Class, write, FdOut),
( feedback('~t~8|~w~t~24|~w~t~40|~w~n',
[Name, Class, '<Copied from running state>']),
copy_stream_data(FdIn, FdOut)
),
close(FdOut)),
close(FdIn)).
/*******************************
* MODULES *
*******************************/
save_modules(SaveClass) :-
forall(special_module(X),
save_module(X, SaveClass)),
forall((current_module(X), \+ special_module(X)),
save_module(X, SaveClass)).
special_module(system).
special_module(user).
define_predicate(Head) :-
'$define_predicate'(Head),
!. % autoloader
define_predicate(Head) :-
strip_module(Head, _, Term),
functor(Term, Name, Arity),
throw(error(existence_error(procedure, Name/Arity), _)).
/*******************************
* AUTOLOAD *
*******************************/
define_init_goal(Options) :-
option(goal(Goal), Options),
!,
define_predicate(Goal).
define_init_goal(_).
define_toplevel_goal(Options) :-
option(toplevel(Goal), Options),
!,
define_predicate(Goal).
define_toplevel_goal(_).
save_autoload(Options) :-
define_init_goal(Options),
define_toplevel_goal(Options),
option(autoload(true), Options, true),
!,
autoload(Options).
save_autoload(_).
/*******************************
* MODULES *
*******************************/
%! save_module(+Module, +SaveClass)
%
% Saves a module
save_module(M, SaveClass) :-
'$qlf_start_module'(M),
feedback('~n~nMODULE ~w~n', [M]),
save_unknown(M),
( P = (M:_H),
current_predicate(_, P),
\+ predicate_property(P, imported_from(_)),
save_predicate(P, SaveClass),
fail
; '$qlf_end_part',
feedback('~n', [])
).
save_predicate(P, _SaveClass) :-
predicate_property(P, foreign),
!,
P = (M:H),
functor(H, Name, Arity),
feedback('~npre-defining foreign ~w/~d ', [Name, Arity]),
'$add_directive_wic'('$predefine_foreign'(M:Name/Arity)).
save_predicate(P, SaveClass) :-
P = (M:H),
functor(H, F, A),
feedback('~nsaving ~w/~d ', [F, A]),
( H = resource(_,_,_),
SaveClass \== development
-> save_attribute(P, (dynamic)),
( M == user
-> save_attribute(P, (multifile))
),
feedback('(Skipped clauses)', []),
fail
; true
),
( no_save(P)
-> true
; save_attributes(P),
\+ predicate_property(P, (volatile)),
( nth_clause(P, _, Ref),
feedback('.', []),
'$qlf_assert_clause'(Ref, SaveClass),
fail
; true
)
).
no_save(P) :-
predicate_property(P, volatile),
\+ predicate_property(P, dynamic),
\+ predicate_property(P, multifile).
pred_attrib(meta_predicate(Term), Head, meta_predicate(M:Term)) :-
!,
strip_module(Head, M, _).
pred_attrib(Attrib, Head,
'$set_predicate_attribute'(M:Name/Arity, AttName, Val)) :-
attrib_name(Attrib, AttName, Val),
strip_module(Head, M, Term),
functor(Term, Name, Arity).
attrib_name(dynamic, dynamic, true).
attrib_name(volatile, volatile, true).
attrib_name(thread_local, thread_local, true).
attrib_name(multifile, multifile, true).
attrib_name(public, public, true).
attrib_name(transparent, transparent, true).
attrib_name(discontiguous, discontiguous, true).
attrib_name(notrace, trace, false).
attrib_name(show_childs, hide_childs, false).
attrib_name(built_in, system, true).
attrib_name(nodebug, hide_childs, true).
attrib_name(quasi_quotation_syntax, quasi_quotation_syntax, true).
attrib_name(iso, iso, true).
save_attribute(P, Attribute) :-
pred_attrib(Attribute, P, D),
( Attribute == built_in % no need if there are clauses
-> ( predicate_property(P, number_of_clauses(0))
-> true
; predicate_property(P, volatile)
)
; Attribute == 'dynamic' % no need if predicate is thread_local
-> \+ predicate_property(P, thread_local)
; true
),
'$add_directive_wic'(D),
feedback('(~w) ', [Attribute]).
save_attributes(P) :-
( predicate_property(P, Attribute),
save_attribute(P, Attribute),
fail
; true
).
% Save status of the unknown flag
save_unknown(M) :-
current_prolog_flag(M:unknown, Unknown),
( Unknown == error
-> true
; '$add_directive_wic'(set_prolog_flag(M:unknown, Unknown))
).
/*******************************
* RECORDS *
*******************************/
save_records :-
feedback('~nRECORDS~n', []),
( current_key(X),
X \== '$topvar', % do not safe toplevel variables
feedback('~n~t~8|~w ', [X, V]),
recorded(X, V, _),
feedback('.', []),
'$add_directive_wic'(recordz(X, V, _)),
fail
; true
).
/*******************************
* FLAGS *
*******************************/
save_flags :-
feedback('~nFLAGS~n~n', []),
( current_flag(X),
flag(X, V, V),
feedback('~t~8|~w = ~w~n', [X, V]),
'$add_directive_wic'(set_flag(X, V)),
fail
; true
).
save_prompt :-
feedback('~nPROMPT~n~n', []),
prompt(Prompt, Prompt),
'$add_directive_wic'(prompt(_, Prompt)).
/*******************************
* IMPORTS *
*******************************/
%! 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.
save_imports :-
feedback('~nIMPORTS~n~n', []),
( predicate_property(M:H, imported_from(I)),
\+ default_import(M, H, I),
functor(H, F, A),
feedback('~t~8|~w:~w/~d <-- ~w~n', [M, F, A, I]),
'$add_directive_wic'(qsave:restore_import(M, I, F/A)),
fail
; true
).
default_import(To, Head, From) :-
'$get_predicate_attribute'(To:Head, (dynamic), 1),
predicate_property(From:Head, exported),
!,
fail.
default_import(Into, _, From) :-
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.
restore_import(To, user, PI) :-
!,
export(user:PI),
To:import(user:PI).
restore_import(To, From, PI) :-
To:import(From:PI).
/*******************************
* PROLOG FLAGS *
*******************************/
save_prolog_flags :-
feedback('~nPROLOG FLAGS~n~n', []),
'$current_prolog_flag'(Flag, Value, _Scope, write, Type),
\+ no_save_flag(Flag),
feedback('~t~8|~w: ~w (type ~q)~n', [Flag, Value, Type]),
'$add_directive_wic'(qsave:restore_prolog_flag(Flag, Value, Type)),
fail.
save_prolog_flags.
no_save_flag(argv).
no_save_flag(os_argv).
no_save_flag(access_level).
no_save_flag(tty_control).
no_save_flag(readline).
no_save_flag(associated_file).
no_save_flag(cpu_count).
no_save_flag(hwnd). % should be read-only, but comes
% from user-code
%! restore_prolog_flag(+Name, +Value, +Type)
%
% Deal with possibly protected flags (debug_on_error and
% report_error are protected flags for the runtime kernel).
restore_prolog_flag(Flag, Value, _Type) :-
current_prolog_flag(Flag, Value),
!.
restore_prolog_flag(Flag, Value, _Type) :-
current_prolog_flag(Flag, _),
!,
catch(set_prolog_flag(Flag, Value), _, true).
restore_prolog_flag(Flag, Value, Type) :-
create_prolog_flag(Flag, Value, [type(Type)]).
/*******************************
* OPERATORS *
*******************************/
%! save_operators(+Options) is det.
%
% Save operators for all modules. Operators for =system= are
% not saved because these are read-only anyway.
save_operators(Options) :-
!,
option(op(save), Options, save),
feedback('~nOPERATORS~n', []),
forall(current_module(M), save_module_operators(M)),
feedback('~n', []).
save_operators(_).
save_module_operators(system) :- !.
save_module_operators(M) :-
forall('$local_op'(P,T,M:N),
( feedback('~n~t~8|~w ', [op(P,T,M:N)]),
'$add_directive_wic'(op(P,T,M:N))
)).
/*******************************
* FORMAT PREDICATES *
*******************************/
save_format_predicates :-
feedback('~nFORMAT PREDICATES~n', []),
current_format_predicate(Code, Head),
qualify_head(Head, QHead),
D = format_predicate(Code, QHead),
feedback('~n~t~8|~w ', [D]),
'$add_directive_wic'(D),
fail.
save_format_predicates.
qualify_head(T, T) :-
functor(T, :, 2),
!.
qualify_head(T, user:T).
/*******************************
* FOREIGN LIBRARIES *
*******************************/
%! save_foreign_libraries(+Archive, +Options) is det.
%
% Save current foreign libraries into the archive.
save_foreign_libraries(RC, Options) :-
option(foreign(save), Options),
!,
feedback('~nFOREIGN LIBRARIES~n', []),
forall(current_foreign_library(FileSpec, _Predicates),
( find_foreign_library(FileSpec, File),
term_to_atom(FileSpec, Name),
'$rc_append_file'(RC, Name, shared, none, File)
)).
save_foreign_libraries(_, _).
%! find_foreign_library(+FileSpec, -File) is det.
%
% Find the shared object specified by FileSpec. If posible, the
% shared object is stripped to reduce its size. This is achieved
% by calling strip -o <tmp> <shared-object>. Note that the file is
% a Prolog tmp file and will be deleted on halt.
%
% @bug Should perform OS search on failure
find_foreign_library(FileSpec, SharedObject) :-
absolute_file_name(FileSpec,
[ file_type(executable),
access(read),
file_errors(fail)
], File),
!,
( absolute_file_name(path(strip), Strip,
[ access(execute),
file_errors(fail)
]),
tmp_file(shared, Stripped),
format(atom(Cmd), '"~w" -o "~w" "~w"',
[ Strip, Stripped, File ]),
shell(Cmd)
-> SharedObject = Stripped
; SharedObject = File
).
/*******************************
* UTIL *
*******************************/
open_map(Options) :-
option(map(Map), Options),
!,
open(Map, write, Fd),
asserta(verbose(Fd)).
open_map(_) :-
retractall(verbose(_)).
close_map :-
retract(verbose(Fd)),
close(Fd),
!.
close_map.
feedback(Fmt, Args) :-
verbose(Fd),
!,
format(Fd, Fmt, Args).
feedback(_, _).
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Option checking and exception generation. This should be in a library!
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
option_type(Name, integer) :- min_stack(Name, _MinValue).
option_type(class, oneof([runtime,kernel,development])).
option_type(autoload, boolean).
option_type(map, atom).
option_type(op, oneof([save, standard])).
option_type(stand_alone, boolean).
option_type(foreign, oneof([save, no_save])).
option_type(goal, callable).
option_type(toplevel, callable).
option_type(init_file, atom).
option_type(emulator, ground).
check_options([]) :- !.
check_options([Var|_]) :-
var(Var),
!,
throw(error(domain_error(save_options, Var), _)).
check_options([Name=Value|T]) :-
!,
( option_type(Name, Type)
-> ( must_be(Type, Value)
-> check_options(T)
; throw(error(domain_error(Type, Value), _))
)
; throw(error(domain_error(save_option, Name), _))
).
check_options([Term|T]) :-
Term =.. [Name,Arg],
!,
check_options([Name=Arg|T]).
check_options([Var|_]) :-
throw(error(domain_error(save_options, Var), _)).
check_options(Opt) :-
throw(error(domain_error(list, Opt), _)).
/*******************************
* MESSAGES *
*******************************/
:- multifile prolog:message/3.
prolog:message(no_resource(Name, Class, File)) -->
[ 'Could not find resource ~w/~w on ~w or system resources'-
[Name, Class, File] ].