1% BEGIN LICENSE BLOCK 2% Version: CMPL 1.1 3% 4% The contents of this file are subject to the Cisco-style Mozilla Public 5% License Version 1.1 (the "License"); you may not use this file except 6% in compliance with the License. You may obtain a copy of the License 7% at www.eclipse-clp.org/license. 8% 9% Software distributed under the License is distributed on an "AS IS" 10% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See 11% the License for the specific language governing rights and limitations 12% under the License. 13% 14% The Original Code is The ECLiPSe Constraint Logic Programming System. 15% The Initial Developer of the Original Code is Cisco Systems, Inc. 16% Portions created by the Initial Developer are 17% Copyright (C) 2006,2007 Cisco Systems, Inc. All Rights Reserved. 18% 19% Contributor(s): Joachim Schimpf. 20% 21% END LICENSE BLOCK 22% ---------------------------------------------------------------------- 23% System: ECLiPSe Constraint Logic Programming System 24% Component: ECLiPSe III compiler 25% Version: $Id: ecl_compiler.ecl,v 1.24 2013/02/26 02:10:06 jschimpf Exp $ 26% ---------------------------------------------------------------------- 27 28:- module(ecl_compiler). 29 30:- comment(summary, "ECLiPSe III compiler - toplevel predicates"). 31:- comment(copyright, "Cisco Technology Inc"). 32:- comment(author, "Joachim Schimpf"). 33:- comment(date, "$Date: 2013/02/26 02:10:06 $"). 34 35:- comment(desc, html(" 36 This module contains the toplevel predicates for invoking the 37 compiler. This is where the different compiler passes are chained 38 together, and where the compiler options are defined. It also 39 contains the code to process source files, and to interpret 40 directives and queries. 41 <P> 42 The top-level interfaces to the compiler are: compile/1,2 for 43 compilation from files, compile_stream/1,2 for compiling from an 44 arbitrary stream, and compile_term/1,2 for compiling data. 45 <P> 46 The predicates themselves are documented in the kernel/database 47 section of the reference manual. 48")). 49 50 51:- use_module(compiler_common). 52:- use_module(compiler_normalise). 53:- use_module(compiler_analysis). 54:- use_module(compiler_peephole). 55:- use_module(compiler_codegen). 56:- use_module(compiler_varclass). 57:- use_module(compiler_indexing). 58:- use_module(compiler_regassign). 59:- use_module(source_processor). 60 61:- lib(asm). 62:- lib(hash). 63:- lib(module_options). 64 65:- import 66 collect_discontiguous_predicates/2, 67 deregister_compiler/0, 68 expand_clause_annotated/4, 69 implicit_local/2, 70 bip_error/1, 71 record_discontiguous_predicate/4, 72 record_inline_source/4, 73 register_compiler/1, 74 set_default_error_handler/2 75 from sepia_kernel. 76 77:- pragma(system). 78 79 80%---------------------------------------------------------------------- 81% Compiler Options 82%---------------------------------------------------------------------- 83 84compiler_options_setup(File, OptionList, Options) :- 85 ( atom(File) -> atom_string(File, FileS) 86 ; string(File) -> FileS = File 87 ; term_string(File, FileS) 88 ), 89 90 ( OptionList = options{} -> 91 Options00 = OptionList 92 ; get_options(OptionList, Options00)@compiler_common -> 93 true 94 ; 95 printf(error, "Invalid option list: %w%n", [OptionList]), 96 print_default_options(error)@compiler_common, 97 abort 98 ), 99 100 Options00 = options{outdir:OutDir,srcroot:SrcRoot}, 101 ( SrcRoot == "" -> 102 Options0 = Options00 103 ; 104 canonical_path_name(SrcRoot, CanSrcRoot), 105 concat_string([CanSrcRoot], CanSrcRootString), 106 update_struct(options, [srcroot:CanSrcRootString], Options00, Options0) 107 ), 108 ( Options0 = options{output:listing(LstFile)} -> 109 open(LstFile,write,Stream), 110 update_struct(options, [output:print(Stream)], Options0, Options) 111 ; Options0 = options{output:listing} -> 112 default_output_file(FileS, OutDir, '.lst', LstFile), 113 open(LstFile,write,Stream), 114 update_struct(options, [output:print(Stream)], Options0, Options) 115 ; Options0 = options{output:eco(EcoFile)} -> 116 open(EcoFile,write,Stream,[end_of_line(lf)]), 117 update_struct(options, [output:eco_to_stream(Stream)], Options0, Options) 118 ; Options0 = options{output:eco} -> 119 get_flag(eclipse_object_suffix, ECO), 120 default_output_file(FileS, OutDir, ECO, EcoFile), 121 open(EcoFile,write,Stream,[end_of_line(lf)]), 122 update_struct(options, [output:eco_to_stream(Stream)], Options0, Options) 123 ; Options0 = options{output:asm(AsmFile)} -> 124 open(AsmFile,write,Stream), 125 update_struct(options, [output:asm_to_stream(Stream)], Options0, Options) 126 ; Options0 = options{output:asm} -> 127 default_output_file(FileS, OutDir, '.asm', AsmFile), 128 open(AsmFile,write,Stream), 129 update_struct(options, [output:asm_to_stream(Stream)], Options0, Options) 130 ; 131 Options = Options0 132 ). 133 134 default_output_file(InFile, OutDir, Suffix, OutFile) :- 135 pathname(InFile, Dir, Base, _Suffix), 136 ( concat_string([OutDir], "") -> 137 concat_string([Dir,Base,Suffix], OutFile) 138 ; 139 concat_string([OutDir,/,Base,Suffix], OutFile) 140 ). 141 142 143compiler_options_cleanup(Options) :- 144 ( Options = options{output:print(Stream)} -> 145 close(Stream) 146 ; Options = options{output:eco_to_stream(Stream)} -> 147 close(Stream) 148 ; Options = options{output:asm_to_stream(Stream)} -> 149 close(Stream) 150 ; 151 true 152 ). 153 154 155% ---------------------------------------------------------------------- 156% Compile a single predicate. 157% 158% Takes a list of clauses (which must all be for the same predicate), 159% In case of error, succeed with Size = -1.0Inf. 160% ---------------------------------------------------------------------- 161 162compile_predicate(ModulePred, Clauses, AnnClauses, SourcePos, PredsSeen, Options, Size) :- 163 block( 164 compile_predicate1(ModulePred, Clauses, AnnClauses, SourcePos, 165 PredsSeen, Options, Size), 166 abort_compile_predicate, 167 Size = -1.0Inf), 168 ( var(Size) -> Size=0 ; true ). 169 170 171compile_predicate1(_, [], _, _, _, _, CodeSize) :- !, CodeSize = 0. 172compile_predicate1(ModulePred, Clauses0, AnnClauses0, SourcePos, PredsSeen, Options, CodeSize) :- 173 message(compiling(ModulePred), Options), 174 ModulePred = Module:Pred, 175 Pred = N/A, 176 ( atom(N), integer(A) -> true 177 ; compiler_event(#illegal_head, SourcePos, _Ann, N, Module) 178 ), 179 verify (Clauses0 = [Clause|_], extract_pred(Clause, Pred)), 180 legal_pred_definition(Pred, SourcePos, Module, Options), 181 % Do inlining/goal expansion. This is done here rather than in the 182 % source_processor to make it controllable via pragmas. 183 ( Options = options{expand_goals:on} -> 184 expand_clause_goals(Clauses0, AnnClauses0, Clauses, AnnClauses, Module) 185 ; 186 Clauses = Clauses0, AnnClauses = AnnClauses0 187 ), 188 % Distinguish dynamic/discontiguous/static 189 ( local_get_flag(Pred, stability, dynamic, Module) -> 190 CodeSize = 0, 191 ( foreach(Clause, Clauses), param(SourcePos,Options,Module) do 192 process_query(SourcePos, (?-assertz(Clause)), Options, Module) 193 ) 194 195 ; record_discontiguous_predicate(Pred, Clauses, AnnClauses, Module) -> 196 % will be compiled later via compile_discontiguous_preds/5 197 CodeSize = 0 198 199 ; check_redefinition(ModulePred, PredsSeen, SourcePos, Options) -> 200 compile_static_predicate(Pred, Clauses, AnnClauses, SourcePos, Options, CodeSize, Module) 201 ; 202 CodeSize = 0 203 ). 204 205 206compile_static_predicate(_Pred, [], _AnnClauses, _SourcePos, _Options, CodeSize, _Module) ?- !, 207 CodeSize = 0. 208compile_static_predicate(Pred, Clauses, AnnClauses, SourcePos, Options, CodeSize, Module) :- 209 compile_pred_to_wam(Pred, Clauses, AnnClauses, WAM, Options, Module), 210 pred_flags(Options, Flags), 211 load_compiled_code(Pred, WAM, CodeSize, Flags, SourcePos, Options, Module), 212 output_compiled_code(Pred, WAM, Clauses, CodeSize, Flags, SourcePos, Options, Module), 213 ( var(CodeSize) -> CodeSize=0 ; true ). 214 215 216compile_discontiguous_preds(Module, SourcePos, Options, Size0, Size) :- 217 collect_discontiguous_predicates(Module, NonContigPreds), 218 ( 219 foreach(Pred-ClausePairs,NonContigPreds), 220 fromto(Size0,Size1,Size2,Size), 221 param(Module, SourcePos, Options) 222 do 223 ( 224 local_get_flag(Pred, source_file, OldFile, Module), 225 SourcePos = source_position{file:NewFile0,line:Line}, 226 normalised_source_file(NewFile0, Options, NewFileAtom), 227 OldFile \== NewFileAtom, 228 \+ error(#multifile, (Pred,OldFile,NewFileAtom:Line), Module) 229 -> 230 % Seen in other file: if handler fails, don't redefine 231 Size2 = Size1 232 ; 233 ( foreach(Clause-AnnClause,ClausePairs), 234 foreach(Clause,Clauses), foreach(AnnClause,AnnClauses) 235 do 236 true 237 ), 238 block(compile_static_predicate(Pred, Clauses, AnnClauses, SourcePos, Options, CodeSize, Module), 239 abort_compile_predicate, 240 CodeSize = -1.0Inf), 241 Size2 is Size1 + CodeSize 242 ) 243 ). 244 245 246 load_compiled_code(Pred, WAM, CodeSize, Flags, SourcePos, Options, Module) :- 247 ( ( Options = options{load:all} ; Options = options{load:new}, \+ is_predicate(Pred)@Module) -> 248 % double negation, because asm binds the labels 249 message("Asm and load", 2, Options), 250 \+ \+ asm(Pred, WAM, Flags)@Module, 251 get_flag(Pred, code_size, CodeSize)@Module, 252 set_pred_pos(Pred, SourcePos, Options, Module) 253 ; 254 true % don't clobber existing code if not loading 255 ). 256 257 258 output_compiled_code(Pred, WAM, Clauses, CodeSize, Flags, SourcePos, Options, Module) :- 259 ( Options = options{output:print} -> 260 printf("%w:%n", [Pred]), 261 print_wam(WAM) 262 263 ; Options = options{output:print(Stream)} -> 264 writeclauses(Stream, Clauses), 265 get_stream(output, OldOut), 266 set_stream(output, Stream), 267 print_wam(WAM), 268 set_stream(output, OldOut), 269 writeln(Stream, --------------------) 270 271 ; Options = options{output:eco_to_stream(Stream)} -> 272 message("Asm", 2, Options), 273 pasm(WAM, CodeSize, BTPos, Codes), 274 ( portable_object_code(Codes) -> 275 true 276 ; 277 get_flag(eclipse_object_suffix, ECO), 278 machine_bits(BPW), 279 printf(warning_output, 280 "WARNING: the generated %w file will only work reliably on %w bit machines!%n", 281 [ECO,BPW]) 282 ), 283 CodeArr =.. [[]|Codes], 284 get_pred_pos(SourcePos, Options, File, Line, Offset), 285 StorePred = store_pred(Pred,CodeArr,CodeSize,BTPos,Flags,File,Line,Offset), 286 ( Module == sepia_kernel -> 287 % call locally, because :/2 may not be defined yet 288 QStorePred = StorePred 289 ; 290 QStorePred = sepia_kernel:StorePred 291 ), 292 message("Output", 2, Options), 293 printf(Stream, "%ODQKw.%n", [:-QStorePred])@Module 294 295 296 ; Options = options{output:asm_to_stream(Stream)} -> 297 message("Output", 2, Options), 298 pretty_print_asm(WAM, Stream, Pred, Flags, Module) 299 300 ; Options = options{output:none} -> 301 true 302 ; 303 Options = options{output:Junk}, 304 printf(error, "Invalid output option: %w%n", [Junk]), 305 abort 306 ). 307 308 309 writeclauses(Stream, Clauses) :- 310 get_stream_info(Stream, output_options, Opt), 311 ( delete(numbervars(NV), Opt, Opt0) -> true ; NV=false,Opt0=Opt ), 312 set_stream_property(Stream, output_options, [numbervars(true)|Opt0]), 313 ( foreach(Clause,Clauses),param(Stream) do 314 \+ \+ ( 315 numbervars(Clause, 0, _), 316 writeclause(Stream, Clause) 317 ) 318 ), 319 nl(Stream), 320 set_stream_property(Stream, output_options, [numbervars(NV)|Opt0]). 321 322 numbervars('$VAR'(N), N, N1) :- !, 323 N1 is N + 1. 324 numbervars(Term, N0, N) :- 325 ( foreacharg(Arg,Term), fromto(N0,N1,N2,N) do 326 numbervars(Arg, N1, N2) 327 ). 328 329 330 pretty_print_asm(WAM, Stream, Pred, Flags, Module) :- 331 printf(Stream, ":- asm:asm(%DQKw, [%n", [Pred])@Module, 332 ( fromto(WAM, [Instr|Rest],Rest, []), param(Stream, Module) do 333 ( Instr = label(_) -> 334 printf(Stream, "%DQKw", [Instr])@Module % no indent for labels 335 ; 336 printf(Stream, " %DQKw", [Instr])@Module 337 ), 338 (Rest \== [] -> writeln(Stream, ",") ; nl(Stream)) 339 ), 340 printf(Stream, "], %DQKw).%n%n", [Flags]). 341 342 343 344 pred_flags(options{debug:Debug,system:System,skip:Skip}, Flags) ?- 345 ( Debug==on -> Flags0 = 16'00080000 ; Flags0 = 0 ), %'% DEBUG_DB 346 ( System==on -> Flags1 is Flags0 \/ 16'40000000 ; Flags1 = Flags0 ), %'% SYSTEM 347 ( Skip==on -> Flags is Flags1 \/ 16'00040000 ; Flags = Flags1 ). %'% DEBUG_SK 348 349 350 set_pred_flags(options{debug:Debug,system:System,skip:Skip}, Pred, Module) ?- 351 set_flag(Pred, debugged, Debug)@Module, 352 set_flag(Pred, skip, Skip)@Module, 353 ( System==on -> Type = built_in ; Type = user ), 354 set_flag(Pred, type, Type)@Module. 355 356 357 set_pred_pos(Pred, source_position{file:File,line:Line,offset:Offset}, Options, Module) :- !, 358 normalised_source_file(File, Options, SrcFile), 359 set_flag(Pred, source_file, SrcFile)@Module, 360 ( Options = options{debug:on} -> 361 set_flag(Pred, source_line, Line)@Module, 362 set_flag(Pred, source_offset, Offset)@Module 363 ; 364 set_flag(Pred, source_line, 0)@Module, 365 set_flag(Pred, source_offset, 0)@Module 366 ). 367 set_pred_pos(_Pred, _Pos, _Options, _Module). 368 369 370 get_pred_pos(source_position{file:File,line:Line0,offset:Offset0}, Options, SrcFile, Line, Offset) ?- !, 371 ( Options = options{debug:on} -> 372 Line = Line0, Offset = Offset0 373 ; 374 % hide position in file to avoid irrelevant diffs in .eco files 375 Line = 0, Offset = 0 376 ), 377 normalised_source_file(File, Options, SrcFile). 378 get_pred_pos(_, _, 0, 0, 0). 379 380 381 normalised_source_file(File, options{srcroot:Root,debug:Debug}, NormFileAtom) ?- 382 % File is canonical, and either atom or string 383 concat_string([File], FileS), 384 ( Debug==off, substring(FileS, 0, PrefixLen, _, Root) -> 385 substring(FileS, PrefixLen, _, 0, RelFileS) 386 ; 387 RelFileS = FileS 388 ), 389 concat_atom([RelFileS], NormFileAtom). 390 391 392 % Fail if this is a redefinition that we want to ignore 393 check_redefinition(ModulePred, PredsSeen, SourcePos, Options) :- 394 ModulePred = Module:Pred, 395 ( hash_contains(PredsSeen, ModulePred) -> 396 % Non-consecutive clauses: if handler fails, don't redefine 397 compiler_event(#consecutive, SourcePos, _Ann, Pred, Module) 398 ; 399 local_get_flag(Pred, source_file, OldFile, Module), 400 SourcePos = source_position{file:NewFile0,line:Line}, 401 normalised_source_file(NewFile0, Options, NewFileAtom), 402 OldFile \== NewFileAtom 403 -> 404 % Seen in other file: if handler fails, don't redefine 405 error(#multifile, (Pred,OldFile,NewFileAtom:Line), Module) 406 ; 407 true 408 ), 409 hash_set(PredsSeen, ModulePred, []). 410 411 412 % Make sure we can define this predicate 413 legal_pred_definition(Pred, SourcePos, Module, Options) :- 414 ( Options = options{load:all} -> 415 % does all checks, hiding imports, etc 416 ( implicit_local(Pred, Module) -> 417 true 418 ; 419 print_error_location(error, _Ann, SourcePos), 420 block(bip_error(Pred)@Module, _Any, exit_block(abort_compile_predicate)) 421 ) 422 ; 423 % If not loading, don't create the local predicate. Problem: 424 % subsequent calls to get_flag/3 may trigger lazy imports for 425 % preds that would be hidden when loading, and so give wrong 426 % flags. That's why we have to use local_get_flag/3 instead. 427 true 428 ), 429 ( local_get_flag(Pred, tool, on, Module) -> 430 block(error(#tool_redef, Pred, Module), _Any, exit_block(abort_compile_predicate)) 431 ; true ), 432 ( local_get_flag(Pred, parallel, on, Module), Options = options{warnings:on} -> 433 printf(warning_output, "Parallel-declaration ignored for %w%n", [Module:Pred]) 434 ; true ). 435 436 437 % Use this for looking up properties of the predicate being compiled 438 local_get_flag(Pred, Property, Value, Module) :- 439 ( get_flag(Pred, definition_module, Module)@Module -> 440 get_flag(Pred, Property, Value)@Module 441 ; 442 get_flag_default(Property, Value) 443 ). 444 445 get_flag_default(tool, off). 446 get_flag_default(parallel, off). 447 get_flag_default(stability, static). 448 %get_flag_default(source_file, _) :- fail. 449 450 451% Compile a predicate (list of clauses) to WAM code list 452% This chains together the various stages of the comiler 453 454compile_pred_to_wam(Pred, Clauses, AnnCs, FinalCode, Options, Module) :- 455 456 % Create our normal form 457 message("Normalize", 2, Options), 458 normalize_clauses_annotated(Clauses, AnnCs, NormPred0, NVars, Options, Module), 459% print_normalized_clause(output, NormPred0), 460 461 % If this predicate is to be unfolded, record its (de)normalised source 462 ( get_flag(Pred, inline, unfold/_)@Module -> 463 denormalize_pred(NormPred0, NVars, Head, SingleClause, AnnSingleClause), 464 record_inline_source(Head, SingleClause, AnnSingleClause, Module) 465 ; 466 true 467 ), 468 469 % Do some intra-predicate flow analysis 470 message("Analysis", 2, Options), 471 binding_analysis(NormPred0), 472 473 % Here we could have a simplification pass, exploiting 474 % information from the analysis phase. 475 476 % Indexing_transformation (needs info from binding_analysis) 477 message("Indexing", 2, Options), 478 indexing_transformation(NormPred0, NormPred, Options), 479 480 % Variable classification 481 % classify_variables must be after indexing transformation, because 482 % indexing_transformation introduces extra variable occurrences. 483 % Classifies void, temp and permanent vaiables, and assigns environment 484 % slots to the permanent ones. Also adds disjunction pseudo-args. 485 message("Varclass", 2, Options), 486 classify_variables(NormPred, 0, Options), 487 488 ( Options = options{print_normalised:on} -> 489 print_normalized_clause(output, NormPred) 490 ; 491 true 492 ), 493 494 % Code generation 495 message("Codegen", 2, Options), 496 generate_code(NormPred, RawCode, AuxCode, Options, Module:Pred), 497 ( Options = options{print_raw_code:on} -> 498 print_annotated_code(RawCode) 499 ; 500 true 501 ), 502 503 % Register allocation 504 message("Regassign", 2, Options), 505 assign_am_registers(RawCode, RegCode, AuxCode), 506 ( Options = options{print_raw_code:on} -> 507 print_annotated_code(RegCode) 508 ; 509 true 510 ), 511 512 % WAM level postprocessing 513 message("Simplify", 2, Options), 514 simplify_code(RegCode, FinalCode, Options), 515 ( Options = options{print_final_code:on} -> 516 print_annotated_code(FinalCode) 517 ; 518 true 519 ). 520 521 522%---------------------------------------------------------------------- 523% Error handling 524%---------------------------------------------------------------------- 525 526?- set_default_error_handler(#consecutive, compiler_err_fail_handler/2). 527?- reset_event_handler(#consecutive). 528?- set_default_error_handler(#illegal_head, compiler_err_abort_handler/2). 529?- reset_event_handler(#illegal_head). 530?- set_default_error_handler(#illegal_goal, compiler_err_abort_handler/2). 531?- reset_event_handler(#illegal_goal). 532 533compiler_err_abort_handler(Error, Culprit) :- 534 print_compiler_message('ERROR', Error, Culprit), 535 exit_block(abort_compile_predicate). 536 537compiler_err_fail_handler(Error, Culprit) :- 538 print_compiler_message('ERROR', Error, Culprit), 539 fail. 540 541compiler_warn_cont_handler(Error, Culprit) :- 542 print_compiler_message('WARNING', Error, Culprit). 543 544 print_compiler_message(Severity, Error, Term@Location) ?- 545 severity_stream(Severity, Stream), 546 printf(Stream, "%w: ", [Severity]), 547 print_location(Stream, Location), 548 error_id(Error, Message), 549 printf(Stream, "%w: ", [Message]), 550 get_flag(output_options, OutputOptions), 551 write_term(Stream, Term, OutputOptions), 552 nl(Stream), 553 flush(Stream). 554 555 severity_stream('WARNING', warning_output). 556 severity_stream('ERROR', error). 557 558 559:- set_default_error_handler(#multifile, redef_other_file_handler/2). 560?- reset_event_handler(#multifile). 561 562redef_other_file_handler(_, (Pred, OldFile0, Location)) :- 563 print_location(warning_output, Location), 564 local_file_name(OldFile0, OldFile), 565 printf(warning_output, "WARNING: %Kw replaces previous definition in file %w%n", 566 [Pred,OldFile]). 567 568 569%---------------------------------------------------------------------- 570% From-file compiler 571%---------------------------------------------------------------------- 572 573:- export 574 compile/1, compile_/2, 575 compile/2, compile_/3, 576 compile_stream/1, compile_stream_/2, 577 compile_stream/2, compile_stream_/3. 578 579:- tool(compile/1, compile_/2). 580:- set_flag(compile/1, type, built_in). 581compile_(File, Module) :- 582 compile_(File, [], Module). 583 584 585:- tool(compile_stream/1, compile_stream_/2). 586:- set_flag(compile_stream/1, type, built_in). 587compile_stream_(Stream, Module) :- 588 compile_stream_(Stream, [], Module). 589 590 591:- tool(compile_stream/2, compile_stream_/3). 592:- set_flag(compile_stream/2, type, built_in). 593compile_stream_(Stream, Options, Module) :- 594 compile_source(stream(Stream), Options, Module). 595 596 597:- tool(compile/2, compile_/3). 598:- set_flag(compile/2, type, built_in). 599 600compile_(Sources, OptionListOrModule, CM) :- Sources = [_|_], !, 601 ( foreach(Source,Sources), param(OptionListOrModule, CM) do 602 compile_source(Source, OptionListOrModule, CM) 603 ). 604compile_(Source, OptionListOrModule, CM) :- 605 compile_source(Source, OptionListOrModule, CM). 606 607 608compile_source(Source, OptionListOrModule, CM) :- 609 % The subcall is needed to make coroutining in the compiler work, 610 % and to give compiled queries a standard environment to run in. 611 subcall(compile_source1(Source, OptionListOrModule, CM), _Delayed). 612 613compile_source1(Source, OptionListOrModule, CM) :- 614 valid_source(Source), 615 !, 616 % for backward compatibility, allow compile(Source, Module) 617 % with the module being created if it does not exist 618 ( atom(OptionListOrModule), OptionListOrModule \== [] -> 619 Module = OptionListOrModule, OptionList = [], 620 ( current_module(Module) -> true ; create_module(Module) ) 621 ; 622 Module = CM, OptionList = OptionListOrModule 623 624 ), 625 compiler_options_setup(Source, OptionList, Options), 626 source_processor_options_setup(Options, OpenOptions, CloseOptions), 627 error(#start_compiler, Source, CM), 628 cputime(Tstart), 629 ( source_open(Source, [with_annotations|OpenOptions], SourcePos0)@Module -> 630 SourcePos0 = source_position{stream:Stream,file:CanonicalFile}, 631 get_stream_info(Stream, device, Device), 632 Options = options{load:Loading}, 633 register_compiler(args(Term,Ann,Loading)-(ecl_compiler:compile_term_annotated(Term,Ann,Options))), 634 hash_create(PredsSeen), 635 ( 636 fromto(begin, _, Class, end), 637 fromto(SourcePos0, SourcePos1, SourcePos2, SourcePosEnd), 638 fromto(SourcePos0, PredPos1, PredPos2, _), 639 fromto(ClauseTail, Clauses0, Clauses1, []), 640 fromto(ClauseTail, ClauseTail0, ClauseTail1, []), 641 fromto(AnnClauseTail, AnnClauses0, AnnClauses1, []), 642 fromto(AnnClauseTail, AnnClauseTail0, AnnClauseTail1, []), 643 fromto(0, Size0, Size2, Size3), 644 fromto(none, Pred0, Pred1, none), 645 param(PredsSeen,Options,Module) 646 do 647 source_read(SourcePos1, SourcePos2, Class, SourceTerm), 648 SourcePos1 = source_position{module:PosModule}, 649 SourceTerm = source_term{term:Term,annotated:Ann}, 650 651 ( Class = clause -> 652 accumulate_clauses(Term, Ann, PosModule, Options, SourcePos1, PredsSeen, 653 Size0, Pred0, PredPos1, Clauses0, ClauseTail0, AnnClauses0, AnnClauseTail0, 654 Size2, Pred1, PredPos2, Clauses1, ClauseTail1, AnnClauses1, AnnClauseTail1) 655 656 ; Class = comment -> % comment, ignore 657 Size0 = Size2, 658 Pred1 = Pred0, 659 ClauseTail1 = ClauseTail0, 660 Clauses1 = Clauses0, 661 AnnClauseTail1 = AnnClauseTail0, 662 AnnClauses1 = AnnClauses0, 663 PredPos2 = PredPos1 664 665 ; % other classes are taken as predicate separator 666 ClauseTail0 = [], % compile previous predicate 667 AnnClauseTail0 = [], 668 compile_predicate(Pred0, Clauses0, AnnClauses0, PredPos1, PredsSeen, Options, CSize), 669 Size1 is Size0 + CSize, 670 Clauses1 = ClauseTail1, 671 AnnClauses1 = AnnClauseTail1, 672 Pred1 = none, 673 PredPos2 = none, 674 675 block(handle_nonclause(Class, Term, Ann, SourcePos1, Size1, Size2, Options, PosModule, Module), 676 abort_compile_predicate, Size2 = -1.0Inf) 677 ) 678 ), 679 680 % Deal with discontiguous clauses collected above 681 SourcePosEnd = source_position{module:EndModule}, 682 compile_discontiguous_preds(EndModule, SourcePosEnd, Options, Size3, Size), 683 684 % If the compilation was successful, raise various events 685 ( Size >= 0 -> 686 % Raise event 149, which executes initialization goals, etc. 687 % This must be done before cd-ing back in source_close below. 688 % This event is also raised when the module changes mid-file! 689 ( Options = options{load:none} -> 690 true 691 ; EndModule == Module -> 692 error(#code_unit_loaded, [], EndModule) 693 ; 694 error(#code_unit_loaded, [check], EndModule) 695 ), 696 697 % Raise event 139, which prints the compilation statistics 698 Tcompile is cputime-Tstart, 699 words_to_bytes(Size, SizeInBytes), 700 ( Device == file -> 701 concat_atom([CanonicalFile], CanonicalSource) 702 ; 703 CanonicalSource = source(Device) 704 ), 705 error(#compiled_file, (CanonicalSource, SizeInBytes, Tcompile), EndModule), 706 707 % Raise event 166, which records the compiled_file information 708 % (used for recompilation, make/0 etc) 709 ( Options = options{load:none} -> 710 true 711 ; atom(CanonicalSource) -> 712 error(#record_compiled_file, CanonicalSource-(ecl_compiler:compile(CanonicalSource, OptionList)), Module) 713 ; 714 true 715 ) 716 ; 717 true 718 ), 719 deregister_compiler, 720 source_close(SourcePosEnd, CloseOptions), 721 compiler_options_cleanup(Options), 722 ( Size >= 0 -> true ; 723 printf(error, "Error(s) occurred while compiling %w%n", [Source]), 724 abort 725 ) 726 ; 727 compiler_options_cleanup(Options), 728 printf(error, "No such file in %Qw%n", [compile(Source)]), 729 abort 730 ). 731compile_source1(Source, OptionListOrModule, CM) :- var(Source), !, 732 error(#inst_fault, compile(Source, OptionListOrModule), CM). 733compile_source1(Source, OptionListOrModule, CM) :- 734 error(#type_error, compile(Source, OptionListOrModule), CM). 735 736 valid_source(Source) :- atom(Source). 737 valid_source(Source) :- string(Source). 738 valid_source(library(_)) ?- true. 739 valid_source(stream(_)) ?- true. 740 741 742source_processor_options_setup(options{load:Load,expand_clauses:ClauseExp}, OpenOptions, CloseOptions) :- 743 ( Load == all -> 744 OpenOptions = [recreate_modules|OO], CloseOptions = [keep_modules] 745 ; 746 OpenOptions = OO, CloseOptions = [] 747 ), 748 ( ClauseExp == on -> 749 OO = [] 750 ; 751 OO = [no_clause_expansion] 752 ). 753 754 755% Add a single clause or a list of clauses to what we already have. 756% If a predicate is finished, compile it. 757:- mode accumulate_clauses(+,+,+,+,+,+,+,+,+,?,-,?,-,-,-,-,-,-,-,-). 758accumulate_clauses([], [], _Module, _Options, _ClausePos, _PredsSeen, 759 Size0, Pred0, PredPos0, PredCl0, PredClTl0, PredClAnn0, PredClAnnTl0, 760 Size0, Pred0, PredPos0, PredCl0, PredClTl0, PredClAnn0, PredClAnnTl0) :- 761 !. 762accumulate_clauses([Term|Terms], [AnnTerm|AnnTerms], Module, Options, ClausePos, PredsSeen, 763 Size0, Pred0, PredPos0, PredCl0, PredClTl0, PredClAnn0, PredClAnnTl0, 764 Size, Pred, PredPos, PredCl, PredClTl, PredClAnn, PredClAnnTl) :- 765 !, 766 extract_pred(Term, NA), 767 Pred1 = Module:NA, 768 ( Pred0 == Pred1 -> 769 % another clause for Pred0 770 PredClTl0 = [Term|PredClTl1], 771 PredClAnnTl0 = [AnnTerm|PredClAnnTl1], 772 accumulate_clauses(Terms, AnnTerms, Module, Options, ClausePos, PredsSeen, 773 Size0, Pred0, PredPos0, PredCl0, PredClTl1, PredClAnn0, PredClAnnTl1, 774 Size, Pred, PredPos, PredCl, PredClTl, PredClAnn, PredClAnnTl) 775 ; 776 % first clause for next predicate Pred1, compile Pred0 777 PredClTl0 = [], PredClAnnTl0 = [], 778 compile_predicate(Pred0, PredCl0, PredClAnn0, PredPos0, PredsSeen, Options, CSize), 779 Size1 is Size0 + CSize, 780 PredCl1 = [Term|PredClTl1], 781 PredClAnn1 = [AnnTerm|PredClAnnTl1], 782 accumulate_clauses(Terms, AnnTerms, Module, Options, ClausePos, PredsSeen, 783 Size1, Pred1, ClausePos, PredCl1, PredClTl1, PredClAnn1, PredClAnnTl1, 784 Size, Pred, PredPos, PredCl, PredClTl, PredClAnn, PredClAnnTl) 785 ). 786accumulate_clauses(Term, AnnTerm, Module, Options, ClausePos, PredsSeen, 787 Size0, Pred0, PredPos0, PredCl0, PredClTl0, PredClAnn0, PredClAnnTl0, 788 Size, Pred, PredPos, PredCl, PredClTl, PredClAnn, PredClAnnTl) :- 789 accumulate_clauses([Term], [AnnTerm], Module, Options, ClausePos, PredsSeen, 790 Size0, Pred0, PredPos0, PredCl0, PredClTl0, PredClAnn0, PredClAnnTl0, 791 Size, Pred, PredPos, PredCl, PredClTl, PredClAnn, PredClAnnTl). 792 793 extract_pred((Head :- _), N/A) :- !, 794 ( var(Head) -> A=0 ; functor(Head, N, A) ). 795 extract_pred((Head ?- _), NA) :- !, 796 extract_pred((Head :- _), NA). 797 extract_pred(Fact, N/A) :- 798 functor(Fact, N, A). 799 800 801 802%---------------------------------------------------------------------- 803% Queries, directives and pragmas 804%---------------------------------------------------------------------- 805 806handle_nonclause(Class, Term, Ann, SourcePos1, Size0, Size, Options, PosModule, Module) :- 807 ( Class = directive -> 808 Size = Size0, 809 ( old_compiler_directive(Term, Options) -> 810 true 811 ; 812 process_directive(SourcePos1, Term, Options, PosModule) 813 ) 814 815 ; Class = query -> 816 Size = Size0, 817 process_query(SourcePos1, Term, Options, PosModule) 818 819 ; Class = handled_directive -> 820 ( consider_pragmas(Term, Options, PosModule) -> 821 Size = Size0, 822 emit_directive_or_query(Term, Options, PosModule) 823 ; handle_module_boundary(Term, Options, PosModule, SourcePos1, Module, Size0, Size) -> 824 emit_directive_or_query(Term, Options, PosModule) 825 ; Term = (:-meta_attribute(Name,Decls)) -> 826 % This is tricky and needs to be split in two: 827 % - syntax-relevant part: handled in source_processor, and also emitted as directive 828 % - handler part: turned into initialization directive to be executed after loading 829 Size = Size0, 830 meta_attribute_now_later(Decls, UrgentDecls, HandlerDecls), 831 emit_directive_or_query((:-meta_attribute(Name,UrgentDecls)), Options, PosModule), 832 process_directive(SourcePos1, (:-local initialization(meta_attribute(Name,HandlerDecls))), Options, PosModule) 833 ; 834 Size = Size0, 835 emit_directive_or_query(Term, Options, PosModule) 836 ) 837 838 ; (Class = var ; Class = other) -> 839 compiler_event(#illegal_head, SourcePos1, Ann, Term, Module), 840 Size = -1.0Inf 841 842 ; % Class = end_include,end 843 Size = Size0 844 ). 845 846 847process_directive(SourcePos, Term, Options, Module) :- 848 ( current_pragma(iso(strict))@Module, Term=(:-Dir) -> 849 % ISO directives may not be directly callable 850 ( iso_directive(Dir, QDir) -> 851 call_directive(SourcePos, (:-QDir), Options, Module), 852 emit_directive_or_query((:-QDir), Options, Module) 853 ; 854 compiler_error(_Ann, SourcePos, "Non-ISO directive (ignored) %w", [Term]) 855 ) 856 ; 857 call_directive(SourcePos, Term, Options, Module), 858 emit_directive_or_query(Term, Options, Module) 859 ). 860 861 862process_query(SourcePos, Term, Options, Module) :- 863 ( Options = options{load:all} -> 864 call_directive(SourcePos, Term, Options, Module) 865 ; 866 % new/none 867 true 868 ), 869 emit_directive_or_query(Term, Options, Module). 870 871 872call_directive(SourcePos, Dir, Options, Module) :- 873 arg(1, Dir, Goal), 874 block( 875 % negate the Goal - don't bind variables! 876 ( \+ call(Goal)@Module -> 877 compiler_warning(_Ann, SourcePos, "Query failed: %w", Dir, Options) 878 ; 879 true 880 ), 881 Tag, 882 compiler_error(_Ann, SourcePos, "Query exited (%w): %w", [Tag,Dir]) 883 ). 884 885 886% If we see the beginning of a new module, then finalize OldModule 887% (unless it is the compilation's context module, in which case this 888% is the first module directive we encounter) 889handle_module_boundary((:-module(Module,_,_)), Options, OldModule, SourcePos, TopModule, Size0, Size) ?- !, 890 handle_module_boundary((:-module(Module)), Options, OldModule, SourcePos, TopModule, Size0, Size). 891handle_module_boundary((:-module(_Module)), Options, OldModule, SourcePos, TopModule, Size0, Size) ?- !, 892 ( Options = options{load:none} -> 893 Size = Size0 894 ; OldModule == TopModule -> 895 Size = Size0 896 ; 897 compile_discontiguous_preds(OldModule, SourcePos, Options, Size0, Size), 898 error(#code_unit_loaded, [check], OldModule) 899 ). 900 901 902% Adjust compiler options according to pragmas 903 904consider_pragmas((:-pragma(Pragma)), Options, M) ?- 905 consider_pragma(Pragma, Options, M). 906 907consider_pragma(debug, Options, _) :- !, 908 setarg(debug of options, Options, on). 909consider_pragma(nodebug, Options, _) :- !, 910 setarg(debug of options, Options, off). 911consider_pragma(system, Options, _) :- !, 912 setarg(system of options, Options, on). 913consider_pragma(skip, Options, _) :- !, 914 setarg(skip of options, Options, on). 915consider_pragma(noskip, Options, _) :- !, 916 setarg(skip of options, Options, off). 917consider_pragma(warnings, Options, _) :- !, 918 setarg(warnings of options, Options, on). 919consider_pragma(nowarnings, Options, _) :- !, 920 setarg(warnings of options, Options, off). 921consider_pragma(expand, Options, _) :- !, 922 setarg(expand_goals of options, Options, on). 923consider_pragma(noexpand, Options, _) :- !, 924 setarg(expand_goals of options, Options, off). 925consider_pragma(opt_level(Level), Options, _) :- integer(Level), !, 926 setarg(opt_level of options, Options, Level). 927consider_pragma(Pragma, _, M) :- 928 error(#bad_pragma, pragma(Pragma), M). % make accessible via current_pragma/1 929 930 931% For compatibility with old compiler 932old_compiler_directive((:-system), Options) ?- !, 933 setarg(system of options, Options, on), 934 setarg(debug of options, Options, off), 935 setarg(skip of options, Options, on), 936 setarg(expand_goals of options, Options, on). 937old_compiler_directive((:-system_debug), Options) ?- !, 938 setarg(system of options, Options, on), 939 setarg(debug of options, Options, on), 940 setarg(skip of options, Options, off). 941old_compiler_directive((:-dbgcomp), Options) ?- !, 942 set_flag(debug_compile, on), 943 setarg(debug of options, Options, on). 944old_compiler_directive((:-nodbgcomp), Options) ?- !, 945 set_flag(debug_compile, off), 946 setarg(expand_goals of options, Options, on), 947 setarg(debug of options, Options, off). 948 949 950% Valid ISO-Prolog directives 951% We qualify those that are not built-ins 952iso_directive(dynamic(P), eclipse_language:dynamic(P)). 953iso_directive(multifile(P), multifile:multifile(P)). 954iso_directive(discontiguous(P), eclipse_language:discontiguous(P)). 955iso_directive(op(P,A,O), op(P,A,O)). 956iso_directive(char_conversion(X,Y), char_conversion(X,Y)). 957iso_directive(initialization(G), iso:initialization(G)). 958iso_directive(include(_), true). % already handled 959iso_directive(ensure_loaded(F), eclipse_language:ensure_loaded(F)). 960iso_directive(set_prolog_flag(F,V), set_prolog_flag(F,V)). 961 962 963% copy directives and queries to the eco file 964% omit comments and includes 965% do copy pragmas, since some of them have load-time effect 966% (e.g. suppress deprecation warnings) 967emit_directive_or_query((:-comment(_,_)), _Options, _Module) ?- !. 968emit_directive_or_query((:-include(_)), _Options, _Module) ?- !. 969emit_directive_or_query((:-[_|_]), _Options, _Module) ?- !. 970emit_directive_or_query(Dir, Options, Module) :- 971 numbervars(Dir, 0, _), 972 ( Options = options{output:print} -> 973 printf("%Iw.%n", [Dir]) 974 ; Options = options{output:print(Stream)} -> 975 printf(Stream, "%Iw.%n", [Dir]) 976 ; Options = options{output:eco_to_stream(Stream)} -> 977 printf(Stream, "%IODQKw.%n", [Dir])@Module 978 ; Options = options{output:asm_to_stream(Stream)} -> 979 printf(Stream, "%IDQKw.%n", [Dir])@Module 980 ; Options = options{output:none} -> 981 true 982 ; 983 Options = options{output:Junk}, 984 printf(error, "Invalid output option: %w%n", [Junk]), 985 abort 986 ), 987 fail. % to undo numbervars 988emit_directive_or_query(_, _, _). 989 990 991%---------------------------------------------------------------------- 992% Compile term/list 993%---------------------------------------------------------------------- 994 995:- export 996 compile_term/1, compile_term_/2, 997 compile_term/2, compile_term_/3, 998 compile_term_annotated/3, compile_term_annotated_/4. 999 1000:- tool(compile_term/1, compile_term_/2). 1001:- set_flag(compile_term/1, type, built_in). 1002compile_term_(Clauses, Module) :- 1003 compile_term_(Clauses, [], Module). 1004 1005 1006:- tool(compile_term/2, compile_term_/3). 1007:- set_flag(compile_term/2, type, built_in). 1008 1009compile_term_(List, OptionList, Module) :- 1010 compile_term_annotated_(List, _, OptionList, Module). 1011 1012:- tool(compile_term_annotated/3, compile_term_annotated_/4). 1013:- set_flag(compile_term_annotated/3, type, built_in). 1014 1015compile_term_annotated_(List, AnnList, OptionList, Module) :- 1016 compiler_options_setup('_term', OptionList, Options), 1017 hash_create(PredsSeen), 1018 % The subcall is needed to make coroutining in the compiler work, 1019 % and to give compiled queries a standard environment to run in. 1020 subcall(compile_list(List, AnnList, first, Clauses, Clauses, AnnC, AnnC, 1021 0, Size, PredsSeen, Options, Module), _Delays), 1022% compiler_options_cleanup(Options). % don't close files 1023 ( Size < 0 -> 1024 exit_block(abort) % because of errors during compile 1025 ; 1026 true 1027 ). 1028 1029 1030compile_list(Term, _, _, _, _, _, _, _, _, _PredsSeen, Options, Module) :- var(Term), !, 1031 error(#inst_fault, compile_term(Term, Options), Module). 1032compile_list([], _, Pred, Clauses, Tail, AnnC, AnnCTail, Size0, Size, PredsSeen, Options, _Module) :- !, 1033 Tail = [], 1034 AnnCTail = [], 1035 compile_predicate(Pred, Clauses, AnnC, term, PredsSeen, Options, Size1), 1036 Size is Size0+Size1. 1037compile_list([Term|Terms], AnnTermList, Pred, Clauses, Tail, AnnC, AnnCTail, Size0, Size, PredsSeen, Options, Module) :- !, 1038 (nonvar(AnnTermList) -> 1039 AnnTermList = annotated_term{term:[AnnTerm|AnnTerms]} 1040 ; 1041 true 1042 ), 1043 ( var(Term) -> 1044 error(#inst_fault, compile_term([Term|Terms], Options), Module) 1045 1046 ; Term = (:-_) -> 1047 % separator, compile the preceding predicate 1048 Tail = [], 1049 AnnCTail = [], 1050 compile_predicate(Pred, Clauses, AnnC, term, PredsSeen, Options, Size1), 1051 Size2 is Size0+Size1, 1052 % unlike compile(file), interpret only pragmas, 1053 % not directives like module/1, include/1, etc 1054 ( consider_pragmas(Term, Options, Module) -> 1055 true 1056 ; 1057 process_directive(no_source, Term, Options, Module) 1058 ), 1059 compile_list(Terms, AnnTerms, none, Clauses1, Clauses1, 1060 AnnC1, AnnC1, Size2, Size, PredsSeen, Options, Module) 1061 1062 ; Term = (?-_) -> 1063 % separator, compile the preceding predicate 1064 Tail = [], 1065 AnnCTail = [], 1066 compile_predicate(Pred, Clauses, AnnC, term, PredsSeen, Options, Size1), 1067 Size2 is Size0+Size1, 1068 process_query(no_source, Term, Options, Module), 1069 compile_list(Terms, AnnTerms, none, Clauses1, Clauses1, 1070 AnnC1, AnnC1, Size2, Size, PredsSeen, Options, Module) 1071 ; callable(Term) -> 1072 optional_clause_expansion(Term, AnnTerm, TransTerm, AnnTrans, Options, Module), 1073 % TransTerm may be a list of clauses! 1074 accumulate_clauses(TransTerm, AnnTrans, Module, Options, term, PredsSeen, 1075 Size0, Pred, term, Clauses, Tail, AnnC, AnnCTail, 1076 Size1, Pred1, _Pos, Clauses1, Tail1, AnnC1, AnnCTail1), 1077 compile_list(Terms, AnnTerms, Pred1, Clauses1, Tail1, 1078 AnnC1, AnnCTail1, Size1, Size, PredsSeen, Options, Module) 1079 ; 1080 ( block(compiler_event(#illegal_head, term, AnnTerm, Term, Module), abort_compile_predicate, true) -> true ; true ), 1081 Size = -1.0Inf 1082 ). 1083compile_list(Term, AnnTerm, Pred, Clauses, Tail, AnnC, AnnCTail, Size0, Size, PredsSeen, Options, Module) :- 1084 ( Pred == first -> 1085 % allow to omit list brackets for single term 1086 (nonvar(AnnTerm) -> 1087 AnnTermList = annotated_term{term:[annotated_term{term:AnnTerm}|annotated_term{term:[]}]} 1088 ; 1089 true 1090 ), 1091 compile_list([Term], AnnTermList, none, Clauses, Tail, AnnC, AnnCTail, Size0, Size, PredsSeen, Options, Module) 1092 ; 1093 error(#type_error, compile_term(Term, Options), Module) 1094 ). 1095 1096 1097 optional_clause_expansion(Term, AnnTerm, TransTerm, AnnTransTerm, options{expand_clauses:CFlag}, Module) :- 1098 ( CFlag == on -> 1099 expand_clause_annotated(Term, AnnTerm, TransTerm, AnnTransTerm)@Module 1100 ; 1101 TransTerm=Term, AnnTransTerm=AnnTerm 1102 ). 1103 1104