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