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-2022, University of Amsterdam 7 VU University Amsterdam 8 CWI, Amsterdam 9 SWI-Prolog Solutions b.v. 10 All rights reserved. 11 12 Redistribution and use in source and binary forms, with or without 13 modification, are permitted provided that the following conditions 14 are met: 15 16 1. Redistributions of source code must retain the above copyright 17 notice, this list of conditions and the following disclaimer. 18 19 2. Redistributions in binary form must reproduce the above copyright 20 notice, this list of conditions and the following disclaimer in 21 the documentation and/or other materials provided with the 22 distribution. 23 24 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 25 "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 26 LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 27 FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 28 COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 29 INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 30 BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 31 LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 32 CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 33 LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 34 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 35 POSSIBILITY OF SUCH DAMAGE. 36*/ 37 38:- module(qsave, 39 [ qsave_program/1, % +File 40 qsave_program/2 % +File, +Options 41 ]). 42:- use_module(library(zip)). 43:- use_module(library(lists)). 44:- use_module(library(option)). 45:- use_module(library(error)). 46:- use_module(library(apply)). 47:- autoload(library(shlib), [current_foreign_library/2]). 48:- autoload(library(prolog_autoload), [autoload_all/1]).
60:- meta_predicate 61 qsave_program(, ). 62 63:- multifile error:has_type/2. 64errorhas_type(qsave_foreign_option, Term) :- 65 is_of_type(oneof([save, no_save]), Term), 66 !. 67errorhas_type(qsave_foreign_option, arch(Archs)) :- 68 is_of_type(list(atom), Archs), 69 !. 70 71save_option(stack_limit, integer, 72 "Stack limit (bytes)"). 73save_option(goal, callable, 74 "Main initialization goal"). 75save_option(toplevel, callable, 76 "Toplevel goal"). 77save_option(init_file, atom, 78 "Application init file"). 79save_option(pce, boolean, 80 "Do (not) include the xpce graphics subsystem"). 81save_option(packs, boolean, 82 "Do (not) attach packs"). 83save_option(class, oneof([runtime,development,prolog]), 84 "Development state"). 85save_option(op, oneof([save,standard]), 86 "Save operators"). 87save_option(autoload, boolean, 88 "Resolve autoloadable predicates"). 89save_option(map, atom, 90 "File to report content of the state"). 91save_option(stand_alone, boolean, 92 "Add emulator at start"). 93save_option(traditional, boolean, 94 "Use traditional mode"). 95save_option(emulator, ground, 96 "Emulator to use"). 97save_option(foreign, qsave_foreign_option, 98 "Include foreign code in state"). 99save_option(obfuscate, boolean, 100 "Obfuscate identifiers"). 101save_option(verbose, boolean, 102 "Be more verbose about the state creation"). 103save_option(undefined, oneof([ignore,error]), 104 "How to handle undefined predicates"). 105save_option(on_error, oneof([print,halt,status]), 106 "How to handle errors"). 107save_option(on_warning, oneof([print,halt,status]), 108 "How to handle warnings"). 109 110term_expansion(save_pred_options, 111 (:- predicate_options(qsave_program/2, 2, Options))) :- 112 findall(O, 113 ( save_option(Name, Type, _), 114 O =.. [Name,Type] 115 ), 116 Options). 117 118save_pred_options. 119 120:- set_prolog_flag(generate_debug_info, false). 121 122:- dynamic 123 verbose/1, 124 saved_resource_file/1. 125:- volatile 126 verbose/1, % contains a stream-handle 127 saved_resource_file/1.
134qsave_program(File) :- 135 qsave_program(File, []). 136 137qsave_program(FileBase, Options0) :- 138 meta_options(is_meta, Options0, Options1), 139 check_options(Options1), 140 exe_file(FileBase, File, Options1), 141 option(class(SaveClass), Options1, runtime), 142 qsave_init_file_option(SaveClass, Options1, Options), 143 prepare_entry_points(Options), 144 save_autoload(Options), 145 setup_call_cleanup( 146 open_map(Options), 147 ( prepare_state(Options), 148 create_prolog_flag(saved_program, true, []), 149 create_prolog_flag(saved_program_class, SaveClass, []), 150 delete_if_exists(File), % truncate will crash a Prolog 151 % running on this state 152 setup_call_catcher_cleanup( 153 open(File, write, StateOut, [type(binary)]), 154 write_state(StateOut, SaveClass, Options), 155 Reason, 156 finalize_state(Reason, StateOut, File)) 157 ), 158 close_map), 159 cleanup, 160 !. 161 162write_state(StateOut, SaveClass, Options) :- 163 make_header(StateOut, SaveClass, Options), 164 setup_call_cleanup( 165 zip_open_stream(StateOut, RC, []), 166 write_zip_state(RC, SaveClass, Options), 167 zip_close(RC, [comment('SWI-Prolog saved state')])), 168 flush_output(StateOut). 169 170write_zip_state(RC, SaveClass, Options) :- 171 save_options(RC, SaveClass, Options), 172 save_resources(RC, SaveClass), 173 lock_files(SaveClass), 174 save_program(RC, SaveClass, Options), 175 save_foreign_libraries(RC, Options). 176 177finalize_state(exit, StateOut, File) :- 178 close(StateOut), 179 '$mark_executable'(File). 180finalize_state(!, StateOut, File) :- 181 print_message(warning, qsave(nondet)), 182 finalize_state(exit, StateOut, File). 183finalize_state(_, StateOut, File) :- 184 close(StateOut, [force(true)]), 185 catch(delete_file(File), 186 Error, 187 print_message(error, Error)). 188 189cleanup :- 190 retractall(saved_resource_file(_)). 191 192is_meta(goal). 193is_meta(toplevel). 194 195exe_file(Base, Exe, Options) :- 196 current_prolog_flag(windows, true), 197 option(stand_alone(true), Options, true), 198 file_name_extension(_, '', Base), 199 !, 200 file_name_extension(Base, exe, Exe). 201exe_file(Exe, Exe, _). 202 203delete_if_exists(File) :- 204 ( exists_file(File) 205 -> delete_file(File) 206 ; true 207 ). 208 209qsave_init_file_option(runtime, Options1, Options) :- 210 \+ option(init_file(_), Options1), 211 !, 212 Options = [init_file(none)|Options1]. 213qsave_init_file_option(_, Options, Options). 214 215 216 /******************************* 217 * HEADER * 218 *******************************/
222make_header(Out, _, Options) :- 223 stand_alone(Options), 224 !, 225 emulator(Emulator, Options), 226 setup_call_cleanup( 227 open(Emulator, read, In, [type(binary)]), 228 copy_stream_data(In, Out), 229 close(In)). 230make_header(Out, SaveClass, Options) :- 231 current_prolog_flag(unix, true), 232 !, 233 emulator(Emulator, Options), 234 current_prolog_flag(posix_shell, Shell), 235 format(Out, '#!~w~n', [Shell]), 236 format(Out, '# SWI-Prolog saved state~n', []), 237 ( SaveClass == runtime 238 -> ArgSep = ' -- ' 239 ; ArgSep = ' ' 240 ), 241 format(Out, 'exec ${SWIPL:-~w} -x "$0"~w"$@"~n~n', [Emulator, ArgSep]). 242make_header(_, _, _). 243 244stand_alone(Options) :- 245 ( current_prolog_flag(windows, true) 246 -> DefStandAlone = true 247 ; DefStandAlone = false 248 ), 249 option(stand_alone(true), Options, DefStandAlone). 250 251emulator(Emulator, Options) :- 252 ( option(emulator(OptVal), Options) 253 -> absolute_file_name(OptVal, [access(read)], Emulator) 254 ; current_prolog_flag(executable, Emulator) 255 ). 256 257 258 259 /******************************* 260 * OPTIONS * 261 *******************************/ 262 263min_stack(stack_limit, 100_000). 264 265convert_option(Stack, Val, NewVal, '~w') :- % stack-sizes are in K-bytes 266 min_stack(Stack, Min), 267 !, 268 ( Val == 0 269 -> NewVal = Val 270 ; NewVal is max(Min, Val) 271 ). 272convert_option(toplevel, Callable, Callable, '~q') :- !. 273convert_option(_, Value, Value, '~w'). 274 275doption(Name) :- min_stack(Name, _). 276doption(init_file). 277doption(system_init_file). 278doption(class). 279doption(home). 280doption(nosignals).
The script files (-s script) are not saved at all. I think this is fine to avoid a save-script loading itself.
291save_options(RC, SaveClass, Options) :-
292 zipper_open_new_file_in_zip(RC, '$prolog/options.txt', Fd, []),
293 ( doption(OptionName),
294 ( OptTerm =.. [OptionName,OptionVal2],
295 option(OptTerm, Options)
296 -> convert_option(OptionName, OptionVal2, OptionVal, FmtVal)
297 ; '$cmd_option_val'(OptionName, OptionVal0),
298 save_option_value(SaveClass, OptionName, OptionVal0, OptionVal1),
299 OptionVal = OptionVal1,
300 FmtVal = '~w'
301 ),
302 atomics_to_string(['~w=', FmtVal, '~n'], Fmt),
303 format(Fd, Fmt, [OptionName, OptionVal]),
304 fail
305 ; true
306 ),
307 save_init_goals(Fd, Options),
308 close(Fd).312save_option_value(Class, class, _, Class) :- !. 313save_option_value(runtime, home, _, _) :- !, fail. 314save_option_value(_, _, Value, Value).
goal(Goal) option, use
that, else save the goals from '$cmd_option_val'/2.321save_init_goals(Out, Options) :- 322 option(goal(Goal), Options), 323 !, 324 format(Out, 'goal=~q~n', [Goal]), 325 save_toplevel_goal(Out, halt, Options). 326save_init_goals(Out, Options) :- 327 '$cmd_option_val'(goals, Goals), 328 forall(member(Goal, Goals), 329 format(Out, 'goal=~w~n', [Goal])), 330 ( Goals == [] 331 -> DefToplevel = default 332 ; DefToplevel = halt 333 ), 334 save_toplevel_goal(Out, DefToplevel, Options). 335 336save_toplevel_goal(Out, _Default, Options) :- 337 option(toplevel(Goal), Options), 338 !, 339 unqualify_reserved_goal(Goal, Goal1), 340 format(Out, 'toplevel=~q~n', [Goal1]). 341save_toplevel_goal(Out, _Default, _Options) :- 342 '$cmd_option_val'(toplevel, Toplevel), 343 Toplevel \== default, 344 !, 345 format(Out, 'toplevel=~w~n', [Toplevel]). 346save_toplevel_goal(Out, Default, _Options) :- 347 format(Out, 'toplevel=~q~n', [Default]). 348 349unqualify_reserved_goal(_:prolog, prolog) :- !. 350unqualify_reserved_goal(_:default, default) :- !. 351unqualify_reserved_goal(Goal, Goal). 352 353 354 /******************************* 355 * RESOURCES * 356 *******************************/ 357 358save_resources(_RC, development) :- !. 359save_resources(RC, _SaveClass) :- 360 feedback('~nRESOURCES~n~n', []), 361 copy_resources(RC), 362 forall(declared_resource(Name, FileSpec, Options), 363 save_resource(RC, Name, FileSpec, Options)). 364 365declared_resource(RcName, FileSpec, []) :- 366 current_predicate(_, M:resource(_,_)), 367 M:resource(Name, FileSpec), 368 mkrcname(M, Name, RcName). 369declared_resource(RcName, FileSpec, Options) :- 370 current_predicate(_, M:resource(_,_,_)), 371 M:resource(Name, A2, A3), 372 ( is_list(A3) 373 -> FileSpec = A2, 374 Options = A3 375 ; FileSpec = A3 376 ), 377 mkrcname(M, Name, RcName).
383mkrcname(user, Name0, Name) :- 384 !, 385 path_segments_to_atom(Name0, Name). 386mkrcname(M, Name0, RcName) :- 387 path_segments_to_atom(Name0, Name), 388 atomic_list_concat([M, :, Name], RcName). 389 390path_segments_to_atom(Name0, Name) :- 391 phrase(segments_to_atom(Name0), Atoms), 392 atomic_list_concat(Atoms, /, Name). 393 394segments_to_atom(Var) --> 395 { var(Var), !, 396 instantiation_error(Var) 397 }. 398segments_to_atom(A/B) --> 399 !, 400 segments_to_atom(A), 401 segments_to_atom(B). 402segments_to_atom(A) --> 403 [A].
409save_resource(RC, Name, FileSpec, _Options) :- 410 absolute_file_name(FileSpec, 411 [ access(read), 412 file_errors(fail) 413 ], File), 414 !, 415 feedback('~t~8|~w~t~32|~w~n', 416 [Name, File]), 417 zipper_append_file(RC, Name, File, []). 418save_resource(RC, Name, FileSpec, Options) :- 419 findall(Dir, 420 absolute_file_name(FileSpec, Dir, 421 [ access(read), 422 file_type(directory), 423 file_errors(fail), 424 solutions(all) 425 ]), 426 Dirs), 427 Dirs \== [], 428 !, 429 forall(member(Dir, Dirs), 430 ( feedback('~t~8|~w~t~32|~w~n', 431 [Name, Dir]), 432 zipper_append_directory(RC, Name, Dir, Options))). 433save_resource(RC, Name, _, _Options) :- 434 '$rc_handle'(SystemRC), 435 copy_resource(SystemRC, RC, Name), 436 !. 437save_resource(_, Name, FileSpec, _Options) :- 438 print_message(warning, 439 error(existence_error(resource, 440 resource(Name, FileSpec)), 441 _)). 442 443copy_resources(ToRC) :- 444 '$rc_handle'(FromRC), 445 zipper_members(FromRC, List), 446 ( member(Name, List), 447 \+ declared_resource(Name, _, _), 448 \+ reserved_resource(Name), 449 copy_resource(FromRC, ToRC, Name), 450 fail 451 ; true 452 ). 453 454reserved_resource('$prolog/state.qlf'). 455reserved_resource('$prolog/options.txt'). 456 457copy_resource(FromRC, ToRC, Name) :- 458 ( zipper_goto(FromRC, file(Name)) 459 -> true 460 ; existence_error(resource, Name) 461 ), 462 zipper_file_info(FromRC, _Name, Attrs), 463 get_dict(time, Attrs, Time), 464 setup_call_cleanup( 465 zipper_open_current(FromRC, FdIn, 466 [ type(binary), 467 time(Time) 468 ]), 469 setup_call_cleanup( 470 zipper_open_new_file_in_zip(ToRC, Name, FdOut, []), 471 ( feedback('~t~8|~w~t~24|~w~n', 472 [Name, '<Copied from running state>']), 473 copy_stream_data(FdIn, FdOut) 474 ), 475 close(FdOut)), 476 close(FdIn)). 477 478 479 /******************************* 480 * OBFUSCATE * 481 *******************************/
487:- multifile prolog:obfuscate_identifiers/1. 488 489create_mapping(Options) :- 490 option(obfuscate(true), Options), 491 !, 492 ( predicate_property(prolog:obfuscate_identifiers(_), number_of_clauses(N)), 493 N > 0 494 -> true 495 ; use_module(library(obfuscate)) 496 ), 497 ( catch(prolog:obfuscate_identifiers(Options), E, 498 print_message(error, E)) 499 -> true 500 ; print_message(warning, failed(obfuscate_identifiers)) 501 ). 502create_mapping(_).
runtime, lock all files such that when running the
program the system stops checking existence and modification time on
the filesystem.
512lock_files(runtime) :- 513 !, 514 '$set_source_files'(system). % implies from_state 515lock_files(_) :- 516 '$set_source_files'(from_state).
522save_program(RC, SaveClass, Options) :- 523 setup_call_cleanup( 524 ( zipper_open_new_file_in_zip(RC, '$prolog/state.qlf', StateFd, 525 [ zip64(true) 526 ]), 527 current_prolog_flag(access_level, OldLevel), 528 set_prolog_flag(access_level, system), % generate system modules 529 '$open_wic'(StateFd, Options) 530 ), 531 ( create_mapping(Options), 532 save_modules(SaveClass), 533 save_records, 534 save_flags, 535 save_prompt, 536 save_imports, 537 save_prolog_flags(Options), 538 save_operators(Options), 539 save_format_predicates 540 ), 541 ( '$close_wic', 542 set_prolog_flag(access_level, OldLevel), 543 close(StateFd) 544 )). 545 546 547 /******************************* 548 * MODULES * 549 *******************************/ 550 551save_modules(SaveClass) :- 552 forall(special_module(X), 553 save_module(X, SaveClass)), 554 forall((current_module(X), \+ special_module(X)), 555 save_module(X, SaveClass)). 556 557special_module(system). 558special_module(user).
567prepare_entry_points(Options) :- 568 define_init_goal(Options), 569 define_toplevel_goal(Options). 570 571define_init_goal(Options) :- 572 option(goal(Goal), Options), 573 !, 574 entry_point(Goal). 575define_init_goal(_). 576 577define_toplevel_goal(Options) :- 578 option(toplevel(Goal), Options), 579 !, 580 entry_point(Goal). 581define_toplevel_goal(_). 582 583entry_point(Goal) :- 584 define_predicate(Goal), 585 ( \+ predicate_property(Goal, built_in), 586 \+ predicate_property(Goal, imported_from(_)) 587 -> goal_pi(Goal, PI), 588 public(PI) 589 ; true 590 ). 591 592define_predicate(Head) :- 593 '$define_predicate'(Head), 594 !. % autoloader 595define_predicate(Head) :- 596 strip_module(Head, _, Term), 597 functor(Term, Name, Arity), 598 throw(error(existence_error(procedure, Name/Arity), _)). 599 600goal_pi(M:G, QPI) :- 601 !, 602 strip_module(M:G, Module, Goal), 603 functor(Goal, Name, Arity), 604 QPI = Module:Name/Arity. 605goal_pi(Goal, Name/Arity) :- 606 functor(Goal, Name, Arity).
prepare_state registered
initialization hooks.613prepare_state(_) :- 614 forall('$init_goal'(when(prepare_state), Goal, Ctx), 615 run_initialize(Goal, Ctx)). 616 617run_initialize(Goal, Ctx) :- 618 ( catch(Goal, E, true), 619 ( var(E) 620 -> true 621 ; throw(error(initialization_error(E, Goal, Ctx), _)) 622 ) 623 ; throw(error(initialization_error(failed, Goal, Ctx), _)) 624 ). 625 626 627 /******************************* 628 * AUTOLOAD * 629 *******************************/
638save_autoload(Options) :- 639 option(autoload(true), Options, true), 640 !, 641 setup_call_cleanup( 642 current_prolog_flag(autoload, Old), 643 autoload_all(Options), 644 set_prolog_flag(autoload, Old)). 645save_autoload(_). 646 647 648 /******************************* 649 * MODULES * 650 *******************************/
656save_module(M, SaveClass) :- 657 '$qlf_start_module'(M), 658 feedback('~n~nMODULE ~w~n', [M]), 659 save_unknown(M), 660 ( P = (M:_H), 661 current_predicate(_, P), 662 \+ predicate_property(P, imported_from(_)), 663 save_predicate(P, SaveClass), 664 fail 665 ; '$qlf_end_part', 666 feedback('~n', []) 667 ). 668 669save_predicate(P, _SaveClass) :- 670 predicate_property(P, foreign), 671 !, 672 P = (M:H), 673 functor(H, Name, Arity), 674 feedback('~npre-defining foreign ~w/~d ', [Name, Arity]), 675 '$add_directive_wic'('$predefine_foreign'(M:Name/Arity)). 676save_predicate(P, SaveClass) :- 677 P = (M:H), 678 functor(H, F, A), 679 feedback('~nsaving ~w/~d ', [F, A]), 680 ( ( H = resource(_,_) 681 ; H = resource(_,_,_) 682 ) 683 -> ( SaveClass == development 684 -> true 685 ; save_attribute(P, (dynamic)), 686 ( M == user 687 -> save_attribute(P, (multifile)) 688 ), 689 feedback('(Skipped clauses)', []), 690 fail 691 ) 692 ; true 693 ), 694 ( no_save(P) 695 -> true 696 ; save_attributes(P), 697 \+ predicate_property(P, (volatile)), 698 ( nth_clause(P, _, Ref), 699 feedback('.', []), 700 '$qlf_assert_clause'(Ref, SaveClass), 701 fail 702 ; true 703 ) 704 ). 705 706no_save(P) :- 707 predicate_property(P, volatile), 708 \+ predicate_property(P, dynamic), 709 \+ predicate_property(P, multifile). 710 711pred_attrib(meta_predicate(Term), Head, meta_predicate(M:Term)) :- 712 !, 713 strip_module(Head, M, _). 714pred_attrib(Attrib, Head, 715 '$set_predicate_attribute'(M:Name/Arity, AttName, Val)) :- 716 attrib_name(Attrib, AttName, Val), 717 strip_module(Head, M, Term), 718 functor(Term, Name, Arity). 719 720attrib_name(dynamic, dynamic, true). 721attrib_name(volatile, volatile, true). 722attrib_name(thread_local, thread_local, true). 723attrib_name(multifile, multifile, true). 724attrib_name(public, public, true). 725attrib_name(transparent, transparent, true). 726attrib_name(discontiguous, discontiguous, true). 727attrib_name(notrace, trace, false). 728attrib_name(show_childs, hide_childs, false). 729attrib_name(built_in, system, true). 730attrib_name(nodebug, hide_childs, true). 731attrib_name(quasi_quotation_syntax, quasi_quotation_syntax, true). 732attrib_name(iso, iso, true). 733 734 735save_attribute(P, Attribute) :- 736 pred_attrib(Attribute, P, D), 737 ( Attribute == built_in % no need if there are clauses 738 -> ( predicate_property(P, number_of_clauses(0)) 739 -> true 740 ; predicate_property(P, volatile) 741 ) 742 ; Attribute == (dynamic) % no need if predicate is thread_local 743 -> \+ predicate_property(P, thread_local) 744 ; true 745 ), 746 '$add_directive_wic'(D), 747 feedback('(~w) ', [Attribute]). 748 749save_attributes(P) :- 750 ( predicate_property(P, Attribute), 751 save_attribute(P, Attribute), 752 fail 753 ; true 754 ). 755 756% Save status of the unknown flag 757 758save_unknown(M) :- 759 current_prolog_flag(Munknown, Unknown), 760 ( Unknown == error 761 -> true 762 ; '$add_directive_wic'(set_prolog_flag(Munknown, Unknown)) 763 ). 764 765 /******************************* 766 * RECORDS * 767 *******************************/ 768 769save_records :- 770 feedback('~nRECORDS~n', []), 771 ( current_key(X), 772 X \== '$topvar', % do not safe toplevel variables 773 feedback('~n~t~8|~w ', [X]), 774 recorded(X, V, _), 775 feedback('.', []), 776 '$add_directive_wic'(recordz(X, V, _)), 777 fail 778 ; true 779 ). 780 781 782 /******************************* 783 * FLAGS * 784 *******************************/ 785 786save_flags :- 787 feedback('~nFLAGS~n~n', []), 788 ( current_flag(X), 789 flag(X, V, V), 790 feedback('~t~8|~w = ~w~n', [X, V]), 791 '$add_directive_wic'(set_flag(X, V)), 792 fail 793 ; true 794 ). 795 796save_prompt :- 797 feedback('~nPROMPT~n~n', []), 798 prompt(Prompt, Prompt), 799 '$add_directive_wic'(prompt(_, Prompt)). 800 801 802 /******************************* 803 * IMPORTS * 804 *******************************/
814save_imports :- 815 feedback('~nIMPORTS~n~n', []), 816 ( predicate_property(M:H, imported_from(I)), 817 \+ default_import(M, H, I), 818 functor(H, F, A), 819 feedback('~t~8|~w:~w/~d <-- ~w~n', [M, F, A, I]), 820 '$add_directive_wic'(qsave:restore_import(M, I, F/A)), 821 fail 822 ; true 823 ). 824 825default_import(To, Head, From) :- 826 '$get_predicate_attribute'(To:Head, (dynamic), 1), 827 predicate_property(From:Head, exported), 828 !, 829 fail. 830default_import(Into, _, From) :- 831 default_module(Into, From).
user, avoiding a message that the predicate is not
exported.839restore_import(To, user, PI) :- 840 !, 841 export(user:PI), 842 To:import(user:PI). 843restore_import(To, From, PI) :- 844 To:import(From:PI). 845 846 /******************************* 847 * PROLOG FLAGS * 848 *******************************/ 849 850save_prolog_flags(Options) :- 851 feedback('~nPROLOG FLAGS~n~n', []), 852 '$current_prolog_flag'(Flag, Value0, _Scope, write, Type), 853 \+ no_save_flag(Flag), 854 map_flag(Flag, Value0, Value, Options), 855 feedback('~t~8|~w: ~w (type ~q)~n', [Flag, Value, Type]), 856 '$add_directive_wic'(qsave:restore_prolog_flag(Flag, Value, Type)), 857 fail. 858save_prolog_flags(_). 859 860no_save_flag(argv). 861no_save_flag(os_argv). 862no_save_flag(access_level). 863no_save_flag(tty_control). 864no_save_flag(readline). 865no_save_flag(associated_file). 866no_save_flag(cpu_count). 867no_save_flag(tmp_dir). 868no_save_flag(file_name_case_handling). 869no_save_flag(hwnd). % should be read-only, but comes 870 % from user-code 871map_flag(autoload, true, false, Options) :- 872 option(class(runtime), Options, runtime), 873 option(autoload(true), Options, true), 874 !. 875map_flag(_, Value, Value, _).
883restore_prolog_flag(Flag, Value, _Type) :- 884 current_prolog_flag(Flag, Value), 885 !. 886restore_prolog_flag(Flag, Value, _Type) :- 887 current_prolog_flag(Flag, _), 888 !, 889 catch(set_prolog_flag(Flag, Value), _, true). 890restore_prolog_flag(Flag, Value, Type) :- 891 create_prolog_flag(Flag, Value, [type(Type)]). 892 893 894 /******************************* 895 * OPERATORS * 896 *******************************/
system are
not saved because these are read-only anyway.903save_operators(Options) :- 904 !, 905 option(op(save), Options, save), 906 feedback('~nOPERATORS~n', []), 907 forall(current_module(M), save_module_operators(M)), 908 feedback('~n', []). 909save_operators(_). 910 911save_module_operators(system) :- !. 912save_module_operators(M) :- 913 forall('$local_op'(P,T,M:N), 914 ( feedback('~n~t~8|~w ', [op(P,T,M:N)]), 915 '$add_directive_wic'(op(P,T,M:N)) 916 )). 917 918 919 /******************************* 920 * FORMAT PREDICATES * 921 *******************************/ 922 923save_format_predicates :- 924 feedback('~nFORMAT PREDICATES~n', []), 925 current_format_predicate(Code, Head), 926 qualify_head(Head, QHead), 927 D = format_predicate(Code, QHead), 928 feedback('~n~t~8|~w ', [D]), 929 '$add_directive_wic'(D), 930 fail. 931save_format_predicates. 932 933qualify_head(T, T) :- 934 functor(T, :, 2), 935 !. 936qualify_head(T, user:T). 937 938 939 /******************************* 940 * FOREIGN LIBRARIES * 941 *******************************/
947save_foreign_libraries(RC, Options) :- 948 option(foreign(save), Options), 949 !, 950 current_prolog_flag(arch, HostArch), 951 feedback('~nHOST(~w) FOREIGN LIBRARIES~n', [HostArch]), 952 save_foreign_libraries1(HostArch, RC, Options). 953save_foreign_libraries(RC, Options) :- 954 option(foreign(arch(Archs)), Options), 955 !, 956 forall(member(Arch, Archs), 957 ( feedback('~n~w FOREIGN LIBRARIES~n', [Arch]), 958 save_foreign_libraries1(Arch, RC, Options) 959 )). 960save_foreign_libraries(_, _). 961 962save_foreign_libraries1(Arch, RC, _Options) :- 963 forall(current_foreign_library(FileSpec, _Predicates), 964 ( find_foreign_library(Arch, FileSpec, EntryName, File, Time), 965 term_to_atom(EntryName, Name), 966 zipper_append_file(RC, Name, File, [time(Time)]) 967 )).
strip -o <tmp>
<shared-object>. Note that (if stripped) the file is a Prolog tmp
file and will be deleted on halt.
981find_foreign_library(Arch, FileSpec, shlib(Arch,Name), SharedObject, Time) :-
982 FileSpec = foreign(Name),
983 ( catch(arch_find_shlib(Arch, FileSpec, File),
984 E,
985 print_message(error, E)),
986 exists_file(File)
987 -> true
988 ; throw(error(existence_error(architecture_shlib(Arch), FileSpec),_))
989 ),
990 time_file(File, Time),
991 strip_file(File, SharedObject).998strip_file(File, Stripped) :- 999 absolute_file_name(path(strip), Strip, 1000 [ access(execute), 1001 file_errors(fail) 1002 ]), 1003 tmp_file(shared, Stripped), 1004 ( catch(do_strip_file(Strip, File, Stripped), E, 1005 (print_message(warning, E), fail)) 1006 -> true 1007 ; print_message(warning, qsave(strip_failed(File))), 1008 fail 1009 ), 1010 !. 1011strip_file(File, File). 1012 1013do_strip_file(Strip, File, Stripped) :- 1014 format(atom(Cmd), '"~w" -x -o "~w" "~w"', 1015 [Strip, Stripped, File]), 1016 shell(Cmd), 1017 exists_file(Stripped).
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.
1031:- multifile arch_shlib/3. 1032 1033arch_find_shlib(Arch, FileSpec, File) :- 1034 arch_shlib(Arch, FileSpec, File), 1035 !. 1036arch_find_shlib(Arch, FileSpec, File) :- 1037 current_prolog_flag(arch, Arch), 1038 absolute_file_name(FileSpec, 1039 [ file_type(executable), 1040 access(read), 1041 file_errors(fail) 1042 ], File), 1043 !. 1044arch_find_shlib(Arch, foreign(Base), File) :- 1045 current_prolog_flag(arch, Arch), 1046 current_prolog_flag(windows, true), 1047 current_prolog_flag(executable, WinExe), 1048 prolog_to_os_filename(Exe, WinExe), 1049 file_directory_name(Exe, BinDir), 1050 file_name_extension(Base, dll, DllFile), 1051 atomic_list_concat([BinDir, /, DllFile], File), 1052 exists_file(File). 1053 1054 1055 /******************************* 1056 * UTIL * 1057 *******************************/ 1058 1059open_map(Options) :- 1060 option(map(Map), Options), 1061 !, 1062 open(Map, write, Fd), 1063 asserta(verbose(Fd)). 1064open_map(_) :- 1065 retractall(verbose(_)). 1066 1067close_map :- 1068 retract(verbose(Fd)), 1069 close(Fd), 1070 !. 1071close_map. 1072 1073feedback(Fmt, Args) :- 1074 verbose(Fd), 1075 !, 1076 format(Fd, Fmt, Args). 1077feedback(_, _). 1078 1079 1080check_options([]) :- !. 1081check_options([Var|_]) :- 1082 var(Var), 1083 !, 1084 throw(error(domain_error(save_options, Var), _)). 1085check_options([Name=Value|T]) :- 1086 !, 1087 ( save_option(Name, Type, _Comment) 1088 -> ( must_be(Type, Value) 1089 -> check_options(T) 1090 ; throw(error(domain_error(Type, Value), _)) 1091 ) 1092 ; throw(error(domain_error(save_option, Name), _)) 1093 ). 1094check_options([Term|T]) :- 1095 Term =.. [Name,Arg], 1096 !, 1097 check_options([Name=Arg|T]). 1098check_options([Var|_]) :- 1099 throw(error(domain_error(save_options, Var), _)). 1100check_options(Opt) :- 1101 throw(error(domain_error(list, Opt), _)).
1108zipper_append_file(_, Name, _, _) :- 1109 saved_resource_file(Name), 1110 !. 1111zipper_append_file(_, _, File, _) :- 1112 source_file(File), 1113 !. 1114zipper_append_file(Zipper, Name, File, Options) :- 1115 ( option(time(_), Options) 1116 -> Options1 = Options 1117 ; time_file(File, Stamp), 1118 Options1 = [time(Stamp)|Options] 1119 ), 1120 setup_call_cleanup( 1121 open(File, read, In, [type(binary)]), 1122 setup_call_cleanup( 1123 zipper_open_new_file_in_zip(Zipper, Name, Out, Options1), 1124 copy_stream_data(In, Out), 1125 close(Out)), 1126 close(In)), 1127 assertz(saved_resource_file(Name)).
time(Stamp).1134zipper_add_directory(Zipper, Name, Dir, Options) :- 1135 ( option(time(Stamp), Options) 1136 -> true 1137 ; time_file(Dir, Stamp) 1138 ), 1139 atom_concat(Name, /, DirName), 1140 ( saved_resource_file(DirName) 1141 -> true 1142 ; setup_call_cleanup( 1143 zipper_open_new_file_in_zip(Zipper, DirName, Out, 1144 [ method(store), 1145 time(Stamp) 1146 | Options 1147 ]), 1148 true, 1149 close(Out)), 1150 assertz(saved_resource_file(DirName)) 1151 ). 1152 1153add_parent_dirs(Zipper, Name, Dir, Options) :- 1154 ( option(time(Stamp), Options) 1155 -> true 1156 ; time_file(Dir, Stamp) 1157 ), 1158 file_directory_name(Name, Parent), 1159 ( Parent \== Name 1160 -> add_parent_dirs(Zipper, Parent, [time(Stamp)|Options]) 1161 ; true 1162 ). 1163 1164add_parent_dirs(_, '.', _) :- 1165 !. 1166add_parent_dirs(Zipper, Name, Options) :- 1167 zipper_add_directory(Zipper, Name, _, Options), 1168 file_directory_name(Name, Parent), 1169 ( Parent \== Name 1170 -> add_parent_dirs(Zipper, Parent, Options) 1171 ; true 1172 ).
1190zipper_append_directory(Zipper, Name, Dir, Options) :- 1191 exists_directory(Dir), 1192 !, 1193 add_parent_dirs(Zipper, Name, Dir, Options), 1194 zipper_add_directory(Zipper, Name, Dir, Options), 1195 directory_files(Dir, Members), 1196 forall(member(M, Members), 1197 ( reserved(M) 1198 -> true 1199 ; ignored(M, Options) 1200 -> true 1201 ; atomic_list_concat([Dir,M], /, Entry), 1202 atomic_list_concat([Name,M], /, Store), 1203 catch(zipper_append_directory(Zipper, Store, Entry, Options), 1204 E, 1205 print_message(warning, E)) 1206 )). 1207zipper_append_directory(Zipper, Name, File, Options) :- 1208 zipper_append_file(Zipper, Name, File, Options). 1209 1210reserved(.). 1211reserved(..).
include(Patterns) option that does not
match File or an exclude(Patterns) that does match File.1218ignored(File, Options) :- 1219 option(include(Patterns), Options), 1220 \+ ( ( is_list(Patterns) 1221 -> member(Pattern, Patterns) 1222 ; Pattern = Patterns 1223 ), 1224 glob_match(Pattern, File) 1225 ), 1226 !. 1227ignored(File, Options) :- 1228 option(exclude(Patterns), Options), 1229 ( is_list(Patterns) 1230 -> member(Pattern, Patterns) 1231 ; Pattern = Patterns 1232 ), 1233 glob_match(Pattern, File), 1234 !. 1235 1236glob_match(Pattern, File) :- 1237 current_prolog_flag(file_name_case_handling, case_sensitive), 1238 !, 1239 wildcard_match(Pattern, File). 1240glob_match(Pattern, File) :- 1241 wildcard_match(Pattern, File, [case_sensitive(false)]). 1242 1243 1244 /******************************** 1245 * SAVED STATE GENERATION * 1246 *********************************/
1252:- public 1253 qsave_toplevel/0. 1254 1255qsave_toplevel :- 1256 current_prolog_flag(os_argv, Argv), 1257 qsave_options(Argv, Files, Options), 1258 set_on_error(Options), 1259 '$cmd_option_val'(compileout, Out), 1260 user:consult(Files), 1261 maybe_exit_on_errors, 1262 qsave_program(Out, user:Options). 1263 1264set_on_error(Options) :- 1265 option(on_error(_), Options), !. 1266set_on_error(_Options) :- 1267 set_prolog_flag(on_error, status). 1268 1269maybe_exit_on_errors :- 1270 '$exit_code'(Code), 1271 ( Code =\= 0 1272 -> halt 1273 ; true 1274 ). 1275 1276qsave_options([], [], []). 1277qsave_options([--|_], [], []) :- 1278 !. 1279qsave_options(['-c'|T0], Files, Options) :- 1280 !, 1281 argv_files(T0, T1, Files, FilesT), 1282 qsave_options(T1, FilesT, Options). 1283qsave_options([O|T0], Files, [Option|T]) :- 1284 string_concat(--, Opt, O), 1285 split_string(Opt, =, '', [NameS|Rest]), 1286 split_string(NameS, '-', '', NameParts), 1287 atomic_list_concat(NameParts, '_', Name), 1288 qsave_option(Name, OptName, Rest, Value), 1289 !, 1290 Option =.. [OptName, Value], 1291 qsave_options(T0, Files, T). 1292qsave_options([_|T0], Files, T) :- 1293 qsave_options(T0, Files, T). 1294 1295argv_files([], [], Files, Files). 1296argv_files([H|T], [H|T], Files, Files) :- 1297 sub_atom(H, 0, _, _, -), 1298 !. 1299argv_files([H|T0], T, [H|Files0], Files) :- 1300 argv_files(T0, T, Files0, Files).
1304qsave_option(Name, Name, [], true) :- 1305 save_option(Name, boolean, _), 1306 !. 1307qsave_option(NoName, Name, [], false) :- 1308 atom_concat('no_', Name, NoName), 1309 save_option(Name, boolean, _), 1310 !. 1311qsave_option(Name, Name, ValueStrings, Value) :- 1312 save_option(Name, Type, _), 1313 !, 1314 atomics_to_string(ValueStrings, "=", ValueString), 1315 convert_option_value(Type, ValueString, Value). 1316qsave_option(Name, Name, _Chars, _Value) :- 1317 existence_error(save_option, Name). 1318 1319convert_option_value(integer, String, Value) :- 1320 ( number_string(Value, String) 1321 -> true 1322 ; sub_string(String, 0, _, 1, SubString), 1323 sub_string(String, _, 1, 0, Suffix0), 1324 downcase_atom(Suffix0, Suffix), 1325 number_string(Number, SubString), 1326 suffix_multiplier(Suffix, Multiplier) 1327 -> Value is Number * Multiplier 1328 ; domain_error(integer, String) 1329 ). 1330convert_option_value(callable, String, Value) :- 1331 term_string(Value, String). 1332convert_option_value(atom, String, Value) :- 1333 atom_string(Value, String). 1334convert_option_value(boolean, String, Value) :- 1335 atom_string(Value, String). 1336convert_option_value(oneof(_), String, Value) :- 1337 atom_string(Value, String). 1338convert_option_value(ground, String, Value) :- 1339 atom_string(Value, String). 1340convert_option_value(qsave_foreign_option, "save", save). 1341convert_option_value(qsave_foreign_option, StrArchList, arch(ArchList)) :- 1342 split_string(StrArchList, ",", ", \t", StrArchList1), 1343 maplist(atom_string, ArchList, StrArchList1). 1344 1345suffix_multiplier(b, 1). 1346suffix_multiplier(k, 1024). 1347suffix_multiplier(m, 1024 * 1024). 1348suffix_multiplier(g, 1024 * 1024 * 1024). 1349 1350 1351 /******************************* 1352 * MESSAGES * 1353 *******************************/ 1354 1355:- multifile prolog:message/3. 1356 1357prologmessage(no_resource(Name, File)) --> 1358 [ 'Could not find resource ~w on ~w or system resources'- 1359 [Name, File] ]. 1360prologmessage(qsave(nondet)) --> 1361 [ 'qsave_program/2 succeeded with a choice point'-[] ]
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.
*/