swi-prolog-nox 7.2.3+dfsg-6 / usr / lib / swi-prolog / library / qsave.pl

/*  Part of SWI-Prolog

    Author:        Jan Wielemaker
    E-mail:        J.Wielemaker@vu.nl
    WWW:           http://www.swi-prolog.org
    Copyright (C): 1985-2013, University of Amsterdam
			      VU University Amsterdam

    This program is free software; you can redistribute it and/or
    modify it under the terms of the GNU General Public License
    as published by the Free Software Foundation; either version 2
    of the License, or (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU Lesser General Public
    License along with this library; if not, write to the Free Software
    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA

    As a special exception, if you link this library with other files,
    compiled with a Free Software compiler, to produce an executable, this
    library does not by itself cause the resulting executable to be covered
    by the GNU General Public License. This exception does not however
    invalidate any other reasons why the executable file might be covered by
    the GNU General Public License.
*/

:- 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_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) :-	% stack-sizes are in K-bytes
	min_stack(Stack, Min), !,
	(   Val == 0
	->  NewVal = Val
	;   NewVal is max(Min, Val*1024)
	).
convert_option(goal, Callable, Atom) :- !,
	term_to_atom(Callable, Atom).
convert_option(toplevel, Callable, Atom) :- !,
	term_to_atom(Callable, Atom).
convert_option(_, Value, Value).

doption(Name) :- min_stack(Name, _).
doption(goal).
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 saves,  so   it  keeps  refering to the
%	development home.
%
%	The script-file (-s script) is 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)
		;   OptionVal = OptionVal1
		),
	        format(Fd, '~w=~w~n', [OptionName, OptionVal]),
	    fail
	;   true
	),
	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).


		 /*******************************
		 *	     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,		    1).
attrib_name(volatile,		    volatile,		    1).
attrib_name(thread_local,	    thread_local,	    1).
attrib_name(multifile,		    multifile,		    1).
attrib_name(public,		    public,		    1).
attrib_name(transparent,	    transparent,	    1).
attrib_name(discontiguous,	    discontiguous,	    1).
attrib_name(notrace,		    trace,		    0).
attrib_name(show_childs,	    hide_childs,	    0).
attrib_name(built_in,		    system,		    1).
attrib_name(nodebug,		    hide_childs,	    1).
attrib_name(quasi_quotation_syntax, quasi_quotation_syntax, 1).
attrib_name(iso,		    iso,		    1).


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)
	    )
	;   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),
	    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'(flag(X, _, V)),
	    fail
	;   true
	).

		 /*******************************
		 *	     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),
			     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] ].