for review: nondet pragma C codes (part 1 of 2)
Zoltan Somogyi
zs at cs.mu.oz.au
Fri Jan 9 13:55:36 AEDT 1998
Fergus or DJ should review this.
The update of the reference manual and test cases to follow.
Estimated hours taken: 40
Implement nondet pragma C codes.
runtime/mercury_stacks.h:
Define a new macro, mkpragmaframe, for use in the implementation
of nondet pragma C codes. This new macro includes space for a
struct with a given sruct tag in the nondet stack frame being created.
compiler/{prog_data.m,hlds_goal.m}:
Revise the representation of pragma C codes, both as the item and
in the HLDS.
compiler/prog_io_pragma.m:
Parse nondet pragma C declarations.
Fix the indentation in some places.
compiler/llds.m:
Include an extra argument in mkframe instructions. This extra argument
gives the details of the C structure (if any) to be included in the
nondet stack frame to be created.
Generalize the LLDS representation of pragma C codes. Instead of a
fixed sequence of <assign from inputs, user c code, assign to outputs>,
let the sequence contain these elements, as well as arbitrary
compiler-generated C code, in any order and possibly with repetitions.
This flexibility is needed for nondet pragma C codes.
Add a field to pragma C codes to say whether they can call Mercury.
Some optimizations can do a better job if they know that a pragma C
code cannot call Mercury.
Add another field to pragma C codes to give the name of the label
they refer to (if any). This is needed to prevent labelopt from
incorrectly optimizing away the label definition.
Add a new alternative to the type pragma_c_decl, to describe the
declaration of the local variable that points to the save struct.
compiler/llds_out.m:
Output mkframe instructions that specify a struct as invoking the new
mkpragmaframe macro, and make sure that the struct is declared just
before the procedure that uses it.
Other minor changes to keep up with the changes to the representation
of pragma C code in the LLDS, and to make the output look a bit nicer.
compiler/pragma_c_gen.m:
Add code to generate code for nondet pragma C codes. Revise the utility
predicates and their data structures a bit to make this possible.
compiler/code_gen.m:
Add code for the necessary special handling of prologs and epilogs
of procedures defined by nondet pragma C codes. The prologs need
to be modified to include a programmer-defined C structure in the
nondet stack frame and to communicate the location of this structure
to the pragma C code, whereas the functionality of the epilog is
taken care of by the pragma C code itself.
compiler/make_hlds.m:
When creating a proc_info for a procedure defined by a pragma C code,
we used to insert unifications between the headvars and the vars of
the pragma C code into the body goal. We now perform substitutions
instead. This removes a factor that would complicate the generation
of code for nondet pragma C codes.
Pass a moduleinfo down the procedures that warn about singletons
(and other basic scope errors). When checking whether to warn about
an argument of a pragma C code not being mentioned in the C code
fragment, we need to know whether the argument is input or output,
since input variables should appear in some code fragments in a
nondet pragma C code and must not appear in others. The
mode_is_{in,out}put checks need the moduleinfo.
(We do not need to check for any variables being mentioned where
they shouldn't be. The C compiler will fail in the presence of any
errors of that type, and since those variables could be referred
to via macros whose definitions we do not see, we couldn't implement
a reliable test anyway.)
compiler/opt_util.m:
Recognize that some sorts of pragma_c codes cannot affect the data
structures that control backtracking. This allows peepholing to
do a better job on code sequences produced for nondet pragma C codes.
Recognize that the C code strings inside some pragma_c codes refer to
other labels in the procedure. This prevents labelopt from incorrectly
optimizing away these labels.
compiler/dupelim.m:
If a label is referred to from within a C code string, then do not
attempt to optimize it away.
compiler/det_analysis.m:
Remove a now incorrect part of an error message.
compiler/{mercury_compile.m,modules.m}:
Add a missing period after some progress messages.
compiler/*.m:
Minor changes to conform to changes to the HLDS and LLDS data
structures.
compiler/Mmakefile:
Incidental change: add a new target "debug" that makes both the
compiled and the SICStus versions of the compiler.
Zoltan.
cvs diff: Diffing .
cvs diff: Diffing bindist
cvs diff: Diffing boehm_gc
cvs diff: Diffing boehm_gc/Mac_files
cvs diff: Diffing boehm_gc/cord
cvs diff: Diffing boehm_gc/cord/private
cvs diff: Diffing boehm_gc/include
cvs diff: Diffing boehm_gc/include/private
cvs diff: Diffing bytecode
cvs diff: Diffing bytecode/test
cvs diff: Diffing compiler
Index: compiler/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/Mmakefile,v
retrieving revision 1.6
diff -u -u -r1.6 Mmakefile
--- Mmakefile 1997/11/06 06:19:02 1.6
+++ Mmakefile 1998/01/04 11:21:01
@@ -60,19 +60,22 @@
# mercury_compile.sicstus.debug
.PHONY: depend
-depend : mercury_compile.depend
+depend: mercury_compile.depend
.PHONY: all
-all : mercury nuprolog sicstus
+all: mercury nuprolog sicstus
.PHONY: mercury
-mercury: mercury_compile
+mercury: mercury_compile
.PHONY: nuprolog
-nuprolog: mercury_compile.nu
+nuprolog: mercury_compile.nu
.PHONY: sicstus
-sicstus: mercury_compile.sicstus
+sicstus: mercury_compile.sicstus
+
+.PHONY: debug
+debug: mercury_compile mercury_compile.sicstus.debug
#-----------------------------------------------------------------------------#
Index: compiler/basic_block.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/basic_block.m,v
retrieving revision 1.1
diff -u -u -r1.1 basic_block.m
--- basic_block.m 1997/12/22 06:58:00 1.1
+++ basic_block.m 1998/01/06 08:23:20
@@ -160,7 +160,7 @@
;
Labels = []
).
-possible_targets(mkframe(_, _, _), []).
+possible_targets(mkframe(_, _, _, _), []).
possible_targets(modframe(_), []).
possible_targets(label(_), []).
possible_targets(goto(CodeAddr), Targets) :-
@@ -187,7 +187,7 @@
possible_targets(discard_tickets_to(_), []).
possible_targets(incr_sp(_, _), []).
possible_targets(decr_sp(_), []).
-possible_targets(pragma_c(_, _, _, _, _), []).
+possible_targets(pragma_c(_, _, _, _), []).
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
Index: compiler/bytecode_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/bytecode_gen.m,v
retrieving revision 1.32
diff -u -u -r1.32 bytecode_gen.m
--- bytecode_gen.m 1997/12/22 09:55:21 1.32
+++ bytecode_gen.m 1998/01/02 05:03:30
@@ -240,7 +240,7 @@
tree(ElseCode,
EndofIfCode))))))
;
- GoalExpr = pragma_c_code(_, _, _, _, _, _, _, _),
+ GoalExpr = pragma_c_code(_, _, _, _, _, _, _),
Code = node([not_supported]),
ByteInfo = ByteInfo0
).
Index: compiler/code_aux.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/code_aux.m,v
retrieving revision 1.50
diff -u -u -r1.50 code_aux.m
--- code_aux.m 1997/09/01 14:00:25 1.50
+++ code_aux.m 1998/01/02 05:03:35
@@ -170,7 +170,7 @@
code_aux__goal_is_flat_2(higher_order_call(_, _, _, _, _, _)).
code_aux__goal_is_flat_2(call(_, _, _, _, _, _)).
code_aux__goal_is_flat_2(unify(_, _, _, _, _)).
-code_aux__goal_is_flat_2(pragma_c_code(_, _, _, _, _, _, _, _)).
+code_aux__goal_is_flat_2(pragma_c_code(_, _, _, _, _, _, _)).
%-----------------------------------------------------------------------------%
Index: compiler/code_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/code_gen.m,v
retrieving revision 1.42
diff -u -u -r1.42 code_gen.m
--- code_gen.m 1997/12/22 09:55:23 1.42
+++ code_gen.m 1998/01/08 06:57:42
@@ -166,9 +166,15 @@
% and when massaging the code generated for the procedure.
:- type frame_info ---> frame(
- int, % number of slots in frame
- maybe(int) % slot number of succip
+ int, % Number of slots in frame.
+
+ maybe(int), % Slot number of succip
% if succip is present
+ % in a general slot.
+
+ bool % Is this the frame of a
+ % model_non proc defined
+ % via pragma C code?
).
%---------------------------------------------------------------------------%
@@ -220,7 +226,7 @@
% now the code is a list of code fragments (== list(instr)),
% so we need to do a level of unwinding to get a flat list.
list__condense(FragmentList, Instructions0),
- FrameInfo = frame(TotalSlots, MaybeSuccipSlot),
+ FrameInfo = frame(TotalSlots, MaybeSuccipSlot, _),
(
MaybeSuccipSlot = yes(SuccipSlot)
->
@@ -257,7 +263,7 @@
middle_rec__match_and_generate(Goal, MiddleRecCode)
->
{ Code = MiddleRecCode },
- { FrameInfo = frame(0, no) }
+ { FrameInfo = frame(0, no, no) }
;
% make a new failure cont (not model_non);
% this continuation is never actually used,
@@ -267,7 +273,8 @@
code_gen__generate_goal(model_det, Goal, BodyCode),
code_info__get_instmap(Instmap),
- code_gen__generate_prolog(model_det, FrameInfo, PrologCode),
+ code_gen__generate_prolog(model_det, Goal, FrameInfo,
+ PrologCode),
(
{ instmap__is_reachable(Instmap) }
->
@@ -286,7 +293,7 @@
% generate the code for the body of the clause
code_gen__generate_goal(model_semi, Goal, BodyCode),
- code_gen__generate_prolog(model_semi, FrameInfo, PrologCode),
+ code_gen__generate_prolog(model_semi, Goal, FrameInfo, PrologCode),
code_gen__generate_epilog(model_semi, FrameInfo, EpilogCode),
{ Code = tree(PrologCode, tree(BodyCode, EpilogCode)) }.
@@ -303,11 +310,12 @@
% generate the code for the body of the clause
code_info__push_resume_point_vars(ResumeVars),
code_gen__generate_goal(model_non, Goal, BodyCode),
- code_gen__generate_prolog(model_non, FrameInfo, PrologCode),
+ code_gen__generate_prolog(model_non, Goal, FrameInfo,
+ PrologCode),
code_gen__generate_epilog(model_non, FrameInfo, EpilogCode),
- code_info__pop_resume_point_vars,
{ MainCode = tree(PrologCode, tree(BodyCode, EpilogCode)) },
+ code_info__pop_resume_point_vars,
code_info__restore_failure_cont(RestoreCode),
trace__generate_event_code(fail, TraceInfo, TraceEventCode),
code_info__generate_failure(FailCode),
@@ -321,7 +329,8 @@
;
% generate the code for the body of the clause
code_gen__generate_goal(model_non, Goal, BodyCode),
- code_gen__generate_prolog(model_non, FrameInfo, PrologCode),
+ code_gen__generate_prolog(model_non, Goal, FrameInfo,
+ PrologCode),
code_gen__generate_epilog(model_non, FrameInfo, EpilogCode),
{ Code = tree(PrologCode, tree(BodyCode, EpilogCode)) }
).
@@ -346,11 +355,11 @@
% need a stack frame, and if the procedure is nondet, then the code
% to fill in the succip slot is subsumed by the mkframe.
-:- pred code_gen__generate_prolog(code_model, frame_info, code_tree,
+:- pred code_gen__generate_prolog(code_model, hlds_goal, frame_info, code_tree,
code_info, code_info).
-:- mode code_gen__generate_prolog(in, out, out, in, out) is det.
+:- mode code_gen__generate_prolog(in, in, out, out, in, out) is det.
-code_gen__generate_prolog(CodeModel, FrameInfo, PrologCode) -->
+code_gen__generate_prolog(CodeModel, Goal, FrameInfo, PrologCode) -->
code_info__get_stack_slots(StackSlots),
code_info__get_varset(VarSet),
{ code_aux__explain_stack_slots(StackSlots, VarSet, SlotsComment) },
@@ -386,7 +395,6 @@
{ TotalSlots = MainSlots },
{ MaybeSuccipSlot = no }
),
- { FrameInfo = frame(TotalSlots, MaybeSuccipSlot) },
code_info__get_maybe_trace_info(MaybeTraceInfo),
( { MaybeTraceInfo = yes(TraceInfo) } ->
{ trace__generate_slot_fill_code(TraceInfo, TraceFillCode) },
@@ -404,20 +412,47 @@
(
{ CodeModel = model_non }
->
- { AllocCode = node([
- mkframe(PushMsg, TotalSlots, do_fail) -
- "Allocate stack frame"
- ]) }
+ (
+ { Goal = pragma_c_code(_,_,_,_,_,_, PragmaCode) - _},
+ { PragmaCode = nondet(Fields, FieldsContext,
+ _,_,_,_,_,_,_) }
+ ->
+ { pragma_c_gen__struct_name(ModuleName, PredName,
+ Arity, ProcId, StructName) },
+ { Struct = pragma_struct(StructName,
+ Fields, FieldsContext) },
+ { string__format("#define\tMR_ORDINARY_SLOTS\t%d\n",
+ [i(TotalSlots)], DefineStr) },
+ { DefineComps = [pragma_c_raw_code(DefineStr)] },
+ { AllocCode = node([
+ mkframe(PushMsg, TotalSlots, yes(Struct),
+ do_fail)
+ - "Allocate stack frame",
+ pragma_c([], DefineComps,
+ will_not_call_mercury, no)
+ - ""
+ ]) },
+ { NondetPragma = yes }
+ ;
+ { AllocCode = node([
+ mkframe(PushMsg, TotalSlots, no, do_fail) -
+ "Allocate stack frame"
+ ]) },
+ { NondetPragma = no }
+ )
;
{ TotalSlots > 0 }
->
{ AllocCode = node([
incr_sp(TotalSlots, PushMsg) -
"Allocate stack frame"
- ]) }
+ ]) },
+ { NondetPragma = no }
;
- { AllocCode = empty }
+ { AllocCode = empty },
+ { NondetPragma = no }
),
+ { FrameInfo = frame(TotalSlots, MaybeSuccipSlot, NondetPragma) },
{ EndComment = node([
comment("End of procedure prologue") - ""
]) },
@@ -462,6 +497,11 @@
% Not all frames will have all these components. For example, for
% nondet procedures we don't deallocate the stack frame before
% success.
+ %
+ % Epilogs for procedures defined by nondet pragma C codes do not
+ % follow the rules above. For such procedures, the normal functions
+ % of the epilog are handled when traversing the pragma C code goal;
+ % we need only #undef a macro defined by the procedure prolog.
:- pred code_gen__generate_epilog(code_model, frame_info, code_tree,
code_info, code_info).
@@ -471,112 +511,130 @@
{ StartComment = node([
comment("Start of procedure epilogue") - ""
]) },
- code_info__get_instmap(Instmap),
- code_info__get_arginfo(ArgModes),
- code_info__get_headvars(HeadVars),
- { assoc_list__from_corresponding_lists(HeadVars, ArgModes, Args)},
- (
- { instmap__is_unreachable(Instmap) }
- ->
- { FlushCode = empty }
- ;
- code_info__setup_call(Args, callee, FlushCode)
- ),
- { FrameInfo = frame(TotalSlots, MaybeSuccipSlot) },
- (
- { MaybeSuccipSlot = yes(SuccipSlot) }
- ->
- { RestoreSuccipCode = node([
- assign(succip, lval(stackvar(SuccipSlot))) -
- "restore the success ip"
- ]) }
- ;
- { RestoreSuccipCode = empty }
- ),
- (
- { TotalSlots = 0 ; CodeModel = model_non }
- ->
- { DeallocCode = empty }
+ { EndComment = node([
+ comment("End of procedure epilogue") - ""
+ ]) },
+ { FrameInfo = frame(TotalSlots, MaybeSuccipSlot, NondetPragma) },
+ ( { NondetPragma = yes } ->
+ { UndefStr = "#undef\tMR_ORDINARY_SLOTS\n" },
+ { UndefComps = [pragma_c_raw_code(UndefStr)] },
+ { UndefCode = node([
+ pragma_c([], UndefComps,
+ will_not_call_mercury, no)
+ - ""
+ ]) },
+ { EpilogCode =
+ tree(StartComment,
+ tree(UndefCode,
+ EndComment))
+ }
;
- { DeallocCode = node([
- decr_sp(TotalSlots) - "Deallocate stack frame"
- ]) }
- ),
- { RestoreDeallocCode = tree(RestoreSuccipCode, DeallocCode ) },
- { code_gen__output_args(Args, LiveArgs) },
- code_info__get_maybe_trace_info(MaybeTraceInfo),
- ( { MaybeTraceInfo = yes(TraceInfo) } ->
- trace__generate_event_code(exit, TraceInfo, SuccessTraceCode),
- ( { CodeModel = model_semi } ->
- trace__generate_event_code(fail, TraceInfo,
- FailureTraceCode)
+ code_info__get_instmap(Instmap),
+ code_info__get_arginfo(ArgModes),
+ code_info__get_headvars(HeadVars),
+ { assoc_list__from_corresponding_lists(HeadVars, ArgModes,
+ Args)},
+ (
+ { instmap__is_unreachable(Instmap) }
+ ->
+ { FlushCode = empty }
+ ;
+ code_info__setup_call(Args, callee, FlushCode)
+ ),
+ (
+ { MaybeSuccipSlot = yes(SuccipSlot) }
+ ->
+ { RestoreSuccipCode = node([
+ assign(succip, lval(stackvar(SuccipSlot))) -
+ "restore the success ip"
+ ]) }
+ ;
+ { RestoreSuccipCode = empty }
+ ),
+ (
+ { TotalSlots = 0 ; CodeModel = model_non }
+ ->
+ { DeallocCode = empty }
;
+ { DeallocCode = node([
+ decr_sp(TotalSlots) - "Deallocate stack frame"
+ ]) }
+ ),
+ { RestoreDeallocCode = tree(RestoreSuccipCode, DeallocCode ) },
+ { code_gen__output_args(Args, LiveArgs) },
+ code_info__get_maybe_trace_info(MaybeTraceInfo),
+ ( { MaybeTraceInfo = yes(TraceInfo) } ->
+ trace__generate_event_code(exit, TraceInfo,
+ SuccessTraceCode),
+ ( { CodeModel = model_semi } ->
+ trace__generate_event_code(fail, TraceInfo,
+ FailureTraceCode)
+ ;
+ { FailureTraceCode = empty }
+ )
+ ;
+ { SuccessTraceCode = empty },
{ FailureTraceCode = empty }
- )
- ;
- { SuccessTraceCode = empty },
- { FailureTraceCode = empty }
- ),
- (
- { CodeModel = model_det },
- { SuccessCode = node([
- livevals(LiveArgs) - "",
- goto(succip) - "Return from procedure call"
- ]) },
- { AllSuccessCode =
- tree(SuccessTraceCode,
- tree(RestoreDeallocCode,
- SuccessCode))
- },
- { AllFailureCode = empty }
- ;
- { CodeModel = model_semi },
- code_info__restore_failure_cont(ResumeCode),
- { set__insert(LiveArgs, reg(r, 1), SuccessLiveRegs) },
- { SuccessCode = node([
- assign(reg(r, 1), const(true)) - "Succeed",
- livevals(SuccessLiveRegs) - "",
- goto(succip) - "Return from procedure call"
- ]) },
- { AllSuccessCode =
- tree(SuccessTraceCode,
- tree(RestoreDeallocCode,
- SuccessCode))
- },
- { set__singleton_set(FailureLiveRegs, reg(r, 1)) },
- { FailureCode = node([
- assign(reg(r, 1), const(false)) - "Fail",
- livevals(FailureLiveRegs) - "",
- goto(succip) - "Return from procedure call"
- ]) },
- { AllFailureCode =
- tree(ResumeCode,
- tree(FailureTraceCode,
- tree(RestoreDeallocCode,
- FailureCode)))
+ ),
+ (
+ { CodeModel = model_det },
+ { SuccessCode = node([
+ livevals(LiveArgs) - "",
+ goto(succip) - "Return from procedure call"
+ ]) },
+ { AllSuccessCode =
+ tree(SuccessTraceCode,
+ tree(RestoreDeallocCode,
+ SuccessCode))
+ },
+ { AllFailureCode = empty }
+ ;
+ { CodeModel = model_semi },
+ code_info__restore_failure_cont(ResumeCode),
+ { set__insert(LiveArgs, reg(r, 1), SuccessLiveRegs) },
+ { SuccessCode = node([
+ assign(reg(r, 1), const(true)) - "Succeed",
+ livevals(SuccessLiveRegs) - "",
+ goto(succip) - "Return from procedure call"
+ ]) },
+ { AllSuccessCode =
+ tree(SuccessTraceCode,
+ tree(RestoreDeallocCode,
+ SuccessCode))
+ },
+ { set__singleton_set(FailureLiveRegs, reg(r, 1)) },
+ { FailureCode = node([
+ assign(reg(r, 1), const(false)) - "Fail",
+ livevals(FailureLiveRegs) - "",
+ goto(succip) - "Return from procedure call"
+ ]) },
+ { AllFailureCode =
+ tree(ResumeCode,
+ tree(FailureTraceCode,
+ tree(RestoreDeallocCode,
+ FailureCode)))
+ }
+ ;
+ { CodeModel = model_non },
+ { SuccessCode = node([
+ livevals(LiveArgs) - "",
+ goto(do_succeed(no))
+ - "Return from procedure call"
+ ]) },
+ { AllSuccessCode =
+ tree(SuccessTraceCode,
+ SuccessCode)
+ },
+ { AllFailureCode = empty }
+ ),
+ { EpilogCode =
+ tree(StartComment,
+ tree(FlushCode,
+ tree(AllSuccessCode,
+ tree(AllFailureCode,
+ EndComment))))
}
- ;
- { CodeModel = model_non },
- { SuccessCode = node([
- livevals(LiveArgs) - "",
- goto(do_succeed(no)) - "Return from procedure call"
- ]) },
- { AllSuccessCode =
- tree(SuccessTraceCode,
- SuccessCode)
- },
- { AllFailureCode = empty }
- ),
- { EndComment = node([
- comment("End of procedure epilogue") - ""
- ]) },
- { EpilogCode =
- tree(StartComment,
- tree(FlushCode,
- tree(AllSuccessCode,
- tree(AllFailureCode,
- EndComment))))
- }.
+ ).
%---------------------------------------------------------------------------%
@@ -739,18 +797,12 @@
{ error("generate_det_goal_2: cannot have det simple_test") }
).
-code_gen__generate_det_goal_2(pragma_c_code(C_Code, MayCallMercury,
- PredId, ModeId, Args, ArgNames, OrigArgTypes, Extra),
+code_gen__generate_det_goal_2(pragma_c_code(MayCallMercury,
+ PredId, ModeId, Args, ArgNames, OrigArgTypes, PragmaCode),
GoalInfo, Instr) -->
- (
- { Extra = none },
- pragma_c_gen__generate_pragma_c_code(model_det, C_Code,
- MayCallMercury, PredId, ModeId, Args, ArgNames,
- OrigArgTypes, GoalInfo, Instr)
- ;
- { Extra = extra_pragma_info(_, _) },
- { error("det pragma has non-empty extras field") }
- ).
+ pragma_c_gen__generate_pragma_c_code(model_det, MayCallMercury,
+ PredId, ModeId, Args, ArgNames, OrigArgTypes, GoalInfo,
+ PragmaCode, Instr).
%---------------------------------------------------------------------------%
@@ -829,18 +881,12 @@
{ error("code_gen__generate_semi_goal_2 - complicated_unify") }
).
-code_gen__generate_semi_goal_2(pragma_c_code(C_Code, MayCallMercury,
- PredId, ModeId, Args, ArgNameMap, OrigArgTypes, Extra),
+code_gen__generate_semi_goal_2(pragma_c_code(MayCallMercury,
+ PredId, ModeId, Args, ArgNames, OrigArgTypes, PragmaCode),
GoalInfo, Instr) -->
- (
- { Extra = none },
- pragma_c_gen__generate_pragma_c_code(model_semi, C_Code,
- MayCallMercury, PredId, ModeId, Args, ArgNameMap,
- OrigArgTypes, GoalInfo, Instr)
- ;
- { Extra = extra_pragma_info(_, _) },
- { error("semidet pragma has non-empty extras field") }
- ).
+ pragma_c_gen__generate_pragma_c_code(model_semi, MayCallMercury,
+ PredId, ModeId, Args, ArgNames, OrigArgTypes, GoalInfo,
+ PragmaCode, Instr).
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
@@ -1017,26 +1063,12 @@
code_gen__generate_non_goal_2(unify(_L, _R, _U, _Uni, _C),
_GoalInfo, _Code) -->
{ error("Cannot have a nondet unification.") }.
-code_gen__generate_non_goal_2(pragma_c_code(C_Code, MayCallMercury,
- PredId, ModeId, Args, ArgNameMap, OrigArgTypes, Extra),
+code_gen__generate_non_goal_2(pragma_c_code(MayCallMercury,
+ PredId, ModeId, Args, ArgNames, OrigArgTypes, PragmaCode),
GoalInfo, Instr) -->
- (
- { Extra = none },
- % Error disabled for bootstrapping. string.m uses this form,
- % and we can't change it to the new form until the new form
- % is completed, and even then we must wait until that compiler
- % is installed on all our machines.
- % { error("nondet pragma has empty extras field") }
- pragma_c_gen__generate_pragma_c_code(model_semi, C_Code,
- MayCallMercury, PredId, ModeId, Args, ArgNameMap,
- OrigArgTypes, GoalInfo, Instr)
- ;
- { Extra = extra_pragma_info(SavedVars, LabelNames) },
- pragma_c_gen__generate_backtrack_pragma_c_code(model_semi,
- C_Code, MayCallMercury, PredId, ModeId, Args,
- ArgNameMap, OrigArgTypes, SavedVars, LabelNames,
- GoalInfo, Instr)
- ).
+ pragma_c_gen__generate_pragma_c_code(model_non, MayCallMercury,
+ PredId, ModeId, Args, ArgNames, OrigArgTypes, GoalInfo,
+ PragmaCode, Instr).
%---------------------------------------------------------------------------%
Index: compiler/code_info.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/code_info.m,v
retrieving revision 1.214
diff -u -u -r1.214 code_info.m
--- code_info.m 1997/12/19 03:06:01 1.214
+++ code_info.m 1998/01/01 06:08:20
@@ -1251,7 +1251,7 @@
% this code could be better
% (mkframe is a bit of a sledge hammer)
{ TempFrameCode = node([
- mkframe("temp frame", 1, RedoAddr)
+ mkframe("temp frame", 1, no, RedoAddr)
- "create a temporary frame",
assign(curfr, lval(succfr(lval(maxfr))))
- "restore curfr after mkframe"
Index: compiler/code_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/code_util.m,v
retrieving revision 1.90
diff -u -u -r1.90 code_util.m
--- code_util.m 1997/12/19 03:06:04 1.90
+++ code_util.m 1998/01/02 04:35:42
@@ -774,8 +774,8 @@
code_util__count_recursive_calls_2(higher_order_call(_, _,_, _, _, _), _, _,
0, 0).
code_util__count_recursive_calls_2(class_method_call(_, _,_, _, _, _), _, _,
- 0, 0).
-code_util__count_recursive_calls_2(pragma_c_code(_,_,_,_, _, _, _, _), _, _,
+ 0, 0).
+code_util__count_recursive_calls_2(pragma_c_code(_,_,_, _, _, _, _), _, _,
0, 0).
code_util__count_recursive_calls_2(call(CallPredId, CallProcId, _, _, _, _),
PredId, ProcId, Count, Count) :-
Index: compiler/constraint.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/constraint.m,v
retrieving revision 1.38
diff -u -u -r1.38 constraint.m
--- constraint.m 1998/01/05 07:26:12 1.38
+++ constraint.m 1998/01/08 03:02:27
@@ -195,8 +195,8 @@
mode_checkpoint(exit, "unify").
constraint__propagate_goal_2(
- pragma_c_code(A, B, C, D, E, F, G, H),
- pragma_c_code(A, B, C, D, E, F, G, H)) -->
+ pragma_c_code(A, B, C, D, E, F, G),
+ pragma_c_code(A, B, C, D, E, F, G)) -->
mode_checkpoint(enter, "pragma_c_code"),
mode_checkpoint(exit, "pragma_c_code").
Index: compiler/cse_detection.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/cse_detection.m,v
retrieving revision 1.51
diff -u -u -r1.51 cse_detection.m
--- cse_detection.m 1998/01/05 07:26:13 1.51
+++ cse_detection.m 1998/01/08 03:02:28
@@ -201,8 +201,8 @@
cse_info, cse_info, bool, hlds_goal_expr).
:- mode detect_cse_in_goal_2(in, in, in, in, out, out, out) is det.
-detect_cse_in_goal_2(pragma_c_code(A,B,C,D,E,F,G,H), _, _, CseInfo, CseInfo,
- no, pragma_c_code(A,B,C,D,E,F,G,H)).
+detect_cse_in_goal_2(pragma_c_code(A,B,C,D,E,F,G), _, _, CseInfo, CseInfo,
+ no, pragma_c_code(A,B,C,D,E,F,G)).
detect_cse_in_goal_2(higher_order_call(A,B,C,D,E,F), _, _, CseInfo, CseInfo,
no, higher_order_call(A,B,C,D,E,F)).
Index: compiler/dead_proc_elim.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/dead_proc_elim.m,v
retrieving revision 1.33
diff -u -u -r1.33 dead_proc_elim.m
--- dead_proc_elim.m 1997/12/19 03:06:11 1.33
+++ dead_proc_elim.m 1998/01/02 04:36:07
@@ -456,7 +456,7 @@
NewNotation = yes(1),
map__set(Needed0, proc(PredId, ProcId), NewNotation, Needed)
).
-dead_proc_elim__examine_expr(pragma_c_code(_, _, PredId, ProcId, _, _, _, _),
+dead_proc_elim__examine_expr(pragma_c_code(_, PredId, ProcId, _, _, _, _),
_CurrProc, Queue0, Queue, Needed0, Needed) :-
queue__put(Queue0, proc(PredId, ProcId), Queue),
map__set(Needed0, proc(PredId, ProcId), no, Needed).
@@ -761,7 +761,7 @@
pre_modecheck_examine_goal(Goal).
pre_modecheck_examine_goal(call(_, _, _, _, _, PredName) - _) -->
dead_pred_info_add_pred_name(PredName).
-pre_modecheck_examine_goal(pragma_c_code(_, _, _, _, _, _, _, _) - _) --> [].
+pre_modecheck_examine_goal(pragma_c_code(_, _, _, _, _, _, _) - _) --> [].
pre_modecheck_examine_goal(unify(_, Rhs, _, _, _) - _) -->
pre_modecheck_examine_unify_rhs(Rhs).
Index: compiler/dependency_graph.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/dependency_graph.m,v
retrieving revision 1.33
diff -u -u -r1.33 dependency_graph.m
--- dependency_graph.m 1998/01/01 06:27:34 1.33
+++ dependency_graph.m 1998/01/02 05:04:07
@@ -253,7 +253,7 @@
).
% There can be no dependencies within a pragma_c_code
-dependency_graph__add_arcs_in_goal_2(pragma_c_code(_, _, _, _, _, _, _, _), _,
+dependency_graph__add_arcs_in_goal_2(pragma_c_code(_, _, _, _, _, _, _), _,
DepGraph, DepGraph).
%-----------------------------------------------------------------------------%
Index: compiler/det_analysis.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/det_analysis.m,v
retrieving revision 1.126
diff -u -u -r1.126 det_analysis.m
--- det_analysis.m 1997/12/22 09:55:30 1.126
+++ det_analysis.m 1998/01/06 07:27:22
@@ -616,19 +616,19 @@
Goal, Det, Msgs).
% pragma c_codes are handled in the same way as predicate calls
-det_infer_goal_2(pragma_c_code(C_Code, IsRecursive, PredId, ProcId, Args,
- ArgNameMap, OrigArgTypes, Extra),
+det_infer_goal_2(pragma_c_code(IsRecursive, PredId, ProcId, Args,
+ ArgNameMap, OrigArgTypes, PragmaCode),
GoalInfo, _, SolnContext, DetInfo, _, _,
- pragma_c_code(C_Code, IsRecursive, PredId, ProcId, Args,
- ArgNameMap, OrigArgTypes, Extra),
+ pragma_c_code(IsRecursive, PredId, ProcId, Args,
+ ArgNameMap, OrigArgTypes, PragmaCode),
Detism, Msgs) :-
det_info_get_module_info(DetInfo, ModuleInfo),
module_info_pred_proc_info(ModuleInfo, PredId, ProcId, _, ProcInfo),
proc_info_declared_determinism(ProcInfo, MaybeDetism),
( MaybeDetism = yes(Detism0) ->
determinism_components(Detism0, CanFail, NumSolns0),
- ( Extra = extra_pragma_info(_, _) ->
- % pragma C codes that specify saved variables and labels
+ ( PragmaCode = nondet(_, _, _, _, _, _, _, _, _) ->
+ % pragma C codes of this form
% can have more than one solution
NumSolns1 = at_most_many
;
Index: compiler/det_report.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/det_report.m,v
retrieving revision 1.46
diff -u -u -r1.46 det_report.m
--- det_report.m 1997/12/22 09:55:32 1.46
+++ det_report.m 1998/01/02 06:12:18
@@ -539,7 +539,7 @@
det_diagnose_goal(Goal, InternalDesired, SwitchContext, DetInfo,
Diagnosed).
-det_diagnose_goal_2(pragma_c_code(_, _, _, _, _, _, _, _), GoalInfo, Desired,
+det_diagnose_goal_2(pragma_c_code(_, _, _, _, _, _, _), GoalInfo, Desired,
_, _, _, yes) -->
{ goal_info_get_context(GoalInfo, Context) },
prog_out__write_context(Context),
@@ -547,12 +547,12 @@
prog_out__write_context(Context),
io__write_string(" determinism is "),
hlds_out__write_determinism(Desired),
- io__write_string(".\n"),
- prog_out__write_context(Context),
- io__write_string(" pragma c_code declarations only allowed\n"),
- prog_out__write_context(Context),
- io__write_string(" for modes which don't succeed more than once.\n").
- % XXX
+ io__write_string(".\n").
+ % The "clarification" below is now incorrect.
+ % prog_out__write_context(Context),
+ % io__write_string(" pragma c_code declarations only allowed\n"),
+ % prog_out__write_context(Context),
+ % io__write_string(" for modes which don't succeed more than once.\n").
%-----------------------------------------------------------------------------%
Index: compiler/dnf.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/dnf.m,v
retrieving revision 1.26
diff -u -u -r1.26 dnf.m
--- dnf.m 1997/12/22 09:55:34 1.26
+++ dnf.m 1998/01/02 05:06:48
@@ -225,7 +225,7 @@
NewPredIds = NewPredIds0,
Goal = Goal0
;
- GoalExpr0 = pragma_c_code(_, _, _, _, _, _, _, _),
+ GoalExpr0 = pragma_c_code(_, _, _, _, _, _, _),
ModuleInfo = ModuleInfo0,
NewPredIds = NewPredIds0,
Goal = Goal0
@@ -429,7 +429,7 @@
dnf__is_atomic_expr(some(_, GoalExpr - _), IsAtomic) :-
dnf__is_atomic_expr(GoalExpr, IsAtomic).
dnf__is_atomic_expr(if_then_else(_, _, _, _, _), no).
-dnf__is_atomic_expr(pragma_c_code(_, _, _, _, _, _, _, _), yes).
+dnf__is_atomic_expr(pragma_c_code(_, _, _, _, _, _, _), yes).
:- pred dnf__expr_free_of_nonatomic(hlds_goal_expr::in,
set(pred_proc_id)::in) is semidet.
@@ -451,7 +451,7 @@
dnf__goal_free_of_nonatomic(Cond, NonAtomic),
dnf__goal_free_of_nonatomic(Then, NonAtomic),
dnf__goal_free_of_nonatomic(Else, NonAtomic).
-dnf__expr_free_of_nonatomic(pragma_c_code(_, _, _, _, _, _, _, _), _NonAtomic).
+dnf__expr_free_of_nonatomic(pragma_c_code(_, _, _, _, _, _, _), _NonAtomic).
:- pred dnf__goal_free_of_nonatomic(hlds_goal::in,
set(pred_proc_id)::in) is semidet.
Index: compiler/dupelim.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/dupelim.m,v
retrieving revision 1.28
diff -u -u -r1.28 dupelim.m
--- dupelim.m 1997/12/24 02:04:59 1.28
+++ dupelim.m 1998/01/08 07:26:44
@@ -69,11 +69,11 @@
create_basic_blocks(Instrs0, Comments, _ProcLabel, _N,
LabelSeq0, BlockMap0),
map__init(StdMap0),
- set__init(FallInto0),
+ set__init(Fixed0),
dupelim__build_maps(LabelSeq0, BlockMap0, StdMap0, StdMap,
- FallInto0, FallInto),
+ Fixed0, Fixed),
map__values(StdMap, StdList),
- find_clusters(StdList, FallInto, [], Clusters),
+ find_clusters(StdList, Fixed, [], Clusters),
( Clusters = [] ->
% We don't want to introduce any incidental changes
% if we cannot eliminate any blocks.
@@ -96,9 +96,9 @@
:- pred dupelim__build_maps(list(label)::in, block_map::in,
std_map::in, std_map::out, set(label)::in, set(label)::out) is det.
-dupelim__build_maps([], _, StdMap, StdMap, FallInto, FallInto).
+dupelim__build_maps([], _, StdMap, StdMap, Fixed, Fixed).
dupelim__build_maps([Label | Labels], BlockMap, StdMap0, StdMap,
- FallInto0, FallInto) :-
+ Fixed0, Fixed) :-
map__lookup(BlockMap, Label, BlockInfo),
BlockInfo = block_info(_, _, Instrs, _, MaybeFallThrough),
standardize_block(Instrs, MaybeFallThrough, StdInstrs),
@@ -108,12 +108,22 @@
map__det_insert(StdMap0, StdInstrs, [Label], StdMap1)
),
( MaybeFallThrough = yes(FallIntoLabel) ->
- set__insert(FallInto0, FallIntoLabel, FallInto1)
+ set__insert(Fixed0, FallIntoLabel, Fixed1)
;
- FallInto1 = FallInto0
+ Fixed1 = Fixed0
),
+ AddPragmaReferredLabels = lambda(
+ [Instr::in, FoldFixed0::in, FoldFixed::out] is det, (
+ ( Instr = pragma_c(_, _, _, yes(Label)) - _ ->
+ set__insert(FoldFixed0, Label, FoldFixed)
+ ;
+ FoldFixed = FoldFixed0
+ )
+ )),
+ list__foldl(AddPragmaReferredLabels, Instrs,
+ Fixed1, Fixed2),
dupelim__build_maps(Labels, BlockMap, StdMap1, StdMap,
- FallInto1, FallInto).
+ Fixed2, Fixed).
% For each set of labels that start basic blocks with identical standard forms,
% find_clusters finds out whether we can eliminate some of those blocks;
@@ -124,34 +134,37 @@
% to eliminate all but one of the blocks. However, blocks that can be fallen
% into cannot be eliminated. (Actually, they could, but only by inserting
% a goto, and full jumpopt would then undo the elimination of the block.)
+% Similarly, blocks whose starting label is referred to by C code cannot
+% be eliminated. (Actually, they could, but only by doing surgery on C code
+% strings, which is not a good idea.)
:- pred find_clusters(list(list(label))::in, set(label)::in,
list(cluster)::in, list(cluster)::out) is det.
find_clusters([], _, Clusters, Clusters).
-find_clusters([Labels | LabelsList], FallInto, Clusters0, Clusters) :-
+find_clusters([Labels | LabelsList], Fixed, Clusters0, Clusters) :-
(
Labels = [_, _ | _],
% The rest of the condition is relatively expensive,
% so don't do it if there aren't at least two labels
% whose blocks have the same standardized form.
IsFallenInto = lambda([Label::in] is semidet, (
- set__member(Label, FallInto)
+ set__member(Label, Fixed)
)),
list__filter(IsFallenInto, Labels,
- FallIntoLabels, NonFallIntoLabels),
- NonFallIntoLabels = [FirstNonFallInto | OtherNonFallInto]
+ FixedLabels, NonFixedLabels),
+ NonFixedLabels = [FirstNonFixed | OtherNonFixed]
->
- ( FallIntoLabels = [ChosenLabel | _] ->
- Cluster = cluster(ChosenLabel, NonFallIntoLabels)
+ ( FixedLabels = [ChosenLabel | _] ->
+ Cluster = cluster(ChosenLabel, NonFixedLabels)
;
- Cluster = cluster(FirstNonFallInto, OtherNonFallInto)
+ Cluster = cluster(FirstNonFixed, OtherNonFixed)
),
Clusters1 = [Cluster | Clusters0]
;
Clusters1 = Clusters0
),
- find_clusters(LabelsList, FallInto, Clusters1, Clusters).
+ find_clusters(LabelsList, Fixed, Clusters1, Clusters).
%-----------------------------------------------------------------------------%
@@ -281,7 +294,7 @@
Instr1 = call(_, _, _, _),
Instr = Instr1
;
- Instr1 = mkframe(_, _, _),
+ Instr1 = mkframe(_, _, _, _),
Instr = Instr1
;
Instr1 = modframe(_),
@@ -341,7 +354,7 @@
Instr1 = decr_sp(_),
Instr = Instr1
;
- Instr1 = pragma_c(_, _, _, _, _),
+ Instr1 = pragma_c(_, _, _, _),
Instr = Instr1
).
@@ -534,7 +547,7 @@
Instr2 = Instr1,
Instr = Instr1
;
- Instr1 = mkframe(_, _, _),
+ Instr1 = mkframe(_, _, _, _),
Instr2 = Instr1,
Instr = Instr1
;
@@ -611,7 +624,7 @@
Instr2 = Instr1,
Instr = Instr1
;
- Instr1 = pragma_c(_, _, _, _, _),
+ Instr1 = pragma_c(_, _, _, _),
Instr2 = Instr1,
Instr = Instr1
).
@@ -765,8 +778,8 @@
dupelim__replace_labels_instr(call(Target, Return0, LiveInfo, CM),
ReplMap, call(Target, Return, LiveInfo, CM)) :-
dupelim__replace_labels_code_addr(Return0, ReplMap, Return).
-dupelim__replace_labels_instr(mkframe(Name, Size, Redoip0), ReplMap,
- mkframe(Name, Size, Redoip)) :-
+dupelim__replace_labels_instr(mkframe(Name, Size, Pragma, Redoip0), ReplMap,
+ mkframe(Name, Size, Pragma, Redoip)) :-
dupelim__replace_labels_code_addr(Redoip0, ReplMap, Redoip).
dupelim__replace_labels_instr(modframe(Redoip0), ReplMap, modframe(Redoip)) :-
dupelim__replace_labels_code_addr(Redoip0, ReplMap, Redoip).
@@ -810,7 +823,16 @@
dupelim__replace_labels_rval(Rval0, ReplMap, Rval).
dupelim__replace_labels_instr(incr_sp(Size, Msg), _, incr_sp(Size, Msg)).
dupelim__replace_labels_instr(decr_sp(Size), _, decr_sp(Size)).
-dupelim__replace_labels_instr(pragma_c(A,B,C,D,E), _, pragma_c(A,B,C,D,E)).
+dupelim__replace_labels_instr(pragma_c(A,B,C,D), ReplMap, pragma_c(A,B,C,D)) :-
+ (
+ D = no
+ ;
+ D = yes(Label0),
+ dupelim__replace_labels_label(Label0, ReplMap, Label),
+ % We cannot replace the label in the C code string
+ % itself.
+ require(unify(Label0, Label), "trying to replace Mercury label in C code")
+ ).
:- pred dupelim__replace_labels_lval(lval::in, map(label, label)::in,
lval::out) is det.
Index: compiler/excess.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/excess.m,v
retrieving revision 1.26
diff -u -u -r1.26 excess.m
--- excess.m 1997/12/22 09:55:37 1.26
+++ excess.m 1998/01/02 04:36:12
@@ -132,7 +132,7 @@
Goal = GoalExpr0 - GoalInfo0,
ElimVars = ElimVars0
;
- GoalExpr0 = pragma_c_code(_, _, _, _, _, _, _, _),
+ GoalExpr0 = pragma_c_code(_, _, _, _, _, _, _),
Goal = GoalExpr0 - GoalInfo0,
ElimVars = ElimVars0
),
Index: compiler/follow_code.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/follow_code.m,v
retrieving revision 1.45
diff -u -u -r1.45 follow_code.m
--- follow_code.m 1997/12/22 09:55:39 1.45
+++ follow_code.m 1998/01/02 05:07:04
@@ -117,8 +117,8 @@
move_follow_code_in_goal_2(unify(A,B,C,D,E), unify(A,B,C,D,E), _, R, R).
-move_follow_code_in_goal_2(pragma_c_code(A,B,C,D,E,F,G,H),
- pragma_c_code(A,B,C,D,E,F,G,H), _, R, R).
+move_follow_code_in_goal_2(pragma_c_code(A,B,C,D,E,F,G),
+ pragma_c_code(A,B,C,D,E,F,G), _, R, R).
%-----------------------------------------------------------------------------%
Index: compiler/follow_vars.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/follow_vars.m,v
retrieving revision 1.44
diff -u -u -r1.44 follow_vars.m
--- follow_vars.m 1997/12/19 03:06:38 1.44
+++ follow_vars.m 1998/01/02 04:36:28
@@ -214,9 +214,9 @@
FollowVars = FollowVars0
).
-find_follow_vars_in_goal_2(pragma_c_code(A,B,C,D,E,F,G,H), _ArgInfo,
+find_follow_vars_in_goal_2(pragma_c_code(A,B,C,D,E,F,G), _ArgInfo,
_ModuleInfo, FollowVars,
- pragma_c_code(A,B,C,D,E,F,G,H), FollowVars).
+ pragma_c_code(A,B,C,D,E,F,G), FollowVars).
%-----------------------------------------------------------------------------%
Index: compiler/frameopt.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/frameopt.m,v
retrieving revision 1.65
diff -u -u -r1.65 frameopt.m
--- frameopt.m 1997/12/22 06:58:12 1.65
+++ frameopt.m 1998/01/06 08:23:31
@@ -533,11 +533,11 @@
(
Uinstr = call(_, _, _, _)
;
- Uinstr = mkframe(_, _, _)
+ Uinstr = mkframe(_, _, _, _)
;
Uinstr = c_code(_)
;
- Uinstr = pragma_c(_, _, _, _, _)
+ Uinstr = pragma_c(_, _, may_call_mercury, _)
)
->
NeedsFrame = yes
@@ -660,7 +660,7 @@
;
Labels = []
).
-possible_targets(mkframe(_, _, _), []).
+possible_targets(mkframe(_, _, _, _), []).
possible_targets(modframe(_), []).
possible_targets(label(_), []).
possible_targets(goto(CodeAddr), Targets) :-
@@ -687,7 +687,7 @@
possible_targets(discard_tickets_to(_), []).
possible_targets(incr_sp(_, _), []).
possible_targets(decr_sp(_), []).
-possible_targets(pragma_c(_, _, _, _, _), []).
+possible_targets(pragma_c(_, _, _, _), []).
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -704,11 +704,8 @@
(
Uinstr = call(_, _, _, _)
;
- % Only may_call_mercury pragma_c's can clobber succip,
- % but the LLDS doesn't say whether a given pragma_c
- % may call Mercury or not. We therefore make the
- % conservative assumption that it may.
- Uinstr = pragma_c(_, _, _, _, _)
+ % Only may_call_mercury pragma_c's can clobber succip.
+ Uinstr = pragma_c(_, _, may_call_mercury, _)
)
->
CanClobberSuccip = yes
@@ -1260,8 +1257,8 @@
;
ReturnAddr = ReturnAddr0
).
-substitute_labels_instr(mkframe(Name, Size, Redoip), _,
- mkframe(Name, Size, Redoip)).
+substitute_labels_instr(mkframe(Name, Size, Pragma, Redoip), _,
+ mkframe(Name, Size, Pragma, Redoip)).
substitute_labels_instr(modframe(Redoip), _, modframe(Redoip)).
substitute_labels_instr(label(_), _, _) :-
error("label in substitute_labels_instr").
@@ -1299,8 +1296,8 @@
substitute_labels_instr(discard_tickets_to(Rval), _, discard_tickets_to(Rval)).
substitute_labels_instr(incr_sp(Size, Name), _, incr_sp(Size, Name)).
substitute_labels_instr(decr_sp(Size), _, decr_sp(Size)).
-substitute_labels_instr(pragma_c(Decl, In, Code, Out, Context), _,
- pragma_c(Decl, In, Code, Out, Context)).
+substitute_labels_instr(pragma_c(Decls, Components, MayCallMercury, MaybeLabel),
+ _, pragma_c(Decls, Components, MayCallMercury, MaybeLabel)).
:- pred substitute_labels_list(list(label)::in, assoc_list(label)::in,
list(label)::out) is det.
Index: compiler/goal_path.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/goal_path.m,v
retrieving revision 1.2
diff -u -u -r1.2 goal_path.m
--- goal_path.m 1997/12/19 03:06:40 1.2
+++ goal_path.m 1998/01/02 04:36:40
@@ -59,8 +59,8 @@
fill_expr_slots(class_method_call(A,B,C,D,E,F), _Path0,
class_method_call(A,B,C,D,E,F)).
fill_expr_slots(unify(A,B,C,D,E), _Path0, unify(A,B,C,D,E)).
-fill_expr_slots(pragma_c_code(A,B,C,D,E,F,G,H), _Path0,
- pragma_c_code(A,B,C,D,E,F,G,H)).
+fill_expr_slots(pragma_c_code(A,B,C,D,E,F,G), _Path0,
+ pragma_c_code(A,B,C,D,E,F,G)).
:- pred fill_conj_slots(list(hlds_goal)::in, goal_path::in, int::in,
list(hlds_goal)::out) is det.
Index: compiler/goal_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/goal_util.m,v
retrieving revision 1.39
diff -u -u -r1.39 goal_util.m
--- goal_util.m 1997/12/19 03:06:42 1.39
+++ goal_util.m 1998/01/02 08:52:22
@@ -178,7 +178,8 @@
hlds_goal).
:- mode goal_util__rename_vars_in_goal(in, in, in, out) is det.
-goal_util__rename_vars_in_goal(Goal0 - GoalInfo0, Must, Subn, Goal - GoalInfo) :-
+goal_util__rename_vars_in_goal(Goal0 - GoalInfo0, Must, Subn, Goal - GoalInfo)
+ :-
goal_util__name_apart_2(Goal0, Must, Subn, Goal),
goal_util__name_apart_goalinfo(GoalInfo0, Must, Subn, GoalInfo).
@@ -246,18 +247,9 @@
goal_util__rename_unify_rhs(TermR0, Must, Subn, TermR),
goal_util__rename_unify(Unify0, Must, Subn, Unify).
-goal_util__name_apart_2(pragma_c_code(A,B,C,D,Vars0,F,G,Extra0), Must, Subn,
- pragma_c_code(A,B,C,D,Vars,F,G,Extra)) :-
- goal_util__rename_var_list(Vars0, Must, Subn, Vars),
- (
- Extra0 = none,
- Extra = none
- ;
- Extra0 = extra_pragma_info(SavedVars0, LabelNames),
- goal_util__rename_var_pair_list(SavedVars0, Must, Subn,
- SavedVars),
- Extra = extra_pragma_info(SavedVars, LabelNames)
- ).
+goal_util__name_apart_2(pragma_c_code(A,B,C,Vars0,E,F,G), Must, Subn,
+ pragma_c_code(A,B,C,Vars,E,F,G)) :-
+ goal_util__rename_var_list(Vars0, Must, Subn, Vars).
%-----------------------------------------------------------------------------%
@@ -457,17 +449,9 @@
goal_util__goal_vars_2(B, Set2, Set3),
goal_util__goal_vars_2(C, Set3, Set).
-goal_util__goal_vars_2(pragma_c_code(_, _, _, _, ArgVars, _, _, Extra),
+goal_util__goal_vars_2(pragma_c_code(_, _, _, ArgVars, _, _, _),
Set0, Set) :-
- set__insert_list(Set0, ArgVars, Set1),
- (
- Extra = none,
- Set = Set1
- ;
- Extra = extra_pragma_info(SavedVarNames, _),
- assoc_list__keys(SavedVarNames, SavedVars),
- set__insert_list(Set1, SavedVars, Set)
- ).
+ set__insert_list(Set0, ArgVars, Set).
:- pred goal_util__goals_goal_vars(list(hlds_goal), set(var), set(var)).
:- mode goal_util__goals_goal_vars(in, in, out) is det.
@@ -552,7 +536,7 @@
goal_expr_size(higher_order_call(_, _, _, _, _, _), 1).
goal_expr_size(class_method_call(_, _, _, _, _, _), 1).
goal_expr_size(unify(_, _, _, _, _), 1).
-goal_expr_size(pragma_c_code(_, _, _, _, _, _, _, _), 1).
+goal_expr_size(pragma_c_code(_, _, _, _, _, _, _), 1).
%-----------------------------------------------------------------------------%
Index: compiler/higher_order.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/higher_order.m,v
retrieving revision 1.36
diff -u -u -r1.36 higher_order.m
--- higher_order.m 1997/12/22 09:55:41 1.36
+++ higher_order.m 1998/01/02 05:09:14
@@ -91,8 +91,6 @@
NextHOid, NewPreds1, NewPreds, ModuleInfo5, ModuleInfo)
).
-
-
%-------------------------------------------------------------------------------
% The largest goal that will be specialized. Goal size is measured
@@ -104,7 +102,6 @@
max_specialized_goal_size(20).
-
:- type request --->
request(
pred_proc_id, % calling pred
@@ -158,7 +155,6 @@
list(higher_order_arg) % specialized args
).
-
% Returned by traverse_goal.
:- type changed --->
changed % Need to requantify goal + check other procs
@@ -176,7 +172,6 @@
get_specialization_requests_2(PredIds, Requests0, Requests,
GoalSizes0, GoalSizes, ModuleInfo0, ModuleInfo).
-
:- pred get_specialization_requests_2(list(pred_id)::in, set(request)::in,
set(request)::out, goal_sizes::in, goal_sizes::out,
module_info::in, module_info::out) is det.
@@ -261,7 +256,6 @@
traverse_other_procs(PredId, ProcIds, ModuleInfo, Requests1,
Requests, Procs1, Procs).
-
%-------------------------------------------------------------------------------
% Goal traversal
@@ -328,13 +322,12 @@
traverse_goal(Goal0, Goal, PredProcId, Changed, GoalSize).
traverse_goal(Goal, Goal, _, unchanged, 1) -->
- { Goal = pragma_c_code(_, _, _, _, _, _, _, _) - _ }.
+ { Goal = pragma_c_code(_, _, _, _, _, _, _) - _ }.
traverse_goal(Goal, Goal, _, unchanged, 1) -->
{ Goal = unify(_, _, _, Unify, _) - _ },
check_unify(Unify).
-
:- pred traverse_conj(hlds_goals::in, hlds_goals::out, pred_proc_id::in,
changed::in, changed::out, int::in, int::out, higher_order_info::in,
higher_order_info::out) is det.
@@ -364,7 +357,6 @@
traverse_disj_2(Goals0, Goals, PredProcId,
Changed0, Changed, GoalSize0, GoalSize, Info0).
-
:- pred traverse_disj_2(hlds_goals::in, hlds_goals::out, pred_proc_id::in,
changed::in, changed::out, int::in, int::out, higher_order_info::in,
higher_order_info::in, higher_order_info::out) is det.
@@ -380,7 +372,6 @@
traverse_disj_2(Goals0, Goals, PredProcId, Changed1, Changed,
GoalSize1, GoalSize, InitialInfo, Info1, Info).
-
% The dependencies have changed, so the
% dependency graph needs to rebuilt for
% inlining to work properly.
@@ -417,7 +408,6 @@
traverse_cases_2(Cases0, Cases, PredProcId, Changed1, Changed,
GoalSize1, GoalSize, InitialInfo, Info1, Info).
-
% This is used in traversing disjunctions. We save the initial
% accumulator, then traverse each disjunct starting with the initial
% info. We then merge the resulting infos.
@@ -433,7 +423,6 @@
set__sorted_list_to_set(List12, Requests),
Info = info(PredVars, Requests, NewPreds, ModuleInfo).
-
:- pred merge_pred_vars(pred_vars::in, pred_vars::in, pred_vars::out) is det.
merge_pred_vars(PredVars1, PredVars2, PredVars) :-
@@ -442,7 +431,6 @@
merge_pred_var_lists(PredVarList1, PredVarList2, PredVarList),
map__from_assoc_list(PredVarList, PredVars).
-
% find out which variables after a disjunction cannot
% be specialized
:- pred merge_pred_var_lists(assoc_list(var, maybe_pred_and_args)::in,
@@ -454,7 +442,6 @@
merge_pred_var_with_list(PredVar, List2, MergedList1),
merge_pred_var_lists(PredVars, MergedList1, MergedList).
-
:- pred merge_pred_var_with_list(pair(var, maybe_pred_and_args)::in,
assoc_list(var, maybe_pred_and_args)::in,
assoc_list(var, maybe_pred_and_args)::out) is det.
@@ -481,7 +468,6 @@
merge_pred_var_with_list(Var1 - Value1, Vars, MergedList1)
).
-
:- pred check_unify(unification::in, higher_order_info::in,
higher_order_info::out) is det.
@@ -712,7 +698,6 @@
PredVars = PredVars0
).
-
:- pred update_changed_status(changed::in, changed::in, changed::out) is det.
update_changed_status(changed, _, changed).
@@ -804,7 +789,6 @@
create_new_preds(Requests, NewPreds1, NewPreds, PredsToFix1, PredsToFix,
NextHOid1, NextHOid, Module1, Module, IO1, IO).
-
% Here we create the pred_info for the new predicate.
:- pred create_new_pred(request::in, new_pred::out, int::in, int::out,
module_info::in, module_info::out, io__state::di, io__state::uo) is det.
@@ -867,7 +851,6 @@
predicate_table_insert(PredTable0, PredInfo2, NewPredId, PredTable),
module_info_set_predicate_table(ModuleInfo0, PredTable, ModuleInfo).
-
:- pred output_higher_order_args(module_info::in, int::in,
list(higher_order_arg)::in, io__state::di, io__state::uo) is det.
@@ -890,7 +873,6 @@
io__write_string(" curried arguments\n"),
output_higher_order_args(ModuleInfo, NumToDrop, HOArgs).
-
:- pred remove_listof_higher_order_args(list(T)::in, int::in,
list(higher_order_arg)::in, list(T)::out) is det.
@@ -919,7 +901,6 @@
)
).
-
% Fixup calls to specialized predicates.
:- pred fixup_preds(list(pred_proc_id)::in, new_preds::in,
module_info::in, module_info::out) is det.
@@ -950,7 +931,6 @@
module_info_set_preds(ModuleInfo0, Preds, ModuleInfo1),
fixup_preds(PredProcIds, NewPreds, ModuleInfo1, ModuleInfo).
-
:- pred create_specialized_versions(list(pred_proc_id)::in, new_preds::in,
set(request)::in, set(request)::out, goal_sizes::in,
goal_sizes::out, module_info::in, module_info::out) is det.
@@ -968,7 +948,6 @@
create_specialized_versions(PredProcs, NewPreds, Requests1, Requests,
GoalSizes1, GoalSizes, ModuleInfo1, ModuleInfo).
-
% Create specialized versions of a single procedure.
:- pred create_specialized_versions_2(list(new_pred)::in, new_preds::in,
proc_info::in, set(request)::in, set(request)::out,
@@ -1046,7 +1025,6 @@
Requests1, Requests, GoalSizes1, GoalSizes,
ModuleInfo2, ModuleInfo).
-
% Returns a list of hlds_goals which construct the list of
% higher order arguments which have been specialized. Traverse
% goal will then recognize these as having a unique possible
Index: compiler/hlds_goal.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_goal.m,v
retrieving revision 1.44
diff -u -u -r1.44 hlds_goal.m
--- hlds_goal.m 1997/12/19 03:06:49 1.44
+++ hlds_goal.m 1998/01/02 07:11:57
@@ -13,7 +13,7 @@
:- interface.
:- import_module hlds_data, hlds_pred, llds, prog_data, (inst), instmap.
-:- import_module list, assoc_list, set, map, std_util.
+:- import_module list, set, map, std_util.
% Here is how goals are represented
@@ -155,15 +155,15 @@
% C code from a pragma(c_code, ...) decl.
; pragma_c_code(
- string, % The C code to do the work
may_call_mercury,
% Can the C code recursively
% invoke Mercury code?
pred_id, % The called predicate
proc_id, % The mode of the predicate
list(var), % The (Mercury) argument variables
- list(maybe(string)),
- % C variable names for each of the
+ list(maybe(pair(string, mode))),
+ % C variable names and the original
+ % mode declaration for each of the
% arguments. A no for a particular
% argument means that it is not used
% by the C code. (In particular, the
@@ -173,25 +173,13 @@
list(type), % The original types of the arguments.
% (With inlining, the actual types may
% be instances of the original types.)
- extra_pragma_info
- % Extra information for model_non
- % pragma_c_codes; none for others.
+ pragma_code % Info about the code that does the
+ % actual work.
).
-:- type extra_pragma_info
- ---> none
- ; extra_pragma_info(
- assoc_list(var, string),
- % the vars/names of the framevars used
- % by the hand-written C code (we may
- % need some more for saving the heap
- % pointer and/or tickets)
- list(string) % the names of the labels needed
- ).
-
- % Given the variable name field from a pragma c_code, get all the
+ % Given the variable info field from a pragma c_code, get all the
% variable names.
-:- pred get_pragma_c_var_names(list(maybe(string)), list(string)).
+:- pred get_pragma_c_var_names(list(maybe(pair(string, mode))), list(string)).
:- mode get_pragma_c_var_names(in, out) is det.
% There may be two sorts of "builtin" predicates - those that we
@@ -484,13 +472,13 @@
get_pragma_c_var_names_2(MaybeVarNames, [], VarNames0),
list__reverse(VarNames0, VarNames).
-:- pred get_pragma_c_var_names_2(list(maybe(string))::in, list(string)::in,
- list(string)::out) is det.
+:- pred get_pragma_c_var_names_2(list(maybe(pair(string, mode)))::in,
+ list(string)::in, list(string)::out) is det.
get_pragma_c_var_names_2([], Names, Names).
get_pragma_c_var_names_2([MaybeName | MaybeNames], Names0, Names) :-
(
- MaybeName = yes(Name),
+ MaybeName = yes(Name - _),
Names1 = [Name | Names0]
;
MaybeName = no,
@@ -920,7 +908,7 @@
goal_is_atomic(class_method_call(_,_,_,_,_,_)).
goal_is_atomic(call(_,_,_,_,_,_)).
goal_is_atomic(unify(_,_,_,_,_)).
-goal_is_atomic(pragma_c_code(_,_,_,_,_,_,_,_)).
+goal_is_atomic(pragma_c_code(_,_,_,_,_,_,_)).
%-----------------------------------------------------------------------------%
Index: compiler/hlds_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_out.m,v
retrieving revision 1.180
diff -u -u -r1.180 hlds_out.m
--- hlds_out.m 1998/01/04 04:42:10 1.180
+++ hlds_out.m 1998/01/08 07:21:09
@@ -484,6 +484,7 @@
hlds_out__write_marker_list(MarkerList),
io__write_string("\n")
),
+
globals__io_lookup_string_option(verbose_dump_hlds, Verbose),
( { string__contains_char(Verbose, 'v') } ->
{ AppendVarnums = yes }
@@ -1120,8 +1121,8 @@
[]
).
-hlds_out__write_goal_2(pragma_c_code(C_Code, _, _, _, ArgVars, ArgNames, _,
- Extra), _, _, _, Indent, Follow, _) -->
+hlds_out__write_goal_2(pragma_c_code(_, _, _, ArgVars, ArgNames, _,
+ PragmaCode), _, _, _, Indent, Follow, _) -->
hlds_out__write_indent(Indent),
io__write_string("$pragma(c_code, ["),
hlds_out__write_varnum_list(ArgVars),
@@ -1130,18 +1131,38 @@
hlds_out__write_string_list(Names),
io__write_string("], "),
(
- { Extra = none }
- ;
- { Extra = extra_pragma_info(SavedVarNames, LabelNames) },
- io__write_string("["),
- hlds_out__write_var_name_list(SavedVarNames),
- io__write_string("], ["),
- hlds_out__write_string_list(LabelNames),
- io__write_string("], ")
- ),
- io__write_string(""""),
- io__write_string(C_Code),
- io__write_string(""" )"),
+ { PragmaCode = ordinary(C_Code, _) },
+ io__write_string(""""),
+ io__write_string(C_Code),
+ io__write_string("""")
+ ;
+ { PragmaCode = nondet(Fields, _FieldsContext,
+ First, _FirstContext,
+ Later, _LaterContext,
+ Treat, Shared, _SharedContext) },
+ io__write_string("local_vars("""),
+ io__write_string(Fields),
+ io__write_string("""), "),
+ io__write_string("first_code("""),
+ io__write_string(First),
+ io__write_string("""), "),
+ io__write_string("retry_code("""),
+ io__write_string(Later),
+ io__write_string("""), "),
+ (
+ { Treat = share },
+ io__write_string("shared_code(""")
+ ;
+ { Treat = duplicate },
+ io__write_string("duplicated_code(""")
+ ;
+ { Treat = automatic },
+ io__write_string("common_code(""")
+ ),
+ io__write_string(Shared),
+ io__write_string(""")")
+ ),
+ io__write_string(")"),
io__write_string(Follow),
io__write_string("\n").
Index: compiler/inlining.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/inlining.m,v
retrieving revision 1.71
diff -u -u -r1.71 inlining.m
--- inlining.m 1997/12/22 09:55:48 1.71
+++ inlining.m 1998/01/02 05:15:42
@@ -196,10 +196,11 @@
{ map__lookup(Procs, ProcId, ProcInfo) },
{ proc_info_goal(ProcInfo, CalledGoal) },
{ Entity = proc(PredId, ProcId) },
- %
- % the heuristic represented by the following code
- % could be improved
- %
+
+ %
+ % the heuristic represented by the following code
+ % could be improved
+ %
(
{ Simple = yes },
{ inlining__is_simple_goal(CalledGoal,
@@ -219,17 +220,10 @@
% Don't inline recursive predicates
{ \+ goal_calls(CalledGoal, PredProcId) },
- % Don't inline model_non pragma c that doesn't have an
- % `extra_pragma_info'.
- %
- % XXX model_non pragma c without `extra_pragma_info' should
- % not be accepted by the compiler, but at the moment it's
- % the only way to get model_non pragma c (the ``correct''
- % way of doing it hasn't been implemented yet). We just
- % have to make sure it doesn't get inlined because that stops
- % it from working.
+ % Under no circumstances inline model_non pragma c codes.
+ % The resulting code would not work properly.
\+ {
- CalledGoal = pragma_c_code(_,_,_,_,_,_,_,none) - _,
+ CalledGoal = pragma_c_code(_,_,_,_,_,_,_) - _,
proc_info_interface_code_model(ProcInfo, model_non)
}
->
@@ -527,8 +521,8 @@
inlining__inlining_in_goal(unify(A, B, C, D, E) - GoalInfo,
unify(A, B, C, D, E) - GoalInfo) --> [].
-inlining__inlining_in_goal(pragma_c_code(A, B, C, D, E, F, G, H) - GoalInfo,
- pragma_c_code(A, B, C, D, E, F, G, H) - GoalInfo) --> [].
+inlining__inlining_in_goal(pragma_c_code(A, B, C, D, E, F, G) - GoalInfo,
+ pragma_c_code(A, B, C, D, E, F, G) - GoalInfo) --> [].
%-----------------------------------------------------------------------------%
Index: compiler/intermod.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/intermod.m,v
retrieving revision 1.39
diff -u -u -r1.39 intermod.m
--- intermod.m 1997/12/19 03:07:01 1.39
+++ intermod.m 1998/01/02 07:04:49
@@ -245,7 +245,6 @@
{ DoWrite = no }
).
-
:- pred has_ho_input(module_info::in, proc_info::in) is semidet.
has_ho_input(ModuleInfo, ProcInfo) :-
@@ -301,7 +300,6 @@
),
intermod__gather_types(ModuleInfo, TypeTable, TypesToCheck).
-
% All equivalence types that only have a :- type foo. in the
% interface section need to be exported in full. All other
% types of type will be exported by intermod__gather_types.
@@ -335,7 +333,6 @@
)) },
list__foldl(AddAbstractEquivType, TypeList).
-
% Go over the goal of an exported proc looking for proc decls, types,
% insts and modes that we need to write to the optfile.
:- pred intermod__traverse_goal(hlds_goal::in, hlds_goal::out, bool::out,
@@ -414,9 +411,8 @@
% Inlineable exported pragma_c_code goals can't use any
% non-exported types, so we just write out the clauses.
-intermod__traverse_goal(pragma_c_code(A,B,C,D,E,F,G,H) - Info,
- pragma_c_code(A,B,C,D,E,F,G,H) - Info, yes) --> [].
-
+intermod__traverse_goal(pragma_c_code(A,B,C,D,E,F,G) - Info,
+ pragma_c_code(A,B,C,D,E,F,G) - Info, yes) --> [].
:- pred intermod__traverse_list_of_goals(hlds_goals::in, hlds_goals::out,
bool::out, intermod_info::in, intermod_info::out) is det.
@@ -604,7 +600,6 @@
intermod__gather_pred_modes(ModuleInfo, Modes, Insts, Procs, ProcIds),
intermod__gather_modes(ModuleInfo, Modes, Insts, PredIds).
-
:- pred intermod__gather_pred_modes(module_info::in, mode_defns::in,
user_inst_defns::in, proc_table::in, list(proc_id)::in,
intermod_info::in, intermod_info::out) is det.
@@ -744,7 +739,6 @@
intermod__write_preds(ModuleInfo, Preds),
globals__io_set_option(verbose_dump_hlds, string(VerboseDump)).
-
:- pred intermod__write_modules(list(module_name)::in,
io__state::di, io__state::uo) is det.
@@ -981,18 +975,18 @@
{ Goal = conj(Goals) - _ },
{ list__filter(
lambda([X::in] is semidet, (
- X = pragma_c_code(_,_,_,_,_,_,_,_) - _
+ X = pragma_c_code(_,_,_,_,_,_,_) - _
)),
Goals, [CCodeGoal]) },
- { CCodeGoal = pragma_c_code(CCode, MayCallMercury,
- _, _, Vars, _, _, _) - _ }
+ { CCodeGoal = pragma_c_code(MayCallMercury,
+ _, _, Vars, _, _, PragmaCode) - _ }
;
- { Goal = pragma_c_code(CCode, MayCallMercury,
- _, _, Vars, _, _, _) - _ }
+ { Goal = pragma_c_code(MayCallMercury,
+ _, _, Vars, _, _, PragmaCode) - _ }
)
->
- intermod__write_c_clauses(Procs, ProcIds, PredOrFunc, CCode,
- MayCallMercury, Vars, Varset, SymName)
+ intermod__write_c_clauses(Procs, ProcIds, PredOrFunc,
+ PragmaCode, MayCallMercury, Vars, Varset, SymName)
;
{ error("intermod__write_c_code called with non c_code goal") }
),
@@ -1000,22 +994,21 @@
Clauses, Procs).
:- pred intermod__write_c_clauses(proc_table::in, list(proc_id)::in,
- pred_or_func::in, string::in, may_call_mercury::in,
+ pred_or_func::in, pragma_code::in, may_call_mercury::in,
list(var)::in, varset::in, sym_name::in,
io__state::di, io__state::uo) is det.
intermod__write_c_clauses(_, [], _, _, _, _, _, _) --> [].
intermod__write_c_clauses(Procs, [ProcId | ProcIds], PredOrFunc,
- CCode, MayCallMercury, Vars, Varset, SymName) -->
+ PragmaCode, MayCallMercury, Vars, Varset, SymName) -->
{ map__lookup(Procs, ProcId, ProcInfo) },
{ proc_info_maybe_declared_argmodes(ProcInfo, MaybeArgModes) },
( { MaybeArgModes = yes(ArgModes) } ->
{ get_pragma_c_code_vars(Vars, Varset, ArgModes, PragmaVars) },
- % XXX will need modification for nondet pragma C code
mercury_output_pragma_c_code(MayCallMercury, SymName,
- PredOrFunc, PragmaVars, no, Varset, CCode),
- intermod__write_c_clauses(Procs, ProcIds, PredOrFunc, CCode,
- MayCallMercury, Vars, Varset, SymName)
+ PredOrFunc, PragmaVars, Varset, PragmaCode),
+ intermod__write_c_clauses(Procs, ProcIds, PredOrFunc,
+ PragmaCode, MayCallMercury, Vars, Varset, SymName)
;
{ error("intermod__write_c_clauses: no mode declaration") }
).
@@ -1078,7 +1071,6 @@
intermod_info_get_var_types(VarTypes) --> =(info(_,_,_,_,_,_,_,_,VarTypes,_)).
intermod_info_get_tvarset(TVarSet) --> =(info(_,_,_,_,_,_,_,_,_,TVarSet)).
-
:- pred intermod_info_set_modules(set(module_name)::in,
intermod_info::in, intermod_info::out) is det.
:- pred intermod_info_set_preds(set(pred_id)::in,
@@ -1185,7 +1177,6 @@
set_list_of_preds_exported(NewPredIds, Preds0, Preds1),
fixup_special_preds(TypeIds, SpecialPredList, SpecMap, Preds1, Preds).
-
:- pred set_list_of_preds_exported(list(pred_id)::in, pred_table::in,
pred_table::out) is det.
@@ -1264,7 +1255,6 @@
{ list__append(Items0, NewItems2, Items) },
{ Module = module_imports(ModuleName, DirectImports,
IndirectImports, Items, no) }.
-
:- pred read_optimization_interfaces(list(module_name)::in, item_list::in,
item_list::out, bool::in, bool::out,
Index: compiler/lambda.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/lambda.m,v
retrieving revision 1.35
diff -u -u -r1.35 lambda.m
--- lambda.m 1997/12/22 09:55:50 1.35
+++ lambda.m 1998/01/02 04:39:58
@@ -210,8 +210,8 @@
lambda__process_goal_2(call(A,B,C,D,E,F), GoalInfo,
call(A,B,C,D,E,F) - GoalInfo) -->
[].
-lambda__process_goal_2(pragma_c_code(A,B,C,D,E,F,G,H), GoalInfo,
- pragma_c_code(A,B,C,D,E,F,G,H) - GoalInfo) -->
+lambda__process_goal_2(pragma_c_code(A,B,C,D,E,F,G), GoalInfo,
+ pragma_c_code(A,B,C,D,E,F,G) - GoalInfo) -->
[].
:- pred lambda__process_goal_list(list(hlds_goal), list(hlds_goal),
Index: compiler/lco.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/lco.m,v
retrieving revision 1.8
diff -u -u -r1.8 lco.m
--- lco.m 1997/12/19 03:07:06 1.8
+++ lco.m 1998/01/02 04:40:08
@@ -90,8 +90,8 @@
lco_in_goal_2(unify(A,B,C,D,E), _ModuleInfo, unify(A,B,C,D,E)).
-lco_in_goal_2(pragma_c_code(A,B,C,D,E,F,G,H), _,
- pragma_c_code(A,B,C,D,E,F,G,H)).
+lco_in_goal_2(pragma_c_code(A,B,C,D,E,F,G), _,
+ pragma_c_code(A,B,C,D,E,F,G)).
%-----------------------------------------------------------------------------%
Index: compiler/live_vars.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/live_vars.m,v
retrieving revision 1.68
diff -u -u -r1.68 live_vars.m
--- live_vars.m 1997/12/19 03:07:08 1.68
+++ live_vars.m 1998/01/06 07:32:49
@@ -343,48 +343,39 @@
LiveSets = LiveSets0
).
-build_live_sets_in_goal_2(pragma_c_code(_, MayCallMercury, PredId, ProcId,
- Args, _, _, Extra), Liveness, ResumeVars0, LiveSets0,
+build_live_sets_in_goal_2(pragma_c_code(MayCallMercury, PredId, ProcId,
+ Args, _, _, _), Liveness, ResumeVars0, LiveSets0,
GoalInfo, ModuleInfo, ProcInfo,
Liveness, ResumeVars, LiveSets) :-
goal_info_get_code_model(GoalInfo, CodeModel),
(
+ % We don't need to save any variables onto the stack
+ % before a pragma_c_code if we know that it can't
+ % succeed more than once and that it is not going
+ % to call back Mercury code, because such pragma C code
+ % won't clobber the registers.
+
CodeModel \= model_non,
MayCallMercury = will_not_call_mercury
->
- % We don't need to save any variables onto the stack
- % before a pragma_c_code if we know that it can't succeed
- % more than once and that it is not going to call back
- % Mercury code, because C code won't clobber the registers.
-
ResumeVars = ResumeVars0,
LiveSets = LiveSets0
;
% The variables which need to be saved onto the stack
% before the call are all the variables that are live
% after the call (except for the output arguments produced
- % by the call), plus any variables needed by a nondet
- % pragma to communication between incarnations, plus
- % all the variables that may be needed at an enclosing
- % resumption point.
+ % by the call), plus all the variables that may be needed
+ % at an enclosing resumption point.
find_output_vars(PredId, ProcId, Args, ModuleInfo, OutVars),
set__difference(Liveness, OutVars, InputLiveness),
- (
- Extra = none,
- StackVars0 = InputLiveness
- ;
- Extra = extra_pragma_info(SavedVarNames, _),
- assoc_list__keys(SavedVarNames, SavedVars),
- set__insert_list(InputLiveness, SavedVars, StackVars0)
- ),
- set__union(StackVars0, ResumeVars0, StackVars1),
+ set__union(InputLiveness, ResumeVars0, StackVars0),
% Might need to add more live variables with accurate GC.
maybe_add_accurate_gc_typeinfos(ModuleInfo,
- ProcInfo, OutVars, StackVars1, StackVars),
+ ProcInfo, OutVars, StackVars0, StackVars),
set__insert(LiveSets0, StackVars, LiveSets),
Index: compiler/livemap.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/livemap.m,v
retrieving revision 1.29
diff -u -u -r1.29 livemap.m
--- livemap.m 1997/12/19 03:07:10 1.29
+++ livemap.m 1998/01/06 08:20:09
@@ -156,7 +156,7 @@
Livemap = Livemap0,
Ccode = Ccode0
;
- Uinstr0 = mkframe(_, _, _),
+ Uinstr0 = mkframe(_, _, _, _),
Livemap = Livemap0,
Livevals = Livevals0,
Instrs = Instrs0,
@@ -323,7 +323,7 @@
Ccode = Ccode0
;
% XXX we shouldn't just give up here
- Uinstr0 = pragma_c(_, _, _, _, _),
+ Uinstr0 = pragma_c(_, _, _, _),
Livemap = Livemap0,
Livevals = Livevals0,
Instrs = Instrs0,
Index: compiler/liveness.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/liveness.m,v
retrieving revision 1.86
diff -u -u -r1.86 liveness.m
--- liveness.m 1997/12/22 09:55:53 1.86
+++ liveness.m 1998/01/02 04:40:32
@@ -298,7 +298,7 @@
detect_liveness_in_goal_2(unify(_,_,_,_,_), _, _, _, _, _) :-
error("unify in detect_liveness_in_goal_2").
-detect_liveness_in_goal_2(pragma_c_code(_,_,_,_,_,_,_,_), _, _, _, _, _) :-
+detect_liveness_in_goal_2(pragma_c_code(_,_,_,_,_,_,_), _, _, _, _, _) :-
error("pragma_c_code in detect_liveness_in_goal_2").
%-----------------------------------------------------------------------------%
@@ -477,7 +477,7 @@
detect_deadness_in_goal_2(unify(_,_,_,_,_), _, _, _, _, _) :-
error("unify in detect_deadness_in_goal_2").
-detect_deadness_in_goal_2(pragma_c_code(_,_,_,_,_,_,_,_), _, _, _, _, _) :-
+detect_deadness_in_goal_2(pragma_c_code(_,_,_,_,_,_,_), _, _, _, _, _) :-
error("pragma_c_code in detect_deadness_in_goal_2").
%-----------------------------------------------------------------------------%
@@ -675,9 +675,9 @@
detect_resume_points_in_goal_2(unify(A,B,C,D,E), _, Liveness, _, _,
unify(A,B,C,D,E), Liveness).
-detect_resume_points_in_goal_2(pragma_c_code(A,B,C,D,E,F,G,H), _, Liveness,
+detect_resume_points_in_goal_2(pragma_c_code(A,B,C,D,E,F,G), _, Liveness,
_, _,
- pragma_c_code(A,B,C,D,E,F,G,H), Liveness).
+ pragma_c_code(A,B,C,D,E,F,G), Liveness).
:- pred detect_resume_points_in_conj(list(hlds_goal), set(var), live_info,
set(var), list(hlds_goal), set(var)).
Index: compiler/llds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/llds.m,v
retrieving revision 1.217
diff -u -u -r1.217 llds.m
--- llds.m 1997/12/24 02:05:04 1.217
+++ llds.m 1998/01/06 08:09:03
@@ -126,9 +126,17 @@
% says whether tail recursion elimination is
% potentially applicable to the call.
- ; mkframe(string, int, code_addr)
- % mkframe(Comment, SlotCount, FailureContinuation)
- % creates a nondet stack frame.
+ ; mkframe(string, int, maybe(pragma_struct), code_addr)
+ % mkframe(Comment, SlotCount, MaybePragmaStruct,
+ % FailureContinuation) creates a nondet stack frame.
+ % Comment says what predicate creates the frame.
+ % SlotCount says how many ordinary framevar slots
+ % it ought to have. If MaybePragmaStruct is yes,
+ % the argument gives the details of the structure
+ % which occupies the rest of the framevar slots.
+ % CodeAddr is the code address to branch to when
+ % trying to generate the next solution from this
+ % choice point.
; modframe(code_addr)
% modframe(FailureContinuation) is the same as
@@ -222,26 +230,66 @@
; decr_sp(int)
% Decrement the det stack pointer.
- ; pragma_c(list(pragma_c_decl), list(pragma_c_input),
- string, list(pragma_c_output), term__context).
- % The local variable declarations, the info required
- % for placing the inputs in the variables, the c code,
- % the info required for picking up the outputs, and
- % the context of the original appearance of the C code
- % in the Mercury source.
-
-% ; frame_pragma_c(list(pragma_c_decl), list(pragma_c_input),
-% string, list(pragma_c_output), list(label), term__context).
-% % The same as above, plus the list of labels to use
-% % in LABEL_1 and DEFINE_LABEL_1 style macros.
-% % For use in model_non pragma_c_codes, where it
-% % should be preceded by a mkframe.
-
- % pragma_c_decl holds the information needed for a variable
- % declaration for a pragma_c instruction.
+ ; pragma_c(list(pragma_c_decl), list(pragma_c_component),
+ may_call_mercury, maybe(label)).
+ % The first argument says what local variable
+ % declarations are required for the following
+ % components, which in turn can specify how
+ % the inputs should be placed in their variables,
+ % how the outputs should be picked up from their
+ % variables, and C code both from the program
+ % and the compiler. These components can be
+ % sequenced in various ways. This flexibility
+ % is needed for nondet pragma C codes, which
+ % need different copies of several components
+ % for different paths tthrough the code.
+ %
+ % The third argument says whether the user C code
+ % components may call Mercury; certain optimizations
+ % can be performed across pragma_c instructions that
+ % cannot call Mercury.
+ %
+ % Some components in some pragma_c instructions
+ % refer to a Mercury label. If they do, we must
+ % prevent the label from being optimized away.
+ % To make it known to labelopt, we mention it in
+ % the fourth arg.
+
+:- type pragma_struct
+ ---> pragma_struct(
+ string, % The name of the struct tag.
+ string, % The field declarations, supplied
+ % by the user in the program.
+ term__context % Where the field declarations
+ % originally appeared.
+ ).
+
+ % A pragma_c_decl holds the information needed for the declaration
+ % of a local variable in a block of C code emitted for a pragma_c
+ % instruction.
:- type pragma_c_decl
- ---> pragma_c_decl(type, string).
- % Type name, variable name.
+ ---> pragma_c_arg_decl(
+ % This local variable corresponds to a procedure arg.
+ type, % The Mercury type of the argument.
+ string % The name of the local variable that
+ % will hold the value of that argument
+ % inside the C block.
+ )
+ ; pragma_c_struct_ptr_decl(
+ % This local variable holds the address of the
+ % save struct.
+ string, % The name of the C struct tag of the save
+ % struct; the type of the local variable
+ % will be a pointer to a struct with this tag.
+ string % The name of the local variable.
+ ).
+
+ % A pragma_c_component holds one component of a pragma_c instruction.
+:- type pragma_c_component
+ ---> pragma_c_inputs(list(pragma_c_input))
+ ; pragma_c_outputs(list(pragma_c_output))
+ ; pragma_c_user_code(term__context, string)
+ ; pragma_c_raw_code(string).
% A pragma_c_input represents the code that initializes one
% of the input variables for a pragma_c instruction.
Index: compiler/llds_common.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/llds_common.m,v
retrieving revision 1.13
diff -u -u -r1.13 llds_common.m
--- llds_common.m 1997/12/10 07:15:44 1.13
+++ llds_common.m 1998/01/06 08:14:54
@@ -177,7 +177,7 @@
Instr = Instr0,
Info = Info0
;
- Instr0 = mkframe(_, _, _),
+ Instr0 = mkframe(_, _, _, _),
Instr = Instr0,
Info = Info0
;
@@ -250,7 +250,7 @@
Instr = Instr0,
Info = Info0
;
- Instr0 = pragma_c(_, _, _, _, _),
+ Instr0 = pragma_c(_, _, _, _),
Instr = Instr0,
Info = Info0
).
Index: compiler/llds_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/llds_out.m,v
retrieving revision 1.67
diff -u -u -r1.67 llds_out.m
--- llds_out.m 1997/12/22 06:58:22 1.67
+++ llds_out.m 1998/01/08 07:41:48
@@ -118,7 +118,8 @@
:- type decl_id ---> create_label(int)
; float_label(string)
; code_addr(code_addr)
- ; data_addr(data_addr).
+ ; data_addr(data_addr)
+ ; pragma_struct(string).
output_c_file(C_File) -->
globals__io_lookup_bool_option(split_c_files, SplitFiles),
@@ -686,7 +687,7 @@
(
Instr = call(_, label(ContLabel), _, _)
;
- Instr = mkframe(_Comment2, _SlotCount, label(ContLabel))
+ Instr = mkframe(_, _, _, label(ContLabel))
;
Instr = modframe(label(ContLabel))
;
@@ -786,10 +787,31 @@
output_code_addr_decls(Target, "", "", 0, _, DeclSet0, DeclSet1),
output_code_addr_decls(ContLabel, "", "", 0, _, DeclSet1, DeclSet).
output_instruction_decls(c_code(_), DeclSet, DeclSet) --> [].
-output_instruction_decls(mkframe(_, _, FailureContinuation),
+output_instruction_decls(mkframe(_, _, MaybeStruct, FailureContinuation),
DeclSet0, DeclSet) -->
+ (
+ { MaybeStruct = yes(pragma_struct(StructName,
+ StructFields, StructFieldsContext)) }
+ ->
+ { set__member(pragma_struct(StructName), DeclSet0) ->
+ string__append_list(["struct ", StructName, " has been declared already"], Msg),
+ error(Msg)
+ ;
+ true
+ },
+ io__write_string("struct "),
+ io__write_string(StructName),
+ io__write_string(" {\n"),
+ output_set_line_num(StructFieldsContext),
+ io__write_string(StructFields),
+ output_reset_line_num,
+ io__write_string("\n};\n"),
+ { set__insert(DeclSet0, pragma_struct(StructName), DeclSet1) }
+ ;
+ { DeclSet1 = DeclSet0 }
+ ),
output_code_addr_decls(FailureContinuation, "", "", 0, _,
- DeclSet0, DeclSet).
+ DeclSet1, DeclSet).
output_instruction_decls(modframe(FailureContinuation), DeclSet0, DeclSet) -->
output_code_addr_decls(FailureContinuation, "", "", 0, _,
DeclSet0, DeclSet).
@@ -819,10 +841,30 @@
output_rval_decls(Rval, "", "", 0, _, DeclSet0, DeclSet).
output_instruction_decls(incr_sp(_, _), DeclSet, DeclSet) --> [].
output_instruction_decls(decr_sp(_), DeclSet, DeclSet) --> [].
-output_instruction_decls(pragma_c(_Decls, Inputs, _C_Code, Outputs, _Context),
+output_instruction_decls(pragma_c(_, Components, _, _), DeclSet0, DeclSet) -->
+ output_pragma_component_list_decls(Components, DeclSet0, DeclSet).
+
+:- pred output_pragma_component_list_decls(list(pragma_c_component),
+ decl_set, decl_set, io__state, io__state).
+:- mode output_pragma_component_list_decls(in, in, out, di, uo) is det.
+
+output_pragma_component_list_decls([], DeclSet, DeclSet) --> [].
+output_pragma_component_list_decls([Component | Components],
DeclSet0, DeclSet) -->
- output_pragma_input_rval_decls(Inputs, DeclSet0, DeclSet1),
- output_pragma_output_lval_decls(Outputs, DeclSet1, DeclSet).
+ output_pragma_component_decls(Component, DeclSet0, DeclSet1),
+ output_pragma_component_list_decls(Components, DeclSet1, DeclSet).
+
+:- pred output_pragma_component_decls(pragma_c_component,
+ decl_set, decl_set, io__state, io__state).
+:- mode output_pragma_component_decls(in, in, out, di, uo) is det.
+
+output_pragma_component_decls(pragma_c_inputs(Inputs), DeclSet0, DeclSet) -->
+ output_pragma_input_rval_decls(Inputs, DeclSet0, DeclSet).
+output_pragma_component_decls(pragma_c_outputs(Outputs), DeclSet0, DeclSet) -->
+ output_pragma_output_lval_decls(Outputs, DeclSet0, DeclSet).
+output_pragma_component_decls(pragma_c_raw_code(_), DeclSet, DeclSet) --> [].
+output_pragma_component_decls(pragma_c_user_code(_, _), DeclSet, DeclSet)
+ --> [].
%-----------------------------------------------------------------------------%
@@ -977,14 +1019,26 @@
io__write_string("\t"),
io__write_string(C_Code_String).
-output_instruction(mkframe(Str, Num, FailureContinuation), _) -->
- io__write_string("\tmkframe("""),
- io__write_string(Str),
- io__write_string(""", "),
- io__write_int(Num),
- io__write_string(", "),
- output_code_addr(FailureContinuation),
- io__write_string(");\n").
+output_instruction(mkframe(Msg, Num, MaybePragmaStructName, FailCont), _) -->
+ ( { MaybePragmaStructName = yes(pragma_struct(StructName, _, _)) } ->
+ io__write_string("\tmkpragmaframe("""),
+ io__write_string(Msg),
+ io__write_string(""", "),
+ io__write_int(Num),
+ io__write_string(", "),
+ io__write_string(StructName),
+ io__write_string(", "),
+ output_code_addr(FailCont),
+ io__write_string(");\n")
+ ;
+ io__write_string("\tmkframe("""),
+ io__write_string(Msg),
+ io__write_string(""", "),
+ io__write_int(Num),
+ io__write_string(", "),
+ output_code_addr(FailCont),
+ io__write_string(");\n")
+ ).
output_instruction(modframe(FailureContinuation), _) -->
io__write_string("\tmodframe("),
@@ -1082,28 +1136,51 @@
io__write_int(N),
io__write_string(");\n").
- % The code we produce for pragma(c_code, ...) is in the form
- % {
- % <declaration of one local variable for each one in the proc>
- % <declarations for any rvals and lvals used, if needed>
- % <assignment of the input regs to the corresponding locals>
- % <the C code itself>
- % <assignment to the output regs of the corresponding locals>
- % }
-output_instruction(pragma_c(Decls, Inputs, C_Code, Outputs, Context), _) -->
+output_instruction(pragma_c(Decls, Components, _, _), _) -->
io__write_string("\t{\n"),
output_pragma_decls(Decls),
- output_pragma_inputs(Inputs),
- output_set_line_num(Context),
- io__write_string("{\t\t"),
- io__write_string(C_Code),
- io__write_string(";}\n"),
- output_reset_line_num,
- output_pragma_outputs(Outputs),
+ output_pragma_components(Components),
io__write_string("\n\t}\n").
+:- pred output_pragma_components(list(pragma_c_component),
+ io__state, io__state).
+:- mode output_pragma_components(in, di, uo) is det.
+
+output_pragma_components([]) --> [].
+output_pragma_components([C | Cs]) -->
+ output_pragma_component(C),
+ output_pragma_components(Cs).
+
+:- pred output_pragma_component(pragma_c_component, io__state, io__state).
+:- mode output_pragma_component(in, di, uo) is det.
+
+output_pragma_component(pragma_c_inputs(Inputs)) -->
+ output_pragma_inputs(Inputs).
+output_pragma_component(pragma_c_outputs(Outputs)) -->
+ output_pragma_outputs(Outputs).
+output_pragma_component(pragma_c_user_code(Context0, C_Code)) -->
+ ( { C_Code = "" } ->
+ []
+ ;
+ % We should start the C_Code on a new line,
+ % just in case it starts with a proprocessor directive.
+ % We must then account for the effect of the \n
+ % on the context.
+ { Context0 = term__context(File, Line0) },
+ { Line is Line0 - 1 },
+ { Context = term__context(File, Line) },
+ output_set_line_num(Context),
+ io__write_string("{\t\t\n"),
+ io__write_string(C_Code),
+ io__write_string(";}\n"),
+ output_reset_line_num
+ ).
+output_pragma_component(pragma_c_raw_code(C_Code)) -->
+ io__write_string(C_Code).
+
:- pred output_set_line_num(term__context, io__state, io__state).
:- mode output_set_line_num(in, di, uo) is det.
+
output_set_line_num(Context) -->
{ term__context_file(Context, File) },
{ term__context_line(Context, Line) },
@@ -1124,6 +1201,7 @@
:- pred output_reset_line_num(io__state, io__state).
:- mode output_reset_line_num(di, uo) is det.
+
output_reset_line_num -->
% We want to generate another #line directive to reset the C compiler's
% idea of what it is processing back to the file we are generating.
@@ -1150,14 +1228,23 @@
output_pragma_decls([]) --> [].
output_pragma_decls([D|Decls]) -->
- { D = pragma_c_decl(Type, VarName) },
+ (
+ { D = pragma_c_arg_decl(Type, VarName) },
% Apart from special cases, the local variables are Words
- { export__term_to_type_string(Type, VarType) },
- io__write_string("\t\t"),
- io__write_string(VarType),
- io__write_string("\t"),
- io__write_string(VarName),
- io__write_string(";\n"),
+ { export__term_to_type_string(Type, VarType) },
+ io__write_string("\t"),
+ io__write_string(VarType),
+ io__write_string("\t"),
+ io__write_string(VarName),
+ io__write_string(";\n")
+ ;
+ { D = pragma_c_struct_ptr_decl(StructTag, VarName) },
+ io__write_string("\tstruct "),
+ io__write_string(StructTag),
+ io__write_string("\t*"),
+ io__write_string(VarName),
+ io__write_string(";\n")
+ ),
output_pragma_decls(Decls).
% Output declarations for any rvals used to initialize the inputs
@@ -1179,7 +1266,7 @@
output_pragma_inputs([]) --> [].
output_pragma_inputs([I|Inputs]) -->
{ I = pragma_c_input(VarName, Type, Rval) },
- io__write_string("\t\t"),
+ io__write_string("\t"),
io__write_string(VarName),
io__write_string(" = "),
(
@@ -1216,7 +1303,7 @@
output_pragma_outputs([]) --> [].
output_pragma_outputs([O|Outputs]) -->
{ O = pragma_c_output(Lval, Type, VarName) },
- io__write_string("\t\t"),
+ io__write_string("\t"),
output_lval_as_word(Lval),
io__write_string(" = "),
(
@@ -1290,6 +1377,7 @@
:- pred output_gc_livevals_params(assoc_list(var, lval), io__state, io__state).
:- mode output_gc_livevals_params(in, di, uo) is det.
+
output_gc_livevals_params([]) --> [].
output_gc_livevals_params([Var - Lval | Lvals]) -->
{ term__var_to_int(Var, VarInt) },
@@ -1301,6 +1389,7 @@
:- pred output_live_value_type(live_value_type, io__state, io__state).
:- mode output_live_value_type(in, di, uo) is det.
+
output_live_value_type(succip) --> io__write_string("MR_succip").
output_live_value_type(curfr) --> io__write_string("MR_curfr").
output_live_value_type(maxfr) --> io__write_string("MR_maxfr").
@@ -1629,6 +1718,8 @@
{ error("output_decl_id: code_addr unexpected") }.
output_decl_id(float_label(_Label)) -->
{ error("output_decl_id: float_label unexpected") }.
+output_decl_id(pragma_struct(_Name)) -->
+ { error("output_decl_id: pragma_struct unexpected") }.
:- pred output_cons_arg_types(list(maybe(rval)), string, int,
io__state, io__state).
Index: compiler/make_hlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make_hlds.m,v
retrieving revision 1.250
diff -u -u -r1.250 make_hlds.m
--- make_hlds.m 1998/01/07 06:09:24 1.250
+++ make_hlds.m 1998/01/08 03:02:35
@@ -61,7 +61,7 @@
:- import_module make_tags, quantification, (inst).
:- import_module code_util, unify_proc, special_pred, type_util, mode_util.
:- import_module mercury_to_mercury, passes_aux, clause_to_proc, inst_match.
-:- import_module fact_table, purity, term_util.
+:- import_module fact_table, purity, goal_util, term_util.
:- import_module string, char, int, set, bintree, list, map, require.
:- import_module bool, getopt, assoc_list, term, term_io, varset.
@@ -306,11 +306,6 @@
{ Pragma = c_code(_, _, _, _, _, _) },
{ Module = Module0 }
;
- % Handle pragma c_code decls later on (when we process
- % clauses).
- { Pragma = c_code(_, _, _, _, _, _, _, _) },
- { Module = Module0 }
- ;
{ Pragma = memo(Name, Arity) },
add_pred_marker(Module0, "memo", Name, Arity, Context,
memo, [], Module1),
@@ -591,18 +586,10 @@
Module0, Module, Info0, Info) -->
(
{ Pragma = c_code(MayCallMercury, Pred, PredOrFunc, Vars,
- VarSet, C_Code) }
+ VarSet, PragmaCode) }
->
module_add_pragma_c_code(MayCallMercury, Pred, PredOrFunc,
- Vars, VarSet, C_Code, Status, Context, no,
- Module0, Module, Info0, Info)
- ;
- { Pragma = c_code(MayCallMercury, Pred, PredOrFunc, Vars,
- SavedVars, LabelNames, VarSet, C_Code) }
- ->
- { ExtraPragmaInfo = yes(SavedVars - LabelNames) },
- module_add_pragma_c_code(MayCallMercury, Pred, PredOrFunc,
- Vars, VarSet, C_Code, Status, Context, ExtraPragmaInfo,
+ Vars, VarSet, PragmaCode, Status, Context,
Module0, Module, Info0, Info)
;
{ Pragma = fact_table(Pred, Arity, File) }
@@ -1875,7 +1862,7 @@
( { Status \= opt_imported } ->
% warn about singleton variables
maybe_warn_singletons(VarSet,
- PredOrFunc - PredName/Arity, Goal),
+ PredOrFunc - PredName/Arity, ModuleInfo, Goal),
% warn about variables with overlapping scopes
maybe_warn_overlap(Warnings, VarSet, PredOrFunc,
PredName/Arity)
@@ -1909,15 +1896,14 @@
%-----------------------------------------------------------------------------%
:- pred module_add_pragma_c_code(may_call_mercury, sym_name, pred_or_func,
- list(pragma_var), varset, string, import_status, term__context,
- maybe(pair(list(string))), module_info, module_info,
- qual_info, qual_info, io__state, io__state).
-:- mode module_add_pragma_c_code(in, in, in, in, in, in, in, in, in, in, out,
- in, out, di, uo) is det.
+ list(pragma_var), varset, pragma_code, import_status, term__context,
+ module_info, module_info, qual_info, qual_info, io__state, io__state).
+:- mode module_add_pragma_c_code(in, in, in, in, in, in, in, in, in, out,
+ in, out, di, uo) is det.
module_add_pragma_c_code(MayCallMercury, PredName, PredOrFunc, PVars, VarSet,
- C_Code, Status, Context, ExtraInfo,
- ModuleInfo0, ModuleInfo, Info0, Info) -->
+ PragmaCode, Status, Context, ModuleInfo0, ModuleInfo,
+ Info0, Info) -->
{ module_info_name(ModuleInfo0, ModuleName) },
{ list__length(PVars, Arity) },
% print out a progress message
@@ -1946,8 +1932,8 @@
maybe_undefined_pred_error(PredName, Arity, PredOrFunc,
Context, "`:- pragma c_code' declaration"),
{ preds_add_implicit(PredicateTable0,
- ModuleName, PredName, Arity, Context,
- PredOrFunc, PredId, PredicateTable1) }
+ ModuleName, PredName, Arity, Context,
+ PredOrFunc, PredId, PredicateTable1) }
),
% Lookup the pred_info for this pred,
% add the pragma to the proc_info in the proc_table in the
@@ -1995,7 +1981,7 @@
{ pred_info_get_purity(PredInfo1, Purity) },
clauses_info_add_pragma_c_code(Clauses0, Purity,
MayCallMercury, PredId, ProcId, VarSet,
- PVars, ArgTypes, C_Code, Context, ExtraInfo,
+ PVars, ArgTypes, PragmaCode, Context,
Clauses, Info0, Info),
{ pred_info_set_clauses_info(PredInfo1, Clauses,
PredInfo2) },
@@ -2006,9 +1992,10 @@
PredicateTable) },
{ module_info_set_predicate_table(ModuleInfo0,
PredicateTable, ModuleInfo) },
- { pragma_get_var_names(PVars, Names) },
- maybe_warn_pragma_singletons(C_Code, Names,
- Context, PredOrFunc - PredName/Arity)
+ { pragma_get_var_infos(PVars, ArgInfo) },
+ maybe_warn_pragma_singletons(PragmaCode, ArgInfo,
+ Context, PredOrFunc - PredName/Arity,
+ ModuleInfo)
;
{ module_info_incr_errors(ModuleInfo0, ModuleInfo) },
io__stderr_stream(StdErr),
@@ -2029,9 +2016,10 @@
% from the list of pragma_vars extract the modes.
:- pred pragma_get_modes(list(pragma_var), list(mode)).
:- mode pragma_get_modes(in, out) is det.
+
pragma_get_modes([], []).
-pragma_get_modes([V|Vars], [M|Modes]) :-
- V = pragma_var(_Variable, _Name, M),
+pragma_get_modes([PragmaVar | Vars], [Mode | Modes]) :-
+ PragmaVar = pragma_var(_Var, _Name, Mode),
pragma_get_modes(Vars, Modes).
%-----------------------------------------------------------------------------%
@@ -2039,22 +2027,23 @@
% from the list of pragma_vars , extract the vars.
:- pred pragma_get_vars(list(pragma_var), list(var)).
:- mode pragma_get_vars(in, out) is det.
+
pragma_get_vars([], []).
-pragma_get_vars([P|PragmaVars], [V|Vars]) :-
- P = pragma_var(V, _Name, _Mode),
+pragma_get_vars([PragmaVar | PragmaVars], [Var | Vars]) :-
+ PragmaVar = pragma_var(Var, _Name, _Mode),
pragma_get_vars(PragmaVars, Vars).
%---------------------------------------------------------------------------%
% from the list of pragma_vars, extract the names.
-:- pred pragma_get_var_names(list(pragma_var), list(maybe(string))).
-:- mode pragma_get_var_names(in, out) is det.
+:- pred pragma_get_var_infos(list(pragma_var), list(maybe(pair(string, mode)))).
+:- mode pragma_get_var_infos(in, out) is det.
-pragma_get_var_names([], []).
-pragma_get_var_names([P|PragmaVars], [yes(N)|Names]) :-
- P = pragma_var(_Var, N, _Mode),
- pragma_get_var_names(PragmaVars, Names).
+pragma_get_var_infos([], []).
+pragma_get_var_infos([PragmaVar | PragmaVars], [yes(Name - Mode) | Info]) :-
+ PragmaVar = pragma_var(_Var, Name, Mode),
+ pragma_get_var_infos(PragmaVars, Info).
%---------------------------------------------------------------------------%
@@ -2195,52 +2184,53 @@
% Warn about variables which occur only once but don't start with
% an underscore, or about variables which do start with an underscore
- % but occur more than once.
+ % but occur more than once, or about variables that do not occur in
+ % C code strings when they should.
%
-:- pred maybe_warn_singletons(varset, pred_or_func_call_id, hlds_goal,
- io__state, io__state).
-:- mode maybe_warn_singletons(in, in, in, di, uo) is det.
+:- pred maybe_warn_singletons(varset, pred_or_func_call_id, module_info,
+ hlds_goal, io__state, io__state).
+:- mode maybe_warn_singletons(in, in, in, in, di, uo) is det.
-maybe_warn_singletons(VarSet, PredCallId, Body) -->
+maybe_warn_singletons(VarSet, PredCallId, ModuleInfo, Body) -->
globals__io_lookup_bool_option(warn_singleton_vars, WarnSingletonVars),
( { WarnSingletonVars = yes } ->
{ set__init(QuantVars) },
- warn_singletons_in_goal(Body, QuantVars, VarSet, PredCallId)
+ warn_singletons_in_goal(Body, QuantVars, VarSet, PredCallId,
+ ModuleInfo)
;
[]
).
:- pred warn_singletons_in_goal(hlds_goal, set(var), varset,
- pred_or_func_call_id, io__state, io__state).
-:- mode warn_singletons_in_goal(in, in, in, in, di, uo) is det.
+ pred_or_func_call_id, module_info, io__state, io__state).
+:- mode warn_singletons_in_goal(in, in, in, in, in, di, uo) is det.
-warn_singletons_in_goal(Goal - GoalInfo, QuantVars, VarSet, PredCallId) -->
+warn_singletons_in_goal(Goal - GoalInfo, QuantVars, VarSet, PredCallId, MI) -->
warn_singletons_in_goal_2(Goal, GoalInfo, QuantVars, VarSet,
- PredCallId).
+ PredCallId, MI).
:- pred warn_singletons_in_goal_2(hlds_goal_expr, hlds_goal_info, set(var),
- varset, pred_or_func_call_id,
- io__state, io__state).
-:- mode warn_singletons_in_goal_2(in, in, in, in, in, di, uo) is det.
+ varset, pred_or_func_call_id, module_info, io__state, io__state).
+:- mode warn_singletons_in_goal_2(in, in, in, in, in, in, di, uo) is det.
warn_singletons_in_goal_2(conj(Goals), _GoalInfo, QuantVars, VarSet,
- PredCallId) -->
- warn_singletons_in_goal_list(Goals, QuantVars, VarSet, PredCallId).
+ PredCallId, MI) -->
+ warn_singletons_in_goal_list(Goals, QuantVars, VarSet, PredCallId, MI).
warn_singletons_in_goal_2(disj(Goals, _), _GoalInfo, QuantVars, VarSet,
- PredCallId) -->
- warn_singletons_in_goal_list(Goals, QuantVars, VarSet, PredCallId).
+ PredCallId, MI) -->
+ warn_singletons_in_goal_list(Goals, QuantVars, VarSet, PredCallId, MI).
warn_singletons_in_goal_2(switch(_Var, _CanFail, Cases, _),
- _GoalInfo, QuantVars, VarSet, PredCallId) -->
- warn_singletons_in_cases(Cases, QuantVars, VarSet, PredCallId).
+ _GoalInfo, QuantVars, VarSet, PredCallId, MI) -->
+ warn_singletons_in_cases(Cases, QuantVars, VarSet, PredCallId, MI).
warn_singletons_in_goal_2(not(Goal), _GoalInfo, QuantVars, VarSet,
- PredCallId) -->
- warn_singletons_in_goal(Goal, QuantVars, VarSet, PredCallId).
+ PredCallId, MI) -->
+ warn_singletons_in_goal(Goal, QuantVars, VarSet, PredCallId, MI).
warn_singletons_in_goal_2(some(Vars, SubGoal), GoalInfo, QuantVars, VarSet,
- PredCallId) -->
+ PredCallId, MI) -->
%
% warn if any quantified variables occur only in the quantifier
%
@@ -2254,10 +2244,10 @@
[]
),
{ set__insert_list(QuantVars, Vars, QuantVars1) },
- warn_singletons_in_goal(SubGoal, QuantVars1, VarSet, PredCallId).
+ warn_singletons_in_goal(SubGoal, QuantVars1, VarSet, PredCallId, MI).
warn_singletons_in_goal_2(if_then_else(Vars, Cond, Then, Else, _), GoalInfo,
- QuantVars, VarSet, PredCallId) -->
+ QuantVars, VarSet, PredCallId, MI) -->
%
% warn if any quantified variables do not occur in the condition
% or the "then" part of the if-then-else
@@ -2275,19 +2265,19 @@
),
{ set__insert_list(QuantVars, Vars, QuantVars1) },
- warn_singletons_in_goal(Cond, QuantVars1, VarSet, PredCallId),
- warn_singletons_in_goal(Then, QuantVars1, VarSet, PredCallId),
- warn_singletons_in_goal(Else, QuantVars, VarSet, PredCallId).
+ warn_singletons_in_goal(Cond, QuantVars1, VarSet, PredCallId, MI),
+ warn_singletons_in_goal(Then, QuantVars1, VarSet, PredCallId, MI),
+ warn_singletons_in_goal(Else, QuantVars, VarSet, PredCallId, MI).
warn_singletons_in_goal_2(call(_, _, Args, _, _, _),
- GoalInfo, QuantVars, VarSet, PredCallId) -->
+ GoalInfo, QuantVars, VarSet, PredCallId, _) -->
{ goal_info_get_nonlocals(GoalInfo, NonLocals) },
{ goal_info_get_context(GoalInfo, Context) },
warn_singletons(Args, NonLocals, QuantVars, VarSet, Context,
PredCallId).
warn_singletons_in_goal_2(higher_order_call(_, Args, _, _, _, _),
- GoalInfo, QuantVars, VarSet, PredCallId) -->
+ GoalInfo, QuantVars, VarSet, PredCallId, _) -->
{ goal_info_get_nonlocals(GoalInfo, NonLocals) },
{ goal_info_get_context(GoalInfo, Context) },
warn_singletons(Args, NonLocals, QuantVars, VarSet, Context,
@@ -2295,54 +2285,56 @@
% This code should never be called anyway.
warn_singletons_in_goal_2(class_method_call(_, _, Args, _, _, _),
- GoalInfo, QuantVars, VarSet, PredCallId) -->
+ GoalInfo, QuantVars, VarSet, PredCallId, _) -->
{ goal_info_get_nonlocals(GoalInfo, NonLocals) },
{ goal_info_get_context(GoalInfo, Context) },
warn_singletons(Args, NonLocals, QuantVars, VarSet, Context,
PredCallId).
warn_singletons_in_goal_2(unify(Var, RHS, _, _, _),
- GoalInfo, QuantVars, VarSet, PredCallId) -->
+ GoalInfo, QuantVars, VarSet, PredCallId, MI) -->
warn_singletons_in_unify(Var, RHS, GoalInfo, QuantVars, VarSet,
- PredCallId).
+ PredCallId, MI).
-warn_singletons_in_goal_2(pragma_c_code(C_Code, _, _, _, _, ArgNames, _, _),
- GoalInfo, _QuantVars, _VarSet, PredCallId) -->
+warn_singletons_in_goal_2(pragma_c_code(_, _, _, _, ArgInfo, _, PragmaCode),
+ GoalInfo, _QuantVars, _VarSet, PredCallId, MI) -->
{ goal_info_get_context(GoalInfo, Context) },
- warn_singletons_in_pragma_c_code(C_Code, ArgNames, Context,
- PredCallId).
+ warn_singletons_in_pragma_c_code(PragmaCode, ArgInfo, Context,
+ PredCallId, MI).
:- pred warn_singletons_in_goal_list(list(hlds_goal), set(var), varset,
- pred_or_func_call_id, io__state, io__state).
-:- mode warn_singletons_in_goal_list(in, in, in, in, di, uo) is det.
+ pred_or_func_call_id, module_info, io__state, io__state).
+:- mode warn_singletons_in_goal_list(in, in, in, in, in, di, uo) is det.
-warn_singletons_in_goal_list([], _, _, _) --> [].
-warn_singletons_in_goal_list([Goal|Goals], QuantVars, VarSet, CallPredId) -->
- warn_singletons_in_goal(Goal, QuantVars, VarSet, CallPredId),
- warn_singletons_in_goal_list(Goals, QuantVars, VarSet, CallPredId).
+warn_singletons_in_goal_list([], _, _, _, _) --> [].
+warn_singletons_in_goal_list([Goal|Goals], QuantVars, VarSet, CallPredId, MI)
+ -->
+ warn_singletons_in_goal(Goal, QuantVars, VarSet, CallPredId, MI),
+ warn_singletons_in_goal_list(Goals, QuantVars, VarSet, CallPredId, MI).
:- pred warn_singletons_in_cases(list(case), set(var), varset,
- pred_or_func_call_id, io__state, io__state).
-:- mode warn_singletons_in_cases(in, in, in, in, di, uo) is det.
+ pred_or_func_call_id, module_info, io__state, io__state).
+:- mode warn_singletons_in_cases(in, in, in, in, in, di, uo) is det.
-warn_singletons_in_cases([], _, _, _) --> [].
-warn_singletons_in_cases([Case|Cases], QuantVars, VarSet, CallPredId) -->
+warn_singletons_in_cases([], _, _, _, _) --> [].
+warn_singletons_in_cases([Case|Cases], QuantVars, VarSet, CallPredId, MI) -->
{ Case = case(_ConsId, Goal) },
- warn_singletons_in_goal(Goal, QuantVars, VarSet, CallPredId),
- warn_singletons_in_cases(Cases, QuantVars, VarSet, CallPredId).
+ warn_singletons_in_goal(Goal, QuantVars, VarSet, CallPredId, MI),
+ warn_singletons_in_cases(Cases, QuantVars, VarSet, CallPredId, MI).
:- pred warn_singletons_in_unify(var, unify_rhs, hlds_goal_info, set(var),
- varset, pred_or_func_call_id, io__state, io__state).
-:- mode warn_singletons_in_unify(in, in, in, in, in, in, di, uo) is det.
+ varset, pred_or_func_call_id, module_info, io__state, io__state).
+:- mode warn_singletons_in_unify(in, in, in, in, in, in, in, di, uo) is det.
-warn_singletons_in_unify(X, var(Y), GoalInfo, QuantVars, VarSet, CallPredId) -->
+warn_singletons_in_unify(X, var(Y), GoalInfo, QuantVars, VarSet, CallPredId, _)
+ -->
{ goal_info_get_nonlocals(GoalInfo, NonLocals) },
{ goal_info_get_context(GoalInfo, Context) },
warn_singletons([X, Y], NonLocals, QuantVars, VarSet,
Context, CallPredId).
warn_singletons_in_unify(X, functor(_ConsId, Vars), GoalInfo, QuantVars, VarSet,
- CallPredId) -->
+ CallPredId, _) -->
{ goal_info_get_nonlocals(GoalInfo, NonLocals) },
{ goal_info_get_context(GoalInfo, Context) },
warn_singletons([X | Vars], NonLocals, QuantVars, VarSet,
@@ -2350,7 +2342,7 @@
warn_singletons_in_unify(X, lambda_goal(_PredOrFunc, LambdaVars, _Modes, _Det,
LambdaGoal),
- GoalInfo, QuantVars, VarSet, CallPredId) -->
+ GoalInfo, QuantVars, VarSet, CallPredId, MI) -->
%
% warn if any lambda-quantified variables occur only in the quantifier
%
@@ -2370,57 +2362,152 @@
%
% warn if the lambda-goal contains singletons
%
- warn_singletons_in_goal(LambdaGoal, QuantVars, VarSet, CallPredId).
+ warn_singletons_in_goal(LambdaGoal, QuantVars, VarSet, CallPredId, MI).
%-----------------------------------------------------------------------------%
-:- pred maybe_warn_pragma_singletons(string, list(maybe(string)),
- term__context, pred_or_func_call_id, io__state, io__state).
-:- mode maybe_warn_pragma_singletons(in, in, in, in, di, uo) is det.
+:- pred maybe_warn_pragma_singletons(pragma_code,
+ list(maybe(pair(string, mode))), term__context, pred_or_func_call_id,
+ module_info, io__state, io__state).
+:- mode maybe_warn_pragma_singletons(in, in, in, in, in, di, uo) is det.
-maybe_warn_pragma_singletons(C_Code, ArgNames, Context, CallId) -->
+maybe_warn_pragma_singletons(PragmaCode, ArgInfo, Context, CallId, MI) -->
globals__io_lookup_bool_option(warn_singleton_vars, WarnSingletonVars),
( { WarnSingletonVars = yes } ->
- warn_singletons_in_pragma_c_code(C_Code, ArgNames,
- Context, CallId)
+ warn_singletons_in_pragma_c_code(PragmaCode, ArgInfo,
+ Context, CallId, MI)
;
[]
).
% warn_singletons_in_pragma_c_code checks to see if each variable is
- % a substring of the given c code. If not, it gives a warning
-:- pred warn_singletons_in_pragma_c_code(string, list(maybe(string)),
- term__context, pred_or_func_call_id, io__state, io__state).
-:- mode warn_singletons_in_pragma_c_code(in, in, in, in, di, uo) is det.
-
-warn_singletons_in_pragma_c_code(C_Code, ArgNames,
- Context, PredOrFunc - PredCallId) -->
- { c_code_to_name_list(C_Code, C_CodeList) },
- { solutions(lambda([Name::out] is nondet, (
- list__member(yes(Name), ArgNames),
- \+ string__prefix(Name, "_"),
- \+ list__member(Name, C_CodeList)
- )), SingletonVars) },
- ( { SingletonVars = [] } ->
- []
+ % mentioned at least once in the c code fragments that ought to
+ % mention it. If not, it gives a warning.
+:- pred warn_singletons_in_pragma_c_code(pragma_code,
+ list(maybe(pair(string, mode))), term__context, pred_or_func_call_id,
+ module_info, io__state, io__state).
+:- mode warn_singletons_in_pragma_c_code(in, in, in, in, in, di, uo) is det.
+
+warn_singletons_in_pragma_c_code(PragmaCode, ArgInfo,
+ Context, PredOrFunc - PredCallId, ModuleInfo) -->
+ (
+ { PragmaCode = ordinary(C_Code, _) },
+ { c_code_to_name_list(C_Code, C_CodeList) },
+ { solutions(lambda([Name::out] is nondet, (
+ list__member(yes(Name - _), ArgInfo),
+ \+ string__prefix(Name, "_"),
+ \+ list__member(Name, C_CodeList)
+ )), UnmentionedVars) },
+ ( { UnmentionedVars = [] } ->
+ []
+ ;
+ io__stderr_stream(StdErr1),
+ io__set_output_stream(StdErr1, OldStream1),
+ prog_out__write_context(Context),
+ io__write_string("In `:- pragma c_code' for "),
+ hlds_out__write_call_id(PredOrFunc, PredCallId),
+ io__write_string(":\n"),
+ prog_out__write_context(Context),
+ ( { UnmentionedVars = [_] } ->
+ io__write_string(" warning: variable `"),
+ write_string_list(UnmentionedVars),
+ io__write_string("' does not occur in the C code.\n")
+ ;
+ io__write_string(" warning: variables `"),
+ write_string_list(UnmentionedVars),
+ io__write_string("' do not occur in the C code.\n")
+ ),
+ io__set_output_stream(OldStream1, _)
+ )
;
- io__stderr_stream(StdErr),
- io__set_output_stream(StdErr, OldStream),
- prog_out__write_context(Context),
- io__write_string("In `:- pragma c_code' for "),
- hlds_out__write_call_id(PredOrFunc, PredCallId),
- io__write_string(":\n"),
- prog_out__write_context(Context),
- ( { SingletonVars = [_] } ->
- io__write_string(" warning: variable `"),
- write_string_list(SingletonVars),
- io__write_string("' does not occur in the C code.\n")
- ;
- io__write_string(" warning: variables `"),
- write_string_list(SingletonVars),
- io__write_string("' do not occur in the C code.\n")
+ { PragmaCode = nondet(_, _, FirstCode, _,
+ LaterCode, _, _, SharedCode, _) },
+ { c_code_to_name_list(FirstCode, FirstCodeList) },
+ { c_code_to_name_list(LaterCode, LaterCodeList) },
+ { c_code_to_name_list(SharedCode, SharedCodeList) },
+ { solutions(lambda([Name::out] is nondet, (
+ list__member(yes(Name - Mode), ArgInfo),
+ mode_is_input(ModuleInfo, Mode),
+ \+ string__prefix(Name, "_"),
+ \+ list__member(Name, FirstCodeList)
+ )), UnmentionedInputVars) },
+ ( { UnmentionedInputVars = [] } ->
+ []
+ ;
+ io__stderr_stream(StdErr2),
+ io__set_output_stream(StdErr2, OldStream2),
+ prog_out__write_context(Context),
+ io__write_string("In `:- pragma c_code' for "),
+ hlds_out__write_call_id(PredOrFunc, PredCallId),
+ io__write_string(":\n"),
+ prog_out__write_context(Context),
+ ( { UnmentionedInputVars = [_] } ->
+ io__write_string(" warning: variable `"),
+ write_string_list(UnmentionedInputVars),
+ io__write_string("' does not occur in the first C code.\n")
+ ;
+ io__write_string(" warning: variables `"),
+ write_string_list(UnmentionedInputVars),
+ io__write_string("' do not occur in the first C code.\n")
+ ),
+ io__set_output_stream(OldStream2, _)
),
- io__set_output_stream(OldStream, _)
+ { solutions(lambda([Name::out] is nondet, (
+ list__member(yes(Name - Mode), ArgInfo),
+ mode_is_output(ModuleInfo, Mode),
+ \+ string__prefix(Name, "_"),
+ \+ list__member(Name, FirstCodeList),
+ \+ list__member(Name, SharedCodeList)
+ )), UnmentionedFirstOutputVars) },
+ ( { UnmentionedFirstOutputVars = [] } ->
+ []
+ ;
+ io__stderr_stream(StdErr3),
+ io__set_output_stream(StdErr3, OldStream3),
+ prog_out__write_context(Context),
+ io__write_string("In `:- pragma c_code' for "),
+ hlds_out__write_call_id(PredOrFunc, PredCallId),
+ io__write_string(":\n"),
+ prog_out__write_context(Context),
+ ( { UnmentionedFirstOutputVars = [_] } ->
+ io__write_string(" warning: variable `"),
+ write_string_list(UnmentionedFirstOutputVars),
+ io__write_string("' does not occur in the first C code or the shared C code.\n")
+ ;
+ io__write_string(" warning: variables `"),
+ write_string_list(UnmentionedFirstOutputVars),
+ io__write_string("' do not occur in the first C code or the shared C code.\n")
+ ),
+ io__set_output_stream(OldStream3, _)
+ ),
+ { solutions(lambda([Name::out] is nondet, (
+ list__member(yes(Name - Mode), ArgInfo),
+ mode_is_output(ModuleInfo, Mode),
+ \+ string__prefix(Name, "_"),
+ \+ list__member(Name, LaterCodeList),
+ \+ list__member(Name, SharedCodeList)
+ )), UnmentionedLaterOutputVars) },
+ ( { UnmentionedLaterOutputVars = [] } ->
+ []
+ ;
+ io__stderr_stream(StdErr4),
+ io__set_output_stream(StdErr4, OldStream4),
+ prog_out__write_context(Context),
+ io__write_string("In `:- pragma c_code' for "),
+ hlds_out__write_call_id(PredOrFunc, PredCallId),
+ io__write_string(":\n"),
+ prog_out__write_context(Context),
+ ( { UnmentionedLaterOutputVars = [_] } ->
+ io__write_string(" warning: variable `"),
+ write_string_list(UnmentionedLaterOutputVars),
+ io__write_string("' does not occur in the retry C code or the shared C code.\n")
+ ;
+ io__write_string(" warning: variables `"),
+ write_string_list(UnmentionedLaterOutputVars),
+ io__write_string("' do not occur in the retry C code or the shared C code.\n")
+ ),
+ io__set_output_stream(OldStream4, _)
+ )
).
%-----------------------------------------------------------------------------%
@@ -2626,51 +2713,42 @@
:- pred clauses_info_add_pragma_c_code(clauses_info, purity, may_call_mercury,
pred_id, proc_id, varset, list(pragma_var), list(type),
- string, term__context,
- maybe(pair(list(string))), clauses_info,
+ pragma_code, term__context, clauses_info,
qual_info, qual_info, io__state, io__state) is det.
:- mode clauses_info_add_pragma_c_code(in, in, in, in, in, in, in, in, in, in,
- in, out, in, out, di, uo) is det.
+ out, in, out, di, uo) is det.
clauses_info_add_pragma_c_code(ClausesInfo0, Purity, MayCallMercury, PredId,
- ModeId, PVarSet, PVars, OrigArgTypes, C_Code, Context,
- ExtraInfo, ClausesInfo, Info0, Info) -->
+ ModeId, PVarSet, PVars, OrigArgTypes, PragmaCode, Context,
+ ClausesInfo, Info0, Info) -->
{
ClausesInfo0 = clauses_info(VarSet0, VarTypes, VarTypes1,
HeadVars, ClauseList),
pragma_get_vars(PVars, Args0),
- pragma_get_var_names(PVars, Names),
+ pragma_get_var_infos(PVars, ArgInfo),
% merge the varsets of the proc and the new pragma_c_code
varset__merge_subst(VarSet0, PVarSet, VarSet1, Subst),
map__apply_to_list(Args0, Subst, TermArgs),
term__term_list_to_var_list(TermArgs, Args),
- (
- ExtraInfo = no,
- ExtraPragmaInfo = none,
- VarSet2 = VarSet1
- ;
- ExtraInfo = yes(SavedVarNames - LabelNames),
- allocate_vars_for_saved_vars(SavedVarNames, SavedVars,
- VarSet1, VarSet2),
- ExtraPragmaInfo = extra_pragma_info(SavedVars, LabelNames)
- ),
-
% build the pragma_c_code
goal_info_init(GoalInfo0),
goal_info_set_context(GoalInfo0, Context, GoalInfo1),
% Put the purity in the goal_info in case this c code is inlined
add_goal_info_purity_feature(GoalInfo1, Purity, GoalInfo),
- HldsGoal0 = pragma_c_code(C_Code, MayCallMercury, PredId, ModeId, Args,
- Names, OrigArgTypes, ExtraPragmaInfo) - GoalInfo
+ HldsGoal0 = pragma_c_code(MayCallMercury, PredId, ModeId, Args,
+ ArgInfo, OrigArgTypes, PragmaCode) - GoalInfo
},
- % Insert unifications with the head args.
- insert_arg_unifications(HeadVars, TermArgs, Context, head, HldsGoal0,
- VarSet2, HldsGoal1, VarSet3, Info0, Info),
+ % Apply unifications with the head args.
+ % Since the set of head vars and the set vars in the
+ % pragma C code are disjoint, the unifications can be
+ % implemented as substitutions, and they will be.
+ insert_arg_unifications(HeadVars, TermArgs, Context, head, yes,
+ HldsGoal0, VarSet1, HldsGoal1, VarSet2, Info0, Info),
{
map__init(Empty),
- implicitly_quantify_clause_body(HeadVars, HldsGoal1, VarSet3, Empty,
+ implicitly_quantify_clause_body(HeadVars, HldsGoal1, VarSet2, Empty,
HldsGoal, VarSet, _, _Warnings),
NewClause = clause([ModeId], HldsGoal, Context),
ClausesInfo = clauses_info(VarSet, VarTypes, VarTypes1, HeadVars,
@@ -2699,8 +2777,8 @@
Goal, VarSet, Warnings, Info0, Info) -->
transform_goal(Body, VarSet0, Subst, Goal1, VarSet1, Info0, Info1),
{ term__apply_substitution_to_list(Args0, Subst, Args) },
- insert_arg_unifications(HeadVars, Args, Context, head, Goal1, VarSet1,
- Goal2, VarSet2, Info1, Info),
+ insert_arg_unifications(HeadVars, Args, Context, head, no,
+ Goal1, VarSet1, Goal2, VarSet2, Info1, Info),
{ map__init(Empty) },
{ implicitly_quantify_clause_body(HeadVars, Goal2, VarSet2, Empty,
Goal, VarSet, _, Warnings) }.
@@ -2862,7 +2940,7 @@
{ list__length(Args, Arity) },
{ PredCallId = Name/Arity },
insert_arg_unifications(HeadVars, Args,
- Context, call(PredCallId),
+ Context, call(PredCallId), no,
Goal0, VarSet1, Goal, VarSet, Info0, Info)
).
@@ -2873,7 +2951,6 @@
unravel_unification(A, B, Context, explicit, [],
VarSet0, Goal, VarSet, Info0, Info).
-
%-----------------------------------------------------------------------------
% `insert_arg_unifications' takes a list of variables,
@@ -2884,6 +2961,17 @@
% It also gets passed a `arg_context', which indicates
% where the terms came from.
+ % We never insert unifications of the form X = X.
+ % If ForPragmaC is yes, we process unifications of the form
+ % X = Y by substituting the var expected by the outside environment
+ % (the head variable) for the variable inside the goal (which was
+ % created just for the pragma_c_code goal), while giving the headvar
+ % the name of the just eliminated variable. The result is will be
+ % a proc_info in which the head variables have meaningful names
+ % and the body goal is just a pragma C code. Without this special
+ % treatment, the body goal will be a conjunction, which would
+ % complicate the handling of code generation for nondet pragma C codes.
+
:- type arg_context
---> head % the arguments in the head of the clause
; call(pred_call_id) % the arguments in a call to a predicate
@@ -2894,13 +2982,13 @@
).
:- pred insert_arg_unifications(list(var), list(term),
- term__context, arg_context, hlds_goal, varset, hlds_goal,
+ term__context, arg_context, bool, hlds_goal, varset, hlds_goal,
varset, qual_info, qual_info, io__state, io__state).
-:- mode insert_arg_unifications(in, in, in, in, in, in, out, out,
- in, out, di, uo) is det.
+:- mode insert_arg_unifications(in, in, in, in, in, in, in, out,
+ out, in, out, di, uo) is det.
-insert_arg_unifications(HeadVars, Args, Context, ArgContext, Goal0, VarSet0,
- Goal, VarSet, Info0, Info) -->
+insert_arg_unifications(HeadVars, Args, Context, ArgContext, ForPragmaC,
+ Goal0, VarSet0, Goal, VarSet, Info0, Info) -->
( { HeadVars = [] } ->
{ Goal = Goal0 },
{ VarSet = VarSet0 },
@@ -2909,30 +2997,52 @@
{ Goal0 = _ - GoalInfo },
{ goal_to_conj_list(Goal0, List0) },
insert_arg_unifications_2(HeadVars, Args, Context, ArgContext,
- 0, List0, VarSet0, List, VarSet, Info0, Info),
+ ForPragmaC, 0, List0, VarSet0, List, VarSet,
+ Info0, Info),
{ conj_list_to_goal(List, GoalInfo, Goal) }
).
:- pred insert_arg_unifications_2(list(var), list(term),
- term__context, arg_context, int, list(hlds_goal), varset,
+ term__context, arg_context, bool, int, list(hlds_goal), varset,
list(hlds_goal), varset, qual_info, qual_info,
io__state, io__state).
-:- mode insert_arg_unifications_2(in, in, in, in, in, in, in, out,
- out, in, out, di, uo) is det.
+:- mode insert_arg_unifications_2(in, in, in, in, in, in, in, in,
+ out, out, in, out, di, uo) is det.
-insert_arg_unifications_2([], [_|_], _, _, _, _, _, _, _, _, _) -->
+insert_arg_unifications_2([], [_|_], _, _, _, _, _, _, _, _, _, _) -->
{ error("insert_arg_unifications_2: length mismatch") }.
-insert_arg_unifications_2([_|_], [], _, _, _, _, _, _, _, _, _) -->
+insert_arg_unifications_2([_|_], [], _, _, _, _, _, _, _, _, _, _) -->
{ error("insert_arg_unifications_2: length mismatch") }.
-insert_arg_unifications_2([], [], _, _, _, List, VarSet, List, VarSet,
- Info, Info) --> [].
-insert_arg_unifications_2([Var|Vars], [Arg|Args], Context, ArgContext, N0,
- List0, VarSet0, List, VarSet, Info0, Info) -->
+insert_arg_unifications_2([], [], _, _, _, _, List, VarSet, List, VarSet,
+ Info, Info) --> [].
+insert_arg_unifications_2([Var|Vars], [Arg|Args], Context, ArgContext,
+ ForPragmaC, N0, List0, VarSet0, List, VarSet, Info0, Info) -->
{ N1 is N0 + 1 },
- % skip unifications of the form `X = X'
- ( { Arg = term__variable(Var) } ->
- insert_arg_unifications_2(Vars, Args, Context, ArgContext, N1,
- List0, VarSet0, List, VarSet, Info0, Info)
+ (
+ { Arg = term__variable(Var) }
+ ->
+ % Skip unifications of the form `X = X'
+ insert_arg_unifications_2(Vars, Args, Context,
+ ArgContext, ForPragmaC, N1, List0, VarSet0, List,
+ VarSet, Info0, Info)
+ ;
+ { Arg = term__variable(ArgVar) },
+ { ForPragmaC = yes }
+ ->
+ % Handle unifications of the form `X = Y' by substitution
+ % if this is safe.
+ { map__init(Subst0) },
+ { map__det_insert(Subst0, ArgVar, Var, Subst) },
+ { goal_util__rename_vars_in_goals(List0, no, Subst,
+ List1) },
+ { varset__search_name(VarSet0, ArgVar, ArgVarName) ->
+ varset__name_var(VarSet0, Var, ArgVarName, VarSet1)
+ ;
+ VarSet1 = VarSet0
+ },
+ insert_arg_unifications_2(Vars, Args, Context, ArgContext,
+ ForPragmaC, N1, List1, VarSet1, List, VarSet,
+ Info0, Info)
;
{ arg_context_to_unify_context(ArgContext, N1,
UnifyMainContext, UnifySubContext) },
@@ -2942,7 +3052,8 @@
{ goal_to_conj_list(Goal, ConjList) },
{ list__append(ConjList, List1, List) },
insert_arg_unifications_2(Vars, Args, Context, ArgContext,
- N1, List0, VarSet1, List1, VarSet, Info1, Info)
+ ForPragmaC, N1, List0, VarSet1, List1, VarSet,
+ Info1, Info)
).
% append_arg_unifications is the same as insert_arg_unifications,
@@ -3121,7 +3232,7 @@
{ map__init(Substitution) },
transform_goal(ParsedGoal, VarSet2, Substitution,
HLDS_Goal0, VarSet3, Info1, Info2),
- insert_arg_unifications(Vars, Vars1, Context, head,
+ insert_arg_unifications(Vars, Vars1, Context, head, no,
HLDS_Goal0, VarSet3, HLDS_Goal, VarSet, Info2, Info),
{ create_atomic_unification(X,
lambda_goal(predicate, Vars, Modes, Det, HLDS_Goal),
@@ -3149,7 +3260,7 @@
{ map__init(Substitution) },
transform_goal(ParsedGoal, VarSet2, Substitution,
HLDS_Goal0, VarSet3, Info1, Info2),
- insert_arg_unifications(Vars, Vars1, Context, head,
+ insert_arg_unifications(Vars, Vars1, Context, head, no,
HLDS_Goal0, VarSet3, HLDS_Goal, VarSet, Info2, Info),
{ create_atomic_unification(X,
lambda_goal(predicate, Vars, Modes, Det, HLDS_Goal),
@@ -3180,7 +3291,7 @@
{ map__init(Substitution) },
transform_goal(ParsedGoal, VarSet2, Substitution,
HLDS_Goal0, VarSet3, Info1, Info2),
- insert_arg_unifications(Vars, Vars1, Context, head,
+ insert_arg_unifications(Vars, Vars1, Context, head, no,
HLDS_Goal0, VarSet3, HLDS_Goal, VarSet, Info2, Info),
{ create_atomic_unification(X,
lambda_goal(function, Vars, Modes, Det, HLDS_Goal),
@@ -3245,7 +3356,7 @@
MainContext, SubContext) },
% Should this be insert_... rather than append_...?
% No, because that causes efficiency problems
- % with type-checking :-(
+ % with type-checking :-|
append_arg_unifications(HeadVars, FunctorArgs,
FunctorContext, ArgContext, Goal0,
VarSet1, Goal, VarSet, Info0, Info)
@@ -3678,7 +3789,6 @@
hlds_out__write_pred_call_id(Name/Arity),
io__write_string(".\n").
-
%-----------------------------------------------------------------------------%
% module_add_pragma_fact_table(PredName, Arity, FileName,
% Status, Context, Module0, Module, Info0, Info)
@@ -3799,10 +3909,10 @@
fact_table_generate_c_code(SymName, PragmaVars, ProcID, PrimaryProcID,
ProcInfo, ArgTypes, Module0, C_ProcCode, C_ExtraCode),
- % XXX this should be modified to use the new type of pragma_c.
+ % XXX this should be modified to use nondet pragma_code.
module_add_pragma_c_code(will_not_call_mercury, SymName, PredOrFunc,
- PragmaVars, VarSet, C_ProcCode, Status, Context, no,
- Module0, Module1, Info0, Info),
+ PragmaVars, VarSet, ordinary(C_ProcCode, Context),
+ Status, Context, Module0, Module1, Info0, Info),
{
C_ExtraCode = ""
->
More information about the developers
mailing list