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-2016, University of Amsterdam 7 VU University Amsterdam 8 All rights reserved. 9 10 Redistribution and use in source and binary forms, with or without 11 modification, are permitted provided that the following conditions 12 are met: 13 14 1. Redistributions of source code must retain the above copyright 15 notice, this list of conditions and the following disclaimer. 16 17 2. Redistributions in binary form must reproduce the above copyright 18 notice, this list of conditions and the following disclaimer in 19 the documentation and/or other materials provided with the 20 distribution. 21 22 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 23 "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 24 LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 25 FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 26 COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 27 INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 28 BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 29 LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 30 CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 31 LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 32 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 33 POSSIBILITY OF SUCH DAMAGE. 34*/ 35 36:- module(qsave, 37 [ qsave_program/1, % +File 38 qsave_program/2 % +File, +Options 39 ]). 40:- use_module(library(lists)). 41:- use_module(library(option)). 42:- use_module(library(error)).
54:- meta_predicate 55 qsave_program(, ). 56 57:- predicate_options(qsave_program/2, 2, 58 [ local(integer), 59 global(integer), 60 trail(integer), 61 goal(callable), 62 toplevel(callable), 63 init_file(atom), 64 class(oneof([runtime,kernel,development])), 65 autoload(boolean), 66 map(atom), 67 op(oneof([save,standard])), 68 stand_alone(boolean), 69 foreign(oneof([save,no_save])), 70 emulator(atom) 71 ]). 72 73:- set_prolog_flag(generate_debug_info, false). 74 75:- dynamic verbose/1. 76:- volatile verbose/1. % contains a stream-handle
83qsave_program(File) :- 84 qsave_program(File, []). 85 86qsave_program(FileBase, Options0) :- 87 meta_options(is_meta, Options0, Options), 88 check_options(Options), 89 exe_file(FileBase, File), 90 option(class(SaveClass), Options, runtime), 91 option(init_file(InitFile), Options, DefInit), 92 default_init_file(SaveClass, DefInit), 93 save_autoload(Options), 94 open_map(Options), 95 create_prolog_flag(saved_program, true, []), 96 create_prolog_flag(saved_program_class, SaveClass, []), 97 ( exists_file(File) 98 -> delete_file(File) 99 ; true 100 ), 101 '$rc_open_archive'(File, RC), 102 make_header(RC, SaveClass, Options), 103 save_options(RC, SaveClass, 104 [ init_file(InitFile) 105 | Options 106 ]), 107 save_resources(RC, SaveClass), 108 '$rc_open'(RC, '$state', '$prolog', write, StateFd), 109 '$open_wic'(StateFd), 110 setup_call_cleanup( 111 ( current_prolog_flag(access_level, OldLevel), 112 set_prolog_flag(access_level, system) % generate system modules 113 ), 114 ( save_modules(SaveClass), 115 save_records, 116 save_flags, 117 save_prompt, 118 save_imports, 119 save_prolog_flags, 120 save_operators(Options), 121 save_format_predicates 122 ), 123 set_prolog_flag(access_level, OldLevel)), 124 '$close_wic', 125 close(StateFd), 126 save_foreign_libraries(RC, Options), 127 '$rc_close_archive'(RC), 128 '$mark_executable'(File), 129 close_map. 130 131is_meta(goal). 132is_meta(toplevel). 133 134exe_file(Base, Exe) :- 135 current_prolog_flag(windows, true), 136 file_name_extension(_, '', Base), 137 !, 138 file_name_extension(Base, exe, Exe). 139exe_file(Exe, Exe). 140 141default_init_file(runtime, none) :- !. 142default_init_file(_, InitFile) :- 143 '$cmd_option_val'(init_file, InitFile). 144 145 146 /******************************* 147 * HEADER * 148 *******************************/ 149 150make_header(RC, _, Options) :- 151 option(emulator(OptVal), Options), 152 !, 153 absolute_file_name(OptVal, [access(read)], Emulator), 154 '$rc_append_file'(RC, '$header', '$rc', none, Emulator). 155make_header(RC, _, Options) :- 156 ( current_prolog_flag(windows, true) 157 -> DefStandAlone = true 158 ; DefStandAlone = false 159 ), 160 option(stand_alone(true), Options, DefStandAlone), 161 !, 162 current_prolog_flag(executable, Executable), 163 '$rc_append_file'(RC, '$header', '$rc', none, Executable). 164make_header(RC, SaveClass, _Options) :- 165 current_prolog_flag(unix, true), 166 !, 167 current_prolog_flag(executable, Executable), 168 '$rc_open'(RC, '$header', '$rc', write, Fd), 169 format(Fd, '#!/bin/sh~n', []), 170 format(Fd, '# SWI-Prolog saved state~n', []), 171 ( SaveClass == runtime 172 -> ArgSep = ' -- ' 173 ; ArgSep = ' ' 174 ), 175 format(Fd, 'exec ${SWIPL-~w} -x "$0"~w"$@"~n~n', [Executable, ArgSep]), 176 close(Fd). 177make_header(_, _, _). 178 179 180 /******************************* 181 * OPTIONS * 182 *******************************/ 183 184min_stack(local, 32). 185min_stack(global, 16). 186min_stack(trail, 16). 187 188convert_option(Stack, Val, NewVal, "~w") :- % stack-sizes are in K-bytes 189 min_stack(Stack, Min), 190 !, 191 ( Val == 0 192 -> NewVal = Val 193 ; NewVal is max(Min, Val*1024) 194 ). 195convert_option(toplevel, Callable, Callable, "~q") :- !. 196convert_option(_, Value, Value, "~w"). 197 198doption(Name) :- min_stack(Name, _). 199doption(toplevel). 200doption(init_file). 201doption(system_init_file). 202doption(class). 203doption(home).
The script files (-s script) are not saved at all. I think this is fine to avoid a save-script loading itself.
214save_options(RC, SaveClass, Options) :-
215 '$rc_open'(RC, '$options', '$prolog', write, Fd),
216 ( doption(OptionName),
217 '$cmd_option_val'(OptionName, OptionVal0),
218 save_option_value(SaveClass, OptionName, OptionVal0, OptionVal1),
219 OptTerm =.. [OptionName,OptionVal2],
220 ( option(OptTerm, Options)
221 -> convert_option(OptionName, OptionVal2, OptionVal, FmtVal)
222 ; OptionVal = OptionVal1,
223 FmtVal = "~w"
224 ),
225 atomics_to_string(["~w=", FmtVal, "~n"], Fmt),
226 format(Fd, Fmt, [OptionName, OptionVal]),
227 fail
228 ; true
229 ),
230 save_init_goals(Fd, Options),
231 close(Fd).235save_option_value(Class, class, _, Class) :- !. 236save_option_value(runtime, home, _, _) :- !, fail. 237save_option_value(_, _, Value, Value).
goal(Goal) option, use
that, else save the goals from '$cmd_option_val'/2.244save_init_goals(Out, Options) :- 245 option(goal(Goal), Options), 246 !, 247 format(Out, 'goal=~q~n', [Goal]). 248save_init_goals(Out, _) :- 249 '$cmd_option_val'(goals, Goals), 250 forall(member(Goal, Goals), 251 format(Out, 'goal=~w~n', [Goal])). 252 253 254 /******************************* 255 * RESOURCES * 256 *******************************/ 257 258save_resources(_RC, development) :- !. 259save_resources(RC, _SaveClass) :- 260 feedback('~nRESOURCES~n~n', []), 261 copy_resources(RC), 262 ( current_predicate(_, M:resource(_,_,_)), 263 forall(M:resource(Name, Class, FileSpec), 264 ( mkrcname(M, Name, RcName), 265 save_resource(RC, RcName, Class, FileSpec) 266 )), 267 fail 268 ; true 269 ). 270 271mkrcname(user, Name, Name) :- !. 272mkrcname(M, Name, RcName) :- 273 atomic_list_concat([M, :, Name], RcName). 274 275save_resource(RC, Name, Class, FileSpec) :- 276 absolute_file_name(FileSpec, 277 [ access(read), 278 file_errors(fail) 279 ], File), 280 !, 281 feedback('~t~8|~w~t~32|~w~t~48|~w~n', 282 [Name, Class, File]), 283 '$rc_append_file'(RC, Name, Class, none, File). 284save_resource(RC, Name, Class, _) :- 285 '$rc_handle'(SystemRC), 286 copy_resource(SystemRC, RC, Name, Class), 287 !. 288save_resource(_, Name, Class, FileSpec) :- 289 print_message(warning, 290 error(existence_error(resource, 291 resource(Name, Class, FileSpec)), 292 _)). 293 294copy_resources(ToRC) :- 295 '$rc_handle'(FromRC), 296 '$rc_members'(FromRC, List), 297 ( member(rc(Name, Class), List), 298 \+ user:resource(Name, Class, _), 299 \+ reserved_resource(Name, Class), 300 copy_resource(FromRC, ToRC, Name, Class), 301 fail 302 ; true 303 ). 304 305reserved_resource('$header', '$rc'). 306reserved_resource('$state', '$prolog'). 307reserved_resource('$options', '$prolog'). 308 309copy_resource(FromRC, ToRC, Name, Class) :- 310 setup_call_cleanup( 311 '$rc_open'(FromRC, Name, Class, read, FdIn), 312 setup_call_cleanup( 313 '$rc_open'(ToRC, Name, Class, write, FdOut), 314 ( feedback('~t~8|~w~t~24|~w~t~40|~w~n', 315 [Name, Class, '<Copied from running state>']), 316 copy_stream_data(FdIn, FdOut) 317 ), 318 close(FdOut)), 319 close(FdIn)). 320 321 322 /******************************* 323 * MODULES * 324 *******************************/ 325 326save_modules(SaveClass) :- 327 forall(special_module(X), 328 save_module(X, SaveClass)), 329 forall((current_module(X), \+ special_module(X)), 330 save_module(X, SaveClass)). 331 332special_module(system). 333special_module(user). 334 335define_predicate(Head) :- 336 '$define_predicate'(Head), 337 !. % autoloader 338define_predicate(Head) :- 339 strip_module(Head, _, Term), 340 functor(Term, Name, Arity), 341 throw(error(existence_error(procedure, Name/Arity), _)). 342 343 344 /******************************* 345 * AUTOLOAD * 346 *******************************/ 347 348define_init_goal(Options) :- 349 option(goal(Goal), Options), 350 !, 351 define_predicate(Goal). 352define_init_goal(_). 353 354define_toplevel_goal(Options) :- 355 option(toplevel(Goal), Options), 356 !, 357 define_predicate(Goal). 358define_toplevel_goal(_). 359 360save_autoload(Options) :- 361 define_init_goal(Options), 362 define_toplevel_goal(Options), 363 option(autoload(true), Options, true), 364 !, 365 autoload(Options). 366save_autoload(_). 367 368 369 /******************************* 370 * MODULES * 371 *******************************/
377save_module(M, SaveClass) :- 378 '$qlf_start_module'(M), 379 feedback('~n~nMODULE ~w~n', [M]), 380 save_unknown(M), 381 ( P = (M:_H), 382 current_predicate(_, P), 383 \+ predicate_property(P, imported_from(_)), 384 save_predicate(P, SaveClass), 385 fail 386 ; '$qlf_end_part', 387 feedback('~n', []) 388 ). 389 390save_predicate(P, _SaveClass) :- 391 predicate_property(P, foreign), 392 !, 393 P = (M:H), 394 functor(H, Name, Arity), 395 feedback('~npre-defining foreign ~w/~d ', [Name, Arity]), 396 '$add_directive_wic'('$predefine_foreign'(M:Name/Arity)). 397save_predicate(P, SaveClass) :- 398 P = (M:H), 399 functor(H, F, A), 400 feedback('~nsaving ~w/~d ', [F, A]), 401 ( H = resource(_,_,_), 402 SaveClass \== development 403 -> save_attribute(P, (dynamic)), 404 ( M == user 405 -> save_attribute(P, (multifile)) 406 ), 407 feedback('(Skipped clauses)', []), 408 fail 409 ; true 410 ), 411 ( no_save(P) 412 -> true 413 ; save_attributes(P), 414 \+ predicate_property(P, (volatile)), 415 ( nth_clause(P, _, Ref), 416 feedback('.', []), 417 '$qlf_assert_clause'(Ref, SaveClass), 418 fail 419 ; true 420 ) 421 ). 422 423no_save(P) :- 424 predicate_property(P, volatile), 425 \+ predicate_property(P, dynamic), 426 \+ predicate_property(P, multifile). 427 428pred_attrib(meta_predicate(Term), Head, meta_predicate(M:Term)) :- 429 !, 430 strip_module(Head, M, _). 431pred_attrib(Attrib, Head, 432 '$set_predicate_attribute'(M:Name/Arity, AttName, Val)) :- 433 attrib_name(Attrib, AttName, Val), 434 strip_module(Head, M, Term), 435 functor(Term, Name, Arity). 436 437attrib_name(dynamic, dynamic, true). 438attrib_name(volatile, volatile, true). 439attrib_name(thread_local, thread_local, true). 440attrib_name(multifile, multifile, true). 441attrib_name(public, public, true). 442attrib_name(transparent, transparent, true). 443attrib_name(discontiguous, discontiguous, true). 444attrib_name(notrace, trace, false). 445attrib_name(show_childs, hide_childs, false). 446attrib_name(built_in, system, true). 447attrib_name(nodebug, hide_childs, true). 448attrib_name(quasi_quotation_syntax, quasi_quotation_syntax, true). 449attrib_name(iso, iso, true). 450 451 452save_attribute(P, Attribute) :- 453 pred_attrib(Attribute, P, D), 454 ( Attribute == built_in % no need if there are clauses 455 -> ( predicate_property(P, number_of_clauses(0)) 456 -> true 457 ; predicate_property(P, volatile) 458 ) 459 ; Attribute == 'dynamic' % no need if predicate is thread_local 460 -> \+ predicate_property(P, thread_local) 461 ; true 462 ), 463 '$add_directive_wic'(), 464 feedback('(~w) ', [Attribute]). 465 466save_attributes(P) :- 467 ( predicate_property(P, Attribute), 468 save_attribute(P, Attribute), 469 fail 470 ; true 471 ). 472 473% Save status of the unknown flag 474 475save_unknown(M) :- 476 current_prolog_flag(Munknown, Unknown), 477 ( Unknown == error 478 -> true 479 ; '$add_directive_wic'(set_prolog_flag(Munknown, Unknown)) 480 ). 481 482 /******************************* 483 * RECORDS * 484 *******************************/ 485 486save_records :- 487 feedback('~nRECORDS~n', []), 488 ( current_key(X), 489 X \== '$topvar', % do not safe toplevel variables 490 feedback('~n~t~8|~w ', [X, V]), 491 recorded(X, V, _), 492 feedback('.', []), 493 '$add_directive_wic'(recordz(X, V, _)), 494 fail 495 ; true 496 ). 497 498 499 /******************************* 500 * FLAGS * 501 *******************************/ 502 503save_flags :- 504 feedback('~nFLAGS~n~n', []), 505 ( current_flag(X), 506 flag(X, V, V), 507 feedback('~t~8|~w = ~w~n', [X, V]), 508 '$add_directive_wic'(set_flag(X, V)), 509 fail 510 ; true 511 ). 512 513save_prompt :- 514 feedback('~nPROMPT~n~n', []), 515 prompt(Prompt, Prompt), 516 '$add_directive_wic'(prompt(_, Prompt)). 517 518 519 /******************************* 520 * IMPORTS * 521 *******************************/
531save_imports :- 532 feedback('~nIMPORTS~n~n', []), 533 ( predicate_property(M:H, imported_from(I)), 534 \+ default_import(M, H, I), 535 functor(H, F, A), 536 feedback('~t~8|~w:~w/~d <-- ~w~n', [M, F, A, I]), 537 '$add_directive_wic'(qsave:restore_import(M, I, F/A)), 538 fail 539 ; true 540 ). 541 542default_import(To, Head, From) :- 543 '$get_predicate_attribute'(To:Head, (dynamic), 1), 544 predicate_property(From:Head, exported), 545 !, 546 fail. 547default_import(Into, _, From) :- 548 default_module(Into, From).
user, avoiding a message that the predicate is not
exported.556restore_import(To, user, PI) :- 557 !, 558 export(user:PI), 559 To:import(user:PI). 560restore_import(To, From, PI) :- 561 To:import(From:PI). 562 563 /******************************* 564 * PROLOG FLAGS * 565 *******************************/ 566 567save_prolog_flags :- 568 feedback('~nPROLOG FLAGS~n~n', []), 569 '$current_prolog_flag'(Flag, Value, _Scope, write, Type), 570 \+ no_save_flag(Flag), 571 feedback('~t~8|~w: ~w (type ~q)~n', [Flag, Value, Type]), 572 '$add_directive_wic'(qsave:restore_prolog_flag(Flag, Value, Type)), 573 fail. 574save_prolog_flags. 575 576no_save_flag(argv). 577no_save_flag(os_argv). 578no_save_flag(access_level). 579no_save_flag(tty_control). 580no_save_flag(readline). 581no_save_flag(associated_file). 582no_save_flag(cpu_count). 583no_save_flag(hwnd). % should be read-only, but comes 584 % from user-code
591restore_prolog_flag(Flag, Value, _Type) :- 592 current_prolog_flag(Flag, Value), 593 !. 594restore_prolog_flag(Flag, Value, _Type) :- 595 current_prolog_flag(Flag, _), 596 !, 597 catch(set_prolog_flag(Flag, Value), _, true). 598restore_prolog_flag(Flag, Value, Type) :- 599 create_prolog_flag(Flag, Value, [type(Type)]). 600 601 602 /******************************* 603 * OPERATORS * 604 *******************************/
system are
not saved because these are read-only anyway.611save_operators(Options) :- 612 !, 613 option(op(save), Options, save), 614 feedback('~nOPERATORS~n', []), 615 forall(current_module(M), save_module_operators(M)), 616 feedback('~n', []). 617save_operators(_). 618 619save_module_operators(system) :- !. 620save_module_operators(M) :- 621 forall('$local_op'(P,T,M:N), 622 ( feedback('~n~t~8|~w ', [op(P,T,M:N)]), 623 '$add_directive_wic'(op(P,T,M:N)) 624 )). 625 626 627 /******************************* 628 * FORMAT PREDICATES * 629 *******************************/ 630 631save_format_predicates :- 632 feedback('~nFORMAT PREDICATES~n', []), 633 current_format_predicate(Code, Head), 634 qualify_head(Head, QHead), 635 D = format_predicate(Code, QHead), 636 feedback('~n~t~8|~w ', [D]), 637 '$add_directive_wic'(), 638 fail. 639save_format_predicates. 640 641qualify_head(T, T) :- 642 functor(T, :, 2), 643 !. 644qualify_head(T, user:T). 645 646 647 /******************************* 648 * FOREIGN LIBRARIES * 649 *******************************/
655save_foreign_libraries(RC, Options) :- 656 option(foreign(save), Options), 657 !, 658 feedback('~nFOREIGN LIBRARIES~n', []), 659 forall(current_foreign_library(FileSpec, _Predicates), 660 ( find_foreign_library(FileSpec, File), 661 term_to_atom(FileSpec, Name), 662 '$rc_append_file'(RC, Name, shared, none, File) 663 )). 664save_foreign_libraries(_, _).
675find_foreign_library(FileSpec, SharedObject) :- 676 absolute_file_name(FileSpec, 677 [ file_type(executable), 678 access(read), 679 file_errors(fail) 680 ], File), 681 !, 682 ( absolute_file_name(path(strip), Strip, 683 [ access(execute), 684 file_errors(fail) 685 ]), 686 tmp_file(shared, Stripped), 687 format(atom(Cmd), '"~w" -o "~w" "~w"', 688 [ Strip, Stripped, File ]), 689 shell(Cmd) 690 -> SharedObject = Stripped 691 ; SharedObject = File 692 ). 693 694 695 /******************************* 696 * UTIL * 697 *******************************/ 698 699open_map(Options) :- 700 option(map(Map), Options), 701 !, 702 open(Map, write, Fd), 703 asserta(verbose(Fd)). 704open_map(_) :- 705 retractall(verbose(_)). 706 707close_map :- 708 retract(verbose(Fd)), 709 close(Fd), 710 !. 711close_map. 712 713feedback(Fmt, Args) :- 714 verbose(Fd), 715 !, 716 format(Fd, Fmt, Args). 717feedback(_, _). 718 719 720/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 721Option checking and exception generation. This should be in a library! 722- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ 723 724option_type(Name, integer) :- min_stack(Name, _MinValue). 725option_type(class, oneof([runtime,kernel,development])). 726option_type(autoload, boolean). 727option_type(map, atom). 728option_type(op, oneof([save, standard])). 729option_type(stand_alone, boolean). 730option_type(foreign, oneof([save, no_save])). 731option_type(goal, callable). 732option_type(toplevel, callable). 733option_type(init_file, atom). 734option_type(emulator, ground). 735 736check_options([]) :- !. 737check_options([Var|_]) :- 738 var(Var), 739 !, 740 throw(error(domain_error(save_options, Var), _)). 741check_options([Name=Value|T]) :- 742 !, 743 ( option_type(Name, Type) 744 -> ( must_be(Type, Value) 745 -> check_options(T) 746 ; throw(error(domain_error(Type, Value), _)) 747 ) 748 ; throw(error(domain_error(save_option, Name), _)) 749 ). 750check_options([Term|T]) :- 751 Term =.. [Name,Arg], 752 !, 753 check_options([Name=Arg|T]). 754check_options([Var|_]) :- 755 throw(error(domain_error(save_options, Var), _)). 756check_options(Opt) :- 757 throw(error(domain_error(list, Opt), _)). 758 759 760 /******************************* 761 * MESSAGES * 762 *******************************/ 763 764:- multifile prolog:message/3. 765 766prologmessage(no_resource(Name, Class, File)) --> 767 [ 'Could not find resource ~w/~w on ~w or system resources'- 768 [Name, Class, File] ]
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.
*/