for review: nondet pragma C codes
Zoltan Somogyi
zs at cs.mu.oz.au
Fri Jan 9 13:52:01 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 = ""
->
Index: compiler/mercury_compile.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_compile.m,v
retrieving revision 1.70
diff -u -u -r1.70 mercury_compile.m
--- mercury_compile.m 1998/01/06 23:50:54 1.70
+++ mercury_compile.m 1998/01/08 03:02:37
@@ -515,8 +515,6 @@
)
).
-
-
:- pred mercury_compile__maybe_write_optfile(bool::in, module_info::in,
module_info::out, io__state::di, io__state::uo) is det.
@@ -567,7 +565,6 @@
{ HLDS = HLDS0 }
).
-
:- pred mercury_compile__output_trans_opt_file(module_info,
io__state, io__state).
:- mode mercury_compile__output_trans_opt_file(in, di, uo) is det.
@@ -583,7 +580,6 @@
trans_opt__write_optfile(HLDS28).
-
:- pred mercury_compile__frontend_pass_2(module_info, module_info,
bool, io__state, io__state).
% :- mode mercury_compile__frontend_pass_2(di, uo, out, di, uo) is det.
@@ -977,7 +973,6 @@
{ ModuleInfo = ModuleInfo5 }
).
-
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -1167,7 +1162,7 @@
process_all_nonimported_procs(
update_proc_error(simplify__proc(Simplify)),
HLDS0, HLDS),
- maybe_write_string(Verbose, "% done\n"),
+ maybe_write_string(Verbose, "% done.\n"),
maybe_report_stats(Stats).
%-----------------------------------------------------------------------------%
@@ -1469,7 +1464,6 @@
{ generate_arg_info(HLDS0, Args, HLDS) },
maybe_write_string(Verbose, " done.\n"),
maybe_report_stats(Stats).
-
:- pred mercury_compile__maybe_saved_vars(module_info, bool, bool,
module_info, io__state, io__state).
Index: compiler/mercury_to_c.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_to_c.m,v
retrieving revision 1.31
diff -u -u -r1.31 mercury_to_c.m
--- mercury_to_c.m 1997/12/22 09:55:58 1.31
+++ mercury_to_c.m 1998/01/04 11:17:31
@@ -674,13 +674,17 @@
c_gen_goal_2(unify(_A, _B, _, Unification, _), Indent, CGenInfo0, CGenInfo) -->
c_gen_unification(Unification, Indent, CGenInfo0, CGenInfo).
-c_gen_goal_2(pragma_c_code(C_Code, _, _, _, _, ArgNames, _, _), _, _, _) -->
+c_gen_goal_2(pragma_c_code(_, _, _, _, ArgNames, _, PragmaCode), _, _, _) -->
{ sorry(4) },
{ get_pragma_c_var_names(ArgNames, Names) },
io__write_string("$pragma(c_code, ["),
c_gen_string_list(Names),
io__write_string("], """),
- io__write_string(C_Code),
+ ( { PragmaCode = ordinary(C_Code, _) } ->
+ io__write_string(C_Code)
+ ;
+ { error("cannot translate nondet pragma code to C") }
+ ),
io__write_string(""" )").
:- pred c_gen_string_list(list(string), io__state, io__state).
Index: compiler/mercury_to_mercury.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.124
diff -u -u -r1.124 mercury_to_mercury.m
--- mercury_to_mercury.m 1997/12/22 09:56:00 1.124
+++ mercury_to_mercury.m 1998/01/06 07:49:35
@@ -59,9 +59,8 @@
:- mode mercury_output_pragma_decl(in, in, in, in, di, uo) is det.
:- pred mercury_output_pragma_c_code(may_call_mercury, sym_name, pred_or_func,
- list(pragma_var), maybe(pair(list(string))),
- varset, string, io__state, io__state).
-:- mode mercury_output_pragma_c_code(in, in, in, in, in, in, in, di, uo) is det.
+ list(pragma_var), varset, pragma_code, io__state, io__state).
+:- mode mercury_output_pragma_c_code(in, in, in, in, in, in, di, uo) is det.
:- pred mercury_output_pragma_unused_args(pred_or_func, sym_name,
int, proc_id, list(int), io__state, io__state) is det.
@@ -286,14 +285,9 @@
mercury_output_pragma_c_body_code(Code)
;
{ Pragma = c_code(MayCallMercury, Pred, PredOrFunc, Vars,
- VarSet, C_CodeString) },
+ VarSet, PragmaCode) },
mercury_output_pragma_c_code(MayCallMercury, Pred, PredOrFunc,
- Vars, no, VarSet, C_CodeString)
- ;
- { Pragma = c_code(MayCallMercury, Pred, PredOrFunc, Vars,
- SavedVars, LabelNames, VarSet, C_CodeString) },
- mercury_output_pragma_c_code(MayCallMercury, Pred, PredOrFunc,
- Vars, yes(SavedVars - LabelNames), VarSet, C_CodeString)
+ Vars, VarSet, PragmaCode)
;
{ Pragma = export(Pred, PredOrFunc, ModeList, C_Function) },
mercury_output_pragma_export(Pred, PredOrFunc, ModeList,
@@ -1813,7 +1807,7 @@
% Output the given pragma c_code declaration
mercury_output_pragma_c_code(MayCallMercury, PredName, PredOrFunc, Vars0,
- MaybeExtraInfo, VarSet, C_CodeString) -->
+ VarSet, PragmaCode) -->
io__write_string(":- pragma c_code("),
mercury_output_sym_name(PredName),
{
@@ -1848,15 +1842,33 @@
io__write_string(", will_not_call_mercury, ")
),
(
- { MaybeExtraInfo = no }
+ { PragmaCode = ordinary(C_Code, _) },
+ term_io__quote_string(C_Code)
;
- { MaybeExtraInfo = yes(SavedVars - LabelNames) },
- mercury_output_c_ident_list(SavedVars),
- io__write_string(", "),
- mercury_output_c_ident_list(LabelNames),
- io__write_string(", ")
+ { PragmaCode = nondet(Fields, _, First, _,
+ Later, _, Treat, Shared, _) },
+ io__write_string("local_vars("),
+ term_io__quote_string(Fields),
+ io__write_string("), "),
+ io__write_string("first_code("),
+ term_io__quote_string(First),
+ io__write_string("), "),
+ io__write_string("retry_code("),
+ term_io__quote_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(")
+ ),
+ term_io__quote_string(Shared),
+ io__write_string(")")
),
- term_io__quote_string(C_CodeString),
io__write_string(").\n").
:- pred mercury_output_c_ident_list(list(string), io__state, io__state).
Index: compiler/middle_rec.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/middle_rec.m,v
retrieving revision 1.67
diff -u -u -r1.67 middle_rec.m
--- middle_rec.m 1997/12/05 15:47:36 1.67
+++ middle_rec.m 1998/01/06 08:19:30
@@ -387,7 +387,7 @@
middle_rec__find_used_registers_lval(Lval, Used0, Used1),
middle_rec__find_used_registers_rval(Rval, Used1, Used).
middle_rec__find_used_registers_instr(call(_, _, _, _), Used, Used).
-middle_rec__find_used_registers_instr(mkframe(_, _, _), Used, Used).
+middle_rec__find_used_registers_instr(mkframe(_, _, _, _), Used, Used).
middle_rec__find_used_registers_instr(modframe(_), Used, Used).
middle_rec__find_used_registers_instr(label(_), Used, Used).
middle_rec__find_used_registers_instr(goto(_), Used, Used).
@@ -414,10 +414,29 @@
middle_rec__find_used_registers_rval(Rval, Used0, Used).
middle_rec__find_used_registers_instr(incr_sp(_, _), Used, Used).
middle_rec__find_used_registers_instr(decr_sp(_), Used, Used).
-middle_rec__find_used_registers_instr(pragma_c(_, Ins, _, Outs, _),
+middle_rec__find_used_registers_instr(pragma_c(_, Components, _, _),
Used0, Used) :-
- insert_pragma_c_input_registers(Ins, Used0, Used1),
- insert_pragma_c_output_registers(Outs, Used1, Used).
+ middle_rec__find_used_registers_components(Components, Used0, Used).
+
+:- pred middle_rec__find_used_registers_components(list(pragma_c_component),
+ set(int), set(int)).
+:- mode middle_rec__find_used_registers_components(in, di, uo) is det.
+
+middle_rec__find_used_registers_components([], Used, Used).
+middle_rec__find_used_registers_components([Comp | Comps], Used0, Used) :-
+ middle_rec__find_used_registers_component(Comp, Used0, Used1),
+ middle_rec__find_used_registers_components(Comps, Used1, Used).
+
+:- pred middle_rec__find_used_registers_component(pragma_c_component,
+ set(int), set(int)).
+:- mode middle_rec__find_used_registers_component(in, di, uo) is det.
+
+middle_rec__find_used_registers_component(pragma_c_inputs(In), Used0, Used) :-
+ insert_pragma_c_input_registers(In, Used0, Used).
+middle_rec__find_used_registers_component(pragma_c_outputs(Out), Used0, Used) :-
+ insert_pragma_c_output_registers(Out, Used0, Used).
+middle_rec__find_used_registers_component(pragma_c_user_code(_, _), Used, Used).
+middle_rec__find_used_registers_component(pragma_c_raw_code(_), Used, Used).
:- pred middle_rec__find_used_registers_lvals(list(lval), set(int), set(int)).
:- mode middle_rec__find_used_registers_lvals(in, di, uo) is det.
Index: compiler/mode_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mode_util.m,v
retrieving revision 1.103
diff -u -u -r1.103 mode_util.m
--- mode_util.m 1998/01/05 07:26:16 1.103
+++ mode_util.m 1998/01/08 03:02:38
@@ -1154,8 +1154,8 @@
recompute_instmap_delta_unify(Uni, UniMode0, UniMode,
GoalInfo, InstMap, InstMapDelta).
-recompute_instmap_delta_2(_, pragma_c_code(A, B, PredId, ProcId, Args, F, G,
- H), _, pragma_c_code(A, B, PredId, ProcId, Args, F, G, H),
+recompute_instmap_delta_2(_, pragma_c_code(A, PredId, ProcId, Args, E, F,
+ G), _, pragma_c_code(A, PredId, ProcId, Args, E, F, G),
InstMap, InstMapDelta) -->
recompute_instmap_delta_call(PredId, ProcId,
Args, InstMap, InstMapDelta).
Index: compiler/modes.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modes.m,v
retrieving revision 1.213
diff -u -u -r1.213 modes.m
--- modes.m 1998/01/05 07:26:19 1.213
+++ modes.m 1998/01/08 03:02:39
@@ -973,8 +973,8 @@
% to modecheck a pragma_c_code, we just modecheck the proc for
% which it is the goal.
-modecheck_goal_expr(pragma_c_code(IsRecursive, C_Code, PredId, _ProcId0, Args0,
- ArgNameMap, OrigArgTypes, ExtraPragmaInfo), GoalInfo, Goal) -->
+modecheck_goal_expr(pragma_c_code(IsRecursive, PredId, _ProcId0, Args0,
+ ArgNameMap, OrigArgTypes, PragmaCode), GoalInfo, Goal) -->
mode_checkpoint(enter, "pragma_c_code"),
mode_info_set_call_context(call(PredId)),
@@ -985,10 +985,10 @@
ProcId, Args, ExtraGoals),
=(ModeInfo),
- { Pragma = pragma_c_code(IsRecursive, C_Code, PredId, ProcId, Args0,
- ArgNameMap, OrigArgTypes, ExtraPragmaInfo) },
+ { Pragma = pragma_c_code(IsRecursive, PredId, ProcId, Args0,
+ ArgNameMap, OrigArgTypes, PragmaCode) },
{ handle_extra_goals(Pragma, ExtraGoals, GoalInfo, Args0, Args,
- InstMap0, ModeInfo, Goal) },
+ InstMap0, ModeInfo, Goal) },
mode_info_unset_call_context,
mode_checkpoint(exit, "pragma_c_code").
Index: compiler/module_qual.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/module_qual.m,v
retrieving revision 1.27
diff -u -u -r1.27 module_qual.m
--- module_qual.m 1997/12/22 09:56:07 1.27
+++ module_qual.m 1998/01/02 04:50:02
@@ -635,13 +635,8 @@
qualify_pragma(c_header_code(Code), c_header_code(Code), Info, Info) --> [].
qualify_pragma(c_code(Code), c_code(Code), Info, Info) --> [].
qualify_pragma(c_code(Rec, SymName, PredOrFunc, PragmaVars0, Varset, CCode),
- c_code(Rec, SymName, PredOrFunc, PragmaVars, Varset, CCode),
+ c_code(Rec, SymName, PredOrFunc, PragmaVars, Varset, CCode),
Info0, Info) -->
- qualify_pragma_vars(PragmaVars0, PragmaVars, Info0, Info).
-qualify_pragma(c_code(Rec, SymName, PredOrFunc, PragmaVars0,
- SavedVars, LabelCount, Varset, CCode),
- c_code(Rec, SymName, PredOrFunc, PragmaVars,
- SavedVars, LabelCount, Varset, CCode), Info0, Info) -->
qualify_pragma_vars(PragmaVars0, PragmaVars, Info0, Info).
qualify_pragma(memo(A, B), memo(A, B), Info, Info) --> [].
qualify_pragma(inline(A, B), inline(A, B), Info, Info) --> [].
Index: compiler/modules.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modules.m,v
retrieving revision 1.47
diff -u -u -r1.47 modules.m
--- modules.m 1998/01/06 23:50:58 1.47
+++ modules.m 1998/01/08 03:06:27
@@ -821,7 +821,7 @@
io__write_list(OrdStream, DepsOrdering, "\n\n",
write_module_scc(OrdStream)),
io__close_output(OrdStream),
- maybe_write_string(Verbose, "% done\n")
+ maybe_write_string(Verbose, "% done.\n")
;
{ string__append_list(["can't open file `",
OrdFileName, "' for output."], OrdMessage) },
@@ -965,7 +965,7 @@
( { DepResult = ok(DepStream) } ->
generate_dep_file(Module, DepsMap, DepStream),
io__close_output(DepStream),
- maybe_write_string(Verbose, "% done\n")
+ maybe_write_string(Verbose, "% done.\n")
;
{ string__append_list(["can't open file `", DepFileName,
"' for output."], DepMessage) },
Index: compiler/opt_debug.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/opt_debug.m,v
retrieving revision 1.77
diff -u -u -r1.77 opt_debug.m
--- opt_debug.m 1997/12/22 06:58:31 1.77
+++ opt_debug.m 1998/01/06 08:16:49
@@ -296,7 +296,7 @@
opt_debug__dump_code_addr(Proc, P_str),
opt_debug__dump_code_addr(Ret, R_str),
string__append_list(["call(", P_str, ", ", R_str, ")"], Str).
-opt_debug__dump_vninstr(vn_mkframe(_, _, _), "mkframe").
+opt_debug__dump_vninstr(vn_mkframe(_, _, _, _), "mkframe").
opt_debug__dump_vninstr(vn_label(Label), Str) :-
opt_debug__dump_label(Label, L_str),
string__append_list(["label(", L_str, ")"], Str).
@@ -828,11 +828,17 @@
opt_debug__dump_code_addr(Proc, P_str),
opt_debug__dump_code_addr(Ret, R_str),
string__append_list(["call(", P_str, ", ", R_str, ", ...)"], Str).
-opt_debug__dump_instr(mkframe(Name, Size, Redoip), Str) :-
+opt_debug__dump_instr(mkframe(Name, Size, MaybePragma, Redoip), Str) :-
string__int_to_string(Size, S_str),
+ ( MaybePragma = yes(pragma_struct(StructName, StructFields, _)) ->
+ string__append_list(["yes(", StructName, ", ",
+ StructFields, ")"], P_str)
+ ;
+ P_str = "no"
+ ),
opt_debug__dump_code_addr(Redoip, R_str),
- string__append_list(["mkframe(", Name, ", ", S_str, ", ", R_str, ")"],
- Str).
+ string__append_list(["mkframe(", Name, ", ", S_str, ", ",
+ P_str, ", ", R_str, ")"], Str).
opt_debug__dump_instr(modframe(Redoip), Str) :-
opt_debug__dump_code_addr(Redoip, R_str),
string__append_list(["modframe(", R_str, ")"], Str).
@@ -890,8 +896,26 @@
string__int_to_string(Size, S_str),
string__append_list(["decr_sp(", S_str, ")"], Str).
% XXX should probably give more info than this
-opt_debug__dump_instr(pragma_c(_, _, Code, _, _), Str) :-
- string__append_list(["pragma_c(", Code, ")"], Str).
+opt_debug__dump_instr(pragma_c(_, Comps, _, _), Str) :-
+ opt_debug__dump_components(Comps, C_str),
+ string__append_list(["pragma_c(", C_str, ")"], Str).
+
+:- pred opt_debug__dump_components(list(pragma_c_component), string).
+:- mode opt_debug__dump_components(in, out) is det.
+
+opt_debug__dump_components([], "").
+opt_debug__dump_components([Comp | Comps], Str) :-
+ opt_debug__dump_component(Comp, Str1),
+ opt_debug__dump_components(Comps, Str2),
+ string__append(Str1, Str2, Str).
+
+:- pred opt_debug__dump_component(pragma_c_component, string).
+:- mode opt_debug__dump_component(in, out) is det.
+
+opt_debug__dump_component(pragma_c_inputs(_), "").
+opt_debug__dump_component(pragma_c_outputs(_), "").
+opt_debug__dump_component(pragma_c_user_code(_, Code), Code).
+opt_debug__dump_component(pragma_c_raw_code(Code), Code).
opt_debug__dump_fullinstr(Uinstr - Comment, Str) :-
opt_debug__dump_instr(Uinstr, U_str),
Index: compiler/opt_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/opt_util.m,v
retrieving revision 1.86
diff -u -u -r1.86 opt_util.m
--- opt_util.m 1997/12/19 03:07:48 1.86
+++ opt_util.m 1998/01/06 08:23:49
@@ -414,7 +414,7 @@
list__reverse(RevSkip, Skip),
Rest = Instrs
;
- Uinstr = mkframe(_, _, _)
+ Uinstr = mkframe(_, _, _, _)
->
fail
;
@@ -789,7 +789,7 @@
Uinstr0 = call(_, _, _, _),
Need = no
;
- Uinstr0 = mkframe(_, _, _),
+ Uinstr0 = mkframe(_, _, _, _),
Need = no
;
Uinstr0 = modframe(_),
@@ -889,7 +889,7 @@
Uinstr0 = decr_sp(_),
Need = no
;
- Uinstr0 = pragma_c(_, _, _, _, _),
+ Uinstr0 = pragma_c(_, _, _, _),
Need = no
).
@@ -972,7 +972,7 @@
opt_util__can_instr_branch_away(block(_, _, _), yes).
opt_util__can_instr_branch_away(assign(_, _), no).
opt_util__can_instr_branch_away(call(_, _, _, _), yes).
-opt_util__can_instr_branch_away(mkframe(_, _, _), no).
+opt_util__can_instr_branch_away(mkframe(_, _, _, _), no).
opt_util__can_instr_branch_away(modframe(_), no).
opt_util__can_instr_branch_away(label(_), no).
opt_util__can_instr_branch_away(goto(_), yes).
@@ -989,7 +989,15 @@
opt_util__can_instr_branch_away(discard_tickets_to(_), no).
opt_util__can_instr_branch_away(incr_sp(_, _), no).
opt_util__can_instr_branch_away(decr_sp(_), no).
-opt_util__can_instr_branch_away(pragma_c(_, _, _, _, _), no).
+opt_util__can_instr_branch_away(pragma_c(_, Components, _, _), BranchAway) :-
+ (
+ list__member(Component, Components),
+ Component = pragma_c_raw_code(_)
+ ->
+ BranchAway = yes
+ ;
+ BranchAway = no
+ ).
opt_util__can_instr_fall_through(comment(_), yes).
opt_util__can_instr_fall_through(livevals(_), yes).
@@ -997,7 +1005,7 @@
opt_util__can_block_fall_through(Instrs, FallThrough).
opt_util__can_instr_fall_through(assign(_, _), yes).
opt_util__can_instr_fall_through(call(_, _, _, _), no).
-opt_util__can_instr_fall_through(mkframe(_, _, _), yes).
+opt_util__can_instr_fall_through(mkframe(_, _, _, _), yes).
opt_util__can_instr_fall_through(modframe(_), yes).
opt_util__can_instr_fall_through(label(_), yes).
opt_util__can_instr_fall_through(goto(_), no).
@@ -1014,7 +1022,7 @@
opt_util__can_instr_fall_through(discard_tickets_to(_), yes).
opt_util__can_instr_fall_through(incr_sp(_, _), yes).
opt_util__can_instr_fall_through(decr_sp(_), yes).
-opt_util__can_instr_fall_through(pragma_c(_, _, _, _, _), yes).
+opt_util__can_instr_fall_through(pragma_c(_, _, _, _), yes).
% Check whether an instruction sequence can possibly fall through
% to the next instruction without using its label.
@@ -1038,7 +1046,7 @@
opt_util__can_use_livevals(block(_, _, _), no).
opt_util__can_use_livevals(assign(_, _), no).
opt_util__can_use_livevals(call(_, _, _, _), yes).
-opt_util__can_use_livevals(mkframe(_, _, _), no).
+opt_util__can_use_livevals(mkframe(_, _, _, _), no).
opt_util__can_use_livevals(modframe(_), no).
opt_util__can_use_livevals(label(_), no).
opt_util__can_use_livevals(goto(_), yes).
@@ -1055,7 +1063,7 @@
opt_util__can_use_livevals(discard_tickets_to(_), no).
opt_util__can_use_livevals(incr_sp(_, _), no).
opt_util__can_use_livevals(decr_sp(_), no).
-opt_util__can_use_livevals(pragma_c(_, _, _, _, _), no).
+opt_util__can_use_livevals(pragma_c(_, _, _, _), no).
% determine all the labels and code_addresses that are referenced by Instr
@@ -1096,7 +1104,7 @@
opt_util__instr_list_labels(Instrs, Labels, CodeAddrs).
opt_util__instr_labels_2(assign(_,_), [], []).
opt_util__instr_labels_2(call(Target, Ret, _, _), [], [Target, Ret]).
-opt_util__instr_labels_2(mkframe(_, _, Addr), [], [Addr]).
+opt_util__instr_labels_2(mkframe(_, _, _, Addr), [], [Addr]).
opt_util__instr_labels_2(modframe(Addr), [], [Addr]).
opt_util__instr_labels_2(label(_), [], []).
opt_util__instr_labels_2(goto(Addr), [], [Addr]).
@@ -1113,7 +1121,12 @@
opt_util__instr_labels_2(discard_tickets_to(_), [], []).
opt_util__instr_labels_2(incr_sp(_, _), [], []).
opt_util__instr_labels_2(decr_sp(_), [], []).
-opt_util__instr_labels_2(pragma_c(_, _, _, _, _), [], []).
+opt_util__instr_labels_2(pragma_c(_, _, _, MaybeLabel), Labels, []) :-
+ ( MaybeLabel = yes(Label) ->
+ Labels = [Label]
+ ;
+ Labels = []
+ ).
:- pred opt_util__instr_rvals_and_lvals(instr, list(rval), list(lval)).
:- mode opt_util__instr_rvals_and_lvals(in, out, out) is det.
@@ -1126,7 +1139,7 @@
opt_util__instr_list_rvals_and_lvals(Instrs, Labels, CodeAddrs).
opt_util__instr_rvals_and_lvals(assign(Lval,Rval), [Rval], [Lval]).
opt_util__instr_rvals_and_lvals(call(_, _, _, _), [], []).
-opt_util__instr_rvals_and_lvals(mkframe(_, _, _), [], []).
+opt_util__instr_rvals_and_lvals(mkframe(_, _, _, _), [], []).
opt_util__instr_rvals_and_lvals(modframe(_), [], []).
opt_util__instr_rvals_and_lvals(label(_), [], []).
opt_util__instr_rvals_and_lvals(goto(_), [], []).
@@ -1143,9 +1156,38 @@
opt_util__instr_rvals_and_lvals(discard_tickets_to(Rval), [Rval], []).
opt_util__instr_rvals_and_lvals(incr_sp(_, _), [], []).
opt_util__instr_rvals_and_lvals(decr_sp(_), [], []).
-opt_util__instr_rvals_and_lvals(pragma_c(_, In, _, Out, _), Rvals, Lvals) :-
- pragma_c_inputs_get_rvals(In, Rvals),
- pragma_c_outputs_get_lvals(Out, Lvals).
+opt_util__instr_rvals_and_lvals(pragma_c(_, Components, _, _), Rvals, Lvals) :-
+ pragma_c_components_get_rvals_and_lvals(Components, Rvals, Lvals).
+
+ % extract the rvals and lvals from the pragma_c_components
+:- pred pragma_c_components_get_rvals_and_lvals(list(pragma_c_component),
+ list(rval), list(lval)).
+:- mode pragma_c_components_get_rvals_and_lvals(in, out, out) is det.
+
+pragma_c_components_get_rvals_and_lvals([], [], []).
+pragma_c_components_get_rvals_and_lvals([Comp | Comps], Rvals, Lvals) :-
+ pragma_c_components_get_rvals_and_lvals(Comps, Rvals1, Lvals1),
+ pragma_c_component_get_rvals_and_lvals(Comp,
+ Rvals1, Rvals, Lvals1, Lvals).
+
+ % extract the rvals and lvals from the pragma_c_component
+ % and add them to the list.
+:- pred pragma_c_component_get_rvals_and_lvals(pragma_c_component,
+ list(rval), list(rval), list(lval), list(lval)).
+:- mode pragma_c_component_get_rvals_and_lvals(in, in, out, in, out) is det.
+
+pragma_c_component_get_rvals_and_lvals(pragma_c_inputs(Inputs),
+ Rvals0, Rvals, Lvals, Lvals) :-
+ pragma_c_inputs_get_rvals(Inputs, Rvals1),
+ list__append(Rvals1, Rvals0, Rvals).
+pragma_c_component_get_rvals_and_lvals(pragma_c_outputs(Outputs),
+ Rvals, Rvals, Lvals0, Lvals) :-
+ pragma_c_outputs_get_lvals(Outputs, Lvals1),
+ list__append(Lvals1, Lvals0, Lvals).
+pragma_c_component_get_rvals_and_lvals(pragma_c_user_code(_, _),
+ Rvals, Rvals, Lvals, Lvals).
+pragma_c_component_get_rvals_and_lvals(pragma_c_raw_code(_),
+ Rvals, Rvals, Lvals, Lvals).
% extract the rvals from the pragma_c_input
:- pred pragma_c_inputs_get_rvals(list(pragma_c_input), list(rval)).
@@ -1216,7 +1258,7 @@
opt_util__count_temps_lval(Lval, R0, R1, F0, F1),
opt_util__count_temps_rval(Rval, R1, R, F1, F).
opt_util__count_temps_instr(call(_, _, _, _), R, R, F, F).
-opt_util__count_temps_instr(mkframe(_, _, _), R, R, F, F).
+opt_util__count_temps_instr(mkframe(_, _, _, _), R, R, F, F).
opt_util__count_temps_instr(modframe(_), R, R, F, F).
opt_util__count_temps_instr(label(_), R, R, F, F).
opt_util__count_temps_instr(goto(_), R, R, F, F).
@@ -1243,7 +1285,7 @@
opt_util__count_temps_rval(Rval, R0, R, F0, F).
opt_util__count_temps_instr(incr_sp(_, _), R, R, F, F).
opt_util__count_temps_instr(decr_sp(_), R, R, F, F).
-opt_util__count_temps_instr(pragma_c(_, _, _, _, _), R, R, F, F).
+opt_util__count_temps_instr(pragma_c(_, _, _, _), R, R, F, F).
:- pred opt_util__count_temps_lval(lval, int, int, int, int).
:- mode opt_util__count_temps_lval(in, in, out, in, out) is det.
@@ -1350,6 +1392,8 @@
opt_util__touches_nondet_ctrl_lval(Lval, Touch)
; Uinstr = restore_hp(Rval) ->
opt_util__touches_nondet_ctrl_rval(Rval, Touch)
+ ; Uinstr = pragma_c(_, Components, _, _) ->
+ opt_util__touches_nondet_ctrl_components(Components, Touch)
;
Touch = yes
).
@@ -1404,6 +1448,24 @@
opt_util__touches_nondet_ctrl_mem_ref(framevar_ref(_), no).
opt_util__touches_nondet_ctrl_mem_ref(heap_ref(Rval, _, _), Touch) :-
opt_util__touches_nondet_ctrl_rval(Rval, Touch).
+
+:- pred opt_util__touches_nondet_ctrl_components(list(pragma_c_component),
+ bool).
+:- mode opt_util__touches_nondet_ctrl_components(in, out) is det.
+
+opt_util__touches_nondet_ctrl_components([], no).
+opt_util__touches_nondet_ctrl_components([C | Cs], Touch) :-
+ opt_util__touches_nondet_ctrl_component(C, Touch1),
+ opt_util__touches_nondet_ctrl_components(Cs, Touch2),
+ bool__or(Touch1, Touch2, Touch).
+
+:- pred opt_util__touches_nondet_ctrl_component(pragma_c_component, bool).
+:- mode opt_util__touches_nondet_ctrl_component(in, out) is det.
+
+opt_util__touches_nondet_ctrl_component(pragma_c_inputs(_), no).
+opt_util__touches_nondet_ctrl_component(pragma_c_outputs(_), no).
+opt_util__touches_nondet_ctrl_component(pragma_c_raw_code(_), no).
+opt_util__touches_nondet_ctrl_component(pragma_c_user_code(_, _), yes).
%-----------------------------------------------------------------------------%
Index: compiler/peephole.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/peephole.m,v
retrieving revision 1.70
diff -u -u -r1.70 peephole.m
--- peephole.m 1997/12/22 06:58:35 1.70
+++ peephole.m 1998/01/01 06:18:34
@@ -140,13 +140,15 @@
% These two patterns are mutually exclusive because if_val is not
% straigh-line code.
-peephole__match(mkframe(Name, Slots, Redoip1), Comment, Instrs0, Instrs) :-
+peephole__match(mkframe(Name, Slots, Pragma, Redoip1), Comment,
+ Instrs0, Instrs) :-
(
opt_util__next_modframe(Instrs0, [], Redoip2, Skipped, Rest),
opt_util__touches_nondet_ctrl(Skipped, no)
->
list__append(Skipped, Rest, Instrs1),
- Instrs = [mkframe(Name, Slots, Redoip2) - Comment | Instrs1]
+ Instrs = [mkframe(Name, Slots, Pragma, Redoip2) - Comment
+ | Instrs1]
;
opt_util__skip_comments_livevals(Instrs0, Instrs1),
Instrs1 = [Instr1 | Instrs2],
@@ -157,7 +159,7 @@
->
Instrs = [
if_val(Test, do_redo) - Comment2,
- mkframe(Name, Slots, do_fail) - Comment
+ mkframe(Name, Slots, Pragma, do_fail) - Comment
| Instrs2
]
;
@@ -168,14 +170,16 @@
->
Instrs = [
if_val(Test, do_redo) - Comment2,
- mkframe(Name, Slots, Redoip1) - Comment
+ mkframe(Name, Slots, Pragma, Redoip1)
+ - Comment
| Instrs2
]
;
Target = do_redo
->
Instrs = [
- mkframe(Name, Slots, Redoip1) - Comment,
+ mkframe(Name, Slots, Pragma, Redoip1)
+ - Comment,
if_val(Test, Redoip1) - Comment2
| Instrs2
]
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/polymorphism.m,v
retrieving revision 1.121
diff -u -u -r1.121 polymorphism.m
--- polymorphism.m 1998/01/02 00:10:44 1.121
+++ polymorphism.m 1998/01/02 06:52:11
@@ -749,8 +749,8 @@
polymorphism__process_goal(B0, B),
polymorphism__process_goal(C0, C).
-polymorphism__process_goal_expr(pragma_c_code(IsRecursive, C_Code, PredId,
- ProcId, ArgVars0, ArgNames0, OrigArgTypes0, ExtraInfo),
+polymorphism__process_goal_expr(pragma_c_code(IsRecursive, PredId, ProcId,
+ ArgVars0, ArgInfo0, OrigArgTypes0, PragmaCode),
GoalInfo, Goal) -->
polymorphism__process_call(PredId, ProcId, ArgVars0,
ArgVars, ExtraVars, ExtraGoals),
@@ -772,7 +772,7 @@
{ term__vars_list(PredArgTypes, PredTypeVars0) },
{ list__remove_dups(PredTypeVars0, PredTypeVars) },
{ polymorphism__c_code_add_typeinfos(ExtraVars, PredTypeVars,
- PredTypeVarSet, ArgNames0, ArgNames) },
+ PredTypeVarSet, ArgInfo0, ArgInfo) },
%
% insert type_info types for all the inserted type_info vars
@@ -787,13 +787,13 @@
%
% plug it all back together
%
- { Call = pragma_c_code(IsRecursive, C_Code, PredId, ProcId, ArgVars,
- ArgNames, OrigArgTypes, ExtraInfo) - CallGoalInfo },
+ { Call = pragma_c_code(IsRecursive, PredId, ProcId, ArgVars,
+ ArgInfo, OrigArgTypes, PragmaCode) - CallGoalInfo },
{ list__append(ExtraGoals, [Call], GoalList) },
{ conj_list_to_goal(GoalList, GoalInfo, Goal) }.
-:- pred polymorphism__c_code_add_typeinfos(list(var), list(tvar),
- tvarset, list(maybe(string)), list(maybe(string))).
+:- pred polymorphism__c_code_add_typeinfos(list(var), list(tvar), tvarset,
+ list(maybe(pair(string, mode))), list(maybe(pair(string, mode)))).
:- mode polymorphism__c_code_add_typeinfos(in, in, in, in, out) is det.
polymorphism__c_code_add_typeinfos([], [], _, ArgNames, ArgNames).
@@ -803,7 +803,9 @@
ArgNames0, ArgNames1),
( varset__search_name(TypeVarSet, TVar, TypeVarName) ->
string__append("TypeInfo_for_", TypeVarName, C_VarName),
- ArgNames = [yes(C_VarName) | ArgNames1]
+ Input = user_defined_mode(qualified("mercury_builtin", "in"),
+ []),
+ ArgNames = [yes(C_VarName - Input) | ArgNames1]
;
ArgNames = [no | ArgNames1]
).
Index: compiler/pragma_c_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/pragma_c_gen.m,v
retrieving revision 1.10
diff -u -u -r1.10 pragma_c_gen.m
--- pragma_c_gen.m 1997/07/27 15:01:23 1.10
+++ pragma_c_gen.m 1998/01/08 03:33:46
@@ -1,5 +1,5 @@
%---------------------------------------------------------------------------%
-% Copyright (C) 1996-1997 The University of Melbourne.
+% Copyright (C) 1996-1998 The University of Melbourne.
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%---------------------------------------------------------------------------%
@@ -15,7 +15,7 @@
% The code that does this is reasonably simple.
%
% The scheme for model_non pragma_c_codes is substantially different,
-% so we handle them seperately.
+% so we handle them separately.
:- module pragma_c_gen.
@@ -25,27 +25,26 @@
:- import_module llds, code_info.
:- import_module list, std_util, term.
-:- pred pragma_c_gen__generate_pragma_c_code(code_model::in, string::in,
+:- pred pragma_c_gen__generate_pragma_c_code(code_model::in,
may_call_mercury::in, pred_id::in, proc_id::in, list(var)::in,
- list(maybe(string))::in, list(type)::in, hlds_goal_info::in,
- code_tree::out, code_info::in, code_info::out) is det.
+ list(maybe(pair(string, mode)))::in, list(type)::in,
+ hlds_goal_info::in, pragma_code::in, code_tree::out,
+ code_info::in, code_info::out) is det.
-:- pred pragma_c_gen__generate_backtrack_pragma_c_code(code_model::in,
- string::in, may_call_mercury::in, pred_id::in, proc_id::in,
- list(var)::in, list(maybe(string))::in, list(type)::in,
- list(pair(var, string))::in, list(string)::in, hlds_goal_info::in,
- code_tree::out, code_info::in, code_info::out) is erroneous.
+:- pred pragma_c_gen__struct_name(string::in, string::in, int::in, proc_id::in,
+ string::out) is det.
%---------------------------------------------------------------------------%
:- implementation.
-:- import_module hlds_module, hlds_pred, call_gen, tree.
-:- import_module string, assoc_list, set, map, require.
+:- import_module hlds_module, hlds_pred, call_gen, llds_out, trace, tree.
+:- import_module options, globals.
+:- import_module bool, string, int, assoc_list, set, map, require.
-% The code we generate for a model_det or model_semi pragma_c_code
+% The code we generate for an ordinary (model_det or model_semi) pragma_c_code
% must be able to fit into the middle of a procedure, since such
-% pragma_c_codes can be inlined. It is of the following form:
+% pragma_c_codes can be inlined. This code is of the following form:
%
% <save live variables onto the stack> /* see note (1) below */
% {
@@ -65,6 +64,179 @@
% <code to fail>
% label:
%
+% The code we generate for nondet pragma_c_code assumes that this code is
+% the only thing between the procedure prolog and epilog; such pragma_c_codes
+% therefore cannot be inlined. The code of the procedure is of one of the
+% following two forms:
+%
+% form 1:
+% <proc entry label and comments>
+% <mkframe including space for the save struct>
+% <#define MR_ORDINARY_SLOTS>
+% <--- boundary between prolog and code generated here --->
+% <set redoip to point to &&xxx_i1>
+% <code for entry to a disjunction and first disjunct>
+% {
+% <declaration of one local variable for each input and output arg>
+% <declaration of one local variable to point to save struct>
+% <assignment of input values from registers to local variables>
+% <assignment to save struct pointer>
+% save_registers(); /* see notes (1) and (2) below */
+% #define SUCCEED() goto callsuccesslabel
+% #define SUCCEED_LAST() goto calllastsuccesslabel
+% #define FAIL() fail()
+% { <the user-written call c code> }
+% { <the user-written shared c code> }
+% callsuccesslabel:
+% restore_registers(); /* see notes (1) and (3) below */
+% <assignment of the output values from local variables to registers>
+% succeed()
+% calllastsuccesslabel: /* see note (4) below) */
+% restore_registers(); /* see notes (1) and (3) below */
+% <assignment of the output values from local variables to registers>
+% succeed_discard()
+% #undef SUCCEED
+% #undef SUCCEED_LAST
+% #undef FAIL
+% }
+% Define_label(xxx_i1)
+% <code for entry to a later disjunct>
+% {
+% <declaration of one local variable for each output arg>
+% <declaration of one local variable to point to save struct>
+% <assignment to save struct pointer>
+% save_registers(); /* see notes (1) and (2) below */
+% #define SUCCEED() goto retrysuccesslabel
+% #define SUCCEED_LAST() goto retrylastsuccesslabel
+% #define FAIL() fail()
+% { <the user-written retry c code> }
+% { <the user-written shared c code> }
+% retrysuccesslabel:
+% restore_registers(); /* see notes (1) and (3) below */
+% <assignment of the output values from local variables to registers>
+% succeed()
+% retrylastsuccesslabel: /* see note (4) below) */
+% restore_registers(); /* see notes (1) and (3) below */
+% <assignment of the output values from local variables to registers>
+% succeed_discard()
+% #undef SUCCEED
+% #undef SUCCEED_LAST
+% #undef FAIL
+% }
+% <--- boundary between code generated here and epilog --->
+% <#undef MR_ORDINARY_SLOTS>
+%
+% form 2:
+% <proc entry label and comments>
+% <mkframe including space for the save struct>
+% <#define MR_ORDINARY_SLOTS>
+% <--- boundary between prolog and code generated here --->
+% <set redoip to point to &&xxx_i1>
+% <code for entry to a disjunction and first disjunct>
+% {
+% <declaration of one local variable for each input and output arg>
+% <declaration of one local variable to point to save struct>
+% <assignment of input values from registers to local variables>
+% <assignment to save struct pointer>
+% save_registers(); /* see notes (1) and (2) below */
+% #define SUCCEED() goto callsuccesslabel
+% #define SUCCEED_LAST() goto calllastsuccesslabel
+% #define FAIL() fail()
+% { <the user-written call c code> }
+% GOTO_LABEL(xxx_i2)
+% callsuccesslabel: /* see note (4) below */
+% restore_registers(); /* see notes (1) and (3) below */
+% <assignment of the output values from local variables to registers>
+% succeed()
+% calllastsuccesslabel: /* see note (4) below */
+% restore_registers(); /* see notes (1) and (3) below */
+% <assignment of the output values from local variables to registers>
+% succeed_discard()
+% #undef SUCCEED
+% #undef SUCCEED_LAST
+% #undef FAIL
+% }
+% Define_label(xxx_i1)
+% <code for entry to a later disjunct>
+% {
+% <declaration of one local variable for each output arg>
+% <declaration of one local variable to point to save struct>
+% <assignment to save struct pointer>
+% save_registers(); /* see notes (1) and (2) below */
+% #define SUCCEED() goto retrysuccesslabel
+% #define SUCCEED_LAST() goto retrylastsuccesslabel
+% #define FAIL() fail()
+% { <the user-written retry c code> }
+% GOTO_LABEL(xxx_i2)
+% retrysuccesslabel: /* see note (4) below */
+% restore_registers(); /* see notes (1) and (3) below */
+% <assignment of the output values from local variables to registers>
+% succeed()
+% retrylastsuccesslabel: /* see note (4) below */
+% restore_registers(); /* see notes (1) and (3) below */
+% <assignment of the output values from local variables to registers>
+% succeed_discard()
+% #undef SUCCEED
+% #undef SUCCEED_LAST
+% #undef FAIL
+% }
+% Define_label(xxx_i2)
+% {
+% <declaration of one local variable for each output arg>
+% <declaration of one local variable to point to save struct>
+% <assignment to save struct pointer>
+% #define SUCCEED() goto sharedsuccesslabel
+% #define SUCCEED_LAST() goto sharedlastsuccesslabel
+% #define FAIL() fail()
+% { <the user-written shared c code> }
+% sharedsuccesslabel:
+% restore_registers(); /* see notes (1) and (3) below */
+% <assignment of the output values from local variables to registers>
+% succeed()
+% sharedlastsuccesslabel: /* see note (4) below */
+% restore_registers(); /* see notes (1) and (3) below */
+% <assignment of the output values from local variables to registers>
+% succeed_discard()
+% #undef SUCCEED
+% #undef SUCCEED_LAST
+% #undef FAIL
+% }
+% <--- boundary between code generated here and epilog --->
+% <#undef MR_ORDINARY_SLOTS>
+%
+% The first form is more time efficient, since it does not include the jumps
+% from the call code and retry code to the shared code and the following
+% initialization of the save struct pointer in the shared code block,
+% while the second form can lead to smaller code since it does not include
+% the shared C code (which can be quite big) twice.
+%
+% Programmers may indicate which form they wish the compiler to use;
+% if they don't, the compiler will choose form 1 if the shared code fragment
+% is "short", and form 2 if it is "long".
+%
+% The procedure prolog creates a nondet stack frame that includes space for
+% a struct that is saved across calls. Since the position of this struct in
+% the nondet stack frame is not known until the procedure prolog is created,
+% which is *after* the call to pragma_c_gen__generate_pragma_c_code, the
+% prolog will #define MR_ORDINARY_SLOTS as the number of ordinary slots
+% in the nondet frame. From the size of the fixed portion of the nondet stack
+% frame, from MR_ORDINARY_SLOTS and from the size of the save struct itself,
+% one can calculate the address of the save struct itself. The epilog will
+% #undef MR_ORDINARY_SLOTS. It need not do anything else, since all the normal
+% epilog stuff has been done in the code above.
+%
+% Unlike with ordinary pragma C codes, with nondet C codes there are never
+% any live variables to save at the start, except for the input variables,
+% and saving these is a job for the included C code. Also unlike ordinary
+% pragma C codes, nondet C codes are never followed by any other code,
+% so the exprn_info component of the code generator state need not be
+% kept up to date.
+%
+% Depending on the value of options such as generate_trace, use_trail, and
+% reclaim_heap_on_nondet_failure, we may need to include some code before
+% the call and retry labels. The generation of this code should follow
+% the same rules as the generation of similar code in nondet disjunctions.
+%
% Notes:
%
% (1) These parts are only emitted if the C code may call Mercury.
@@ -83,22 +255,59 @@
% through C back to Mercury. In that case, we need to
% keep the value of `hp' that was set by the recursive
% invocation of Mercury. The Mercury calling convention
-% guarantees that the values of `sp', `curfr', and `maxfr'
-% will be preserved, so if we're using conservative gc,
-% there is nothing that needs restoring.
-
-pragma_c_gen__generate_pragma_c_code(CodeModel, C_Code, MayCallMercury,
- PredId, ProcId, ArgVars, Names, OrigArgTypes, _GoalInfo,
- Code) -->
+% guarantees that when calling det or demi code, the values
+% of `sp', `curfr', and `maxfr' will be preserved, so if we're
+% using conservative gc, there is nothing that needs restoring.
+%
+% When calling nondet code, maxfr may be changed. This is why
+% we must call restore_registers() from the code we generate for
+% nondet pragma C codes even if we are not using conservative gc.
+%
+% (4) These labels and the code following them can be optimized away
+% by the C compiler if the macro that branches to them is not invoked
+% in the preceding body of included C code. We cannot optimize them
+% away ourselves, since these macros can be invoked from other macros,
+% and thus we do not have a sure test of whether the code fragments
+% invoke the macros.
+
+pragma_c_gen__generate_pragma_c_code(CodeModel, MayCallMercury,
+ PredId, ProcId, ArgVars, ArgInfo, OrigArgTypes, _GoalInfo,
+ PragmaCode, Code) -->
+ (
+ { PragmaCode = ordinary(C_Code, Context) },
+ pragma_c_gen__ordinary_pragma_c_code(CodeModel, MayCallMercury,
+ PredId, ProcId, ArgVars, ArgInfo, OrigArgTypes,
+ C_Code, Context, Code)
+ ;
+ { PragmaCode = nondet(
+ Fields, FieldsContext, First, FirstContext,
+ Later, LaterContext, Treat, Shared, SharedContext) },
+ pragma_c_gen__nondet_pragma_c_code(CodeModel, MayCallMercury,
+ PredId, ProcId, ArgVars, ArgInfo, OrigArgTypes,
+ Fields, FieldsContext, First, FirstContext,
+ Later, LaterContext, Treat, Shared, SharedContext,
+ Code)
+ ).
+
+%---------------------------------------------------------------------------%
+
+:- pred pragma_c_gen__ordinary_pragma_c_code(code_model::in,
+ may_call_mercury::in, pred_id::in, proc_id::in, list(var)::in,
+ list(maybe(pair(string, mode)))::in, list(type)::in,
+ string::in, term__context::in, code_tree::out,
+ code_info::in, code_info::out) is det.
+
+pragma_c_gen__ordinary_pragma_c_code(CodeModel, MayCallMercury,
+ PredId, ProcId, ArgVars, ArgInfo, OrigArgTypes,
+ C_Code, Context, Code) -->
% First we need to get a list of input and output arguments
code_info__get_pred_proc_arginfo(PredId, ProcId, ArgInfos),
- { make_c_arg_list(ArgVars, Names, OrigArgTypes, ArgInfos, Args) },
+ { make_c_arg_list(ArgVars, ArgInfo, OrigArgTypes, ArgInfos, Args) },
{ pragma_select_in_args(Args, InArgs) },
{ pragma_select_out_args(Args, OutArgs) },
+ { make_pragma_decls(Args, Decls) },
- ( { MayCallMercury = will_not_call_mercury } ->
- { SaveVarsCode = empty }
- ;
+ ( { MayCallMercury = may_call_mercury } ->
% the C code might call back Mercury code
% which clobbers the succip
code_info__succip_is_used,
@@ -109,10 +318,11 @@
{ get_c_arg_list_vars(OutArgs, OutArgs1) },
{ set__list_to_set(OutArgs1, OutArgsSet) },
call_gen__save_variables(OutArgsSet, SaveVarsCode)
+ ;
+ { SaveVarsCode = empty }
),
- { make_pragma_decls(Args, Decls) },
- get_pragma_input_vars(InArgs, Inputs, InputVarsCode),
+ get_pragma_input_vars(InArgs, InputDescs, InputVarsCode),
( { CodeModel = model_semi } ->
% We have to clear r1 for C code that gets inlined
% so that it is safe to assign to SUCCESS_INDICATOR.
@@ -128,12 +338,19 @@
% C code goes here
- code_info__get_next_label(SkipLab),
+ code_info__get_next_label(SkipLabel),
code_info__generate_failure(FailCode),
- { CheckFailureCode = tree(node([
- if_val(lval(reg(r, 1)), label(SkipLab)) -
+ { TestCode = node([
+ if_val(lval(reg(r, 1)), label(SkipLabel)) -
"Test for success of pragma_c_code"
- ]), tree(FailCode, node([ label(SkipLab) - "" ])))
+ ]) },
+ { SkipLabelCode = node([
+ label(SkipLabel) - ""
+ ]) },
+ { CheckFailureCode =
+ tree(TestCode,
+ tree(FailCode,
+ SkipLabelCode))
},
code_info__lock_reg(reg(r, 1)),
@@ -156,45 +373,333 @@
pragma_acquire_regs(OutArgs, Regs)
),
- place_pragma_output_args_in_regs(OutArgs, Regs, Outputs),
+ place_pragma_output_args_in_regs(OutArgs, Regs, OutputDescs),
- ( { MayCallMercury = will_not_call_mercury } ->
- { Wrapped_C_Code = C_Code }
+ { C_Code_Comp = pragma_c_user_code(Context, C_Code) },
+ { MayCallMercury = will_not_call_mercury ->
+ WrappedComp = [C_Code_Comp]
;
- { string__append_list([
- "\tsave_registers();\n{\n",
- C_Code, "\n}\n",
- "#ifndef CONSERVATIVE_GC\n",
- "\trestore_registers();\n",
- "#endif\n"
- ], Wrapped_C_Code) }
- ),
-
- % The context in the goal_info we are given is the context of the
- % call to the predicate whose definition is a pragma_c_code.
- % The context we want to put into the LLDS code we generate
- % is the context of the pragma_c_code line in the definition
- % of that predicate.
- code_info__get_module_info(ModuleInfo),
- { module_info_pred_proc_info(ModuleInfo, PredId, ProcId, _, ProcInfo) },
- { proc_info_goal(ProcInfo, OrigGoal) },
- { OrigGoal = _ - OrigGoalInfo },
- { goal_info_get_context(OrigGoalInfo, Context) },
+ SaveRegsComp = pragma_c_raw_code(
+ "\tsave_registers();\n"
+ ),
+ RestoreRegsComp = pragma_c_raw_code(
+ "#ifndef CONSERVATIVE_GC\n\trestore_registers();\n#endif\n"
+ ),
+ WrappedComp = [SaveRegsComp, C_Code_Comp, RestoreRegsComp]
+ },
+ { InputComp = pragma_c_inputs(InputDescs) },
+ { OutputComp = pragma_c_outputs(OutputDescs) },
+ { list__append([InputComp | WrappedComp], [OutputComp], Components) },
- { PragmaCode = node([
- pragma_c(Decls, Inputs, Wrapped_C_Code, Outputs, Context) -
+ { PragmaCCode = node([
+ pragma_c(Decls, Components, MayCallMercury, no) -
"Pragma C inclusion"
]) },
+
{ Code =
tree(SaveVarsCode,
tree(InputVarsCode,
tree(ShuffleR1_Code,
- tree(PragmaCode,
+ tree(PragmaCCode,
CheckFailureCode))))
}.
%---------------------------------------------------------------------------%
+:- pred pragma_c_gen__nondet_pragma_c_code(code_model::in,
+ may_call_mercury::in, pred_id::in, proc_id::in, list(var)::in,
+ list(maybe(pair(string, mode)))::in, list(type)::in,
+ string::in, term__context::in, string::in, term__context::in,
+ string::in, term__context::in, pragma_shared_code_treatment::in,
+ string::in, term__context::in, code_tree::out,
+ code_info::in, code_info::out) is det.
+
+pragma_c_gen__nondet_pragma_c_code(CodeModel, MayCallMercury,
+ PredId, ProcId, ArgVars, ArgInfo, OrigArgTypes,
+ _Fields, _FieldsContext, First, FirstContext,
+ Later, LaterContext, Treat, Shared, SharedContext, Code) -->
+ { require(unify(CodeModel, model_non),
+ "inappropriate code model for nondet pragma C code") },
+ % First we need to get a list of input and output arguments
+ code_info__get_pred_proc_arginfo(PredId, ProcId, ArgInfos),
+ { make_c_arg_list(ArgVars, ArgInfo, OrigArgTypes, ArgInfos, Args) },
+ { pragma_select_in_args(Args, InArgs) },
+ { pragma_select_out_args(Args, OutArgs) },
+ { make_pragma_decls(Args, Decls) },
+ { make_pragma_decls(OutArgs, OutDecls) },
+
+ { input_descs_from_arg_info(InArgs, InputDescs) },
+ { output_descs_from_arg_info(OutArgs, OutputDescs) },
+
+ code_info__get_module_info(ModuleInfo),
+ { predicate_module(ModuleInfo, PredId, ModuleName) },
+ { predicate_name(ModuleInfo, PredId, PredName) },
+ { predicate_arity(ModuleInfo, PredId, Arity) },
+ { pragma_c_gen__struct_name(ModuleName, PredName, Arity, ProcId,
+ StructName) },
+ { SaveStructDecl = pragma_c_struct_ptr_decl(StructName, "LOCALS") },
+ { string__format("\tLOCALS = (struct %s *) (
+ (char *) (curfr - MR_ORDINARY_SLOTS - NONDET_FIXED_SIZE)
+ - sizeof(struct %s));\n",
+ [s(StructName), s(StructName)],
+ InitSaveStruct) },
+
+ code_info__get_next_label(RetryLabel),
+ { ModFrameCode = node([
+ modframe(label(RetryLabel)) -
+ "Set up backtracking to retry label"
+ ]) },
+ { RetryLabelCode = node([
+ label(RetryLabel) -
+ "Start of the retry block"
+ ]) },
+
+ code_info__get_globals(Globals),
+
+ { globals__lookup_bool_option(Globals, reclaim_heap_on_nondet_failure,
+ ReclaimHeap) },
+ code_info__maybe_save_hp(ReclaimHeap, SaveHeapCode, MaybeHpSlot),
+ code_info__maybe_restore_hp(MaybeHpSlot, RestoreHeapCode),
+
+ { globals__lookup_bool_option(Globals, use_trail, UseTrail) },
+ code_info__maybe_save_ticket(UseTrail, SaveTicketCode, MaybeTicketSlot),
+ code_info__maybe_reset_ticket(MaybeTicketSlot, undo, RestoreTicketCode),
+
+ code_info__get_maybe_trace_info(MaybeTraceInfo),
+ ( { MaybeTraceInfo = yes(TraceInfo) } ->
+ trace__generate_event_code(disj([disj(1)]), TraceInfo,
+ FirstTraceCode),
+ trace__generate_event_code(disj([disj(2)]), TraceInfo,
+ LaterTraceCode)
+ ;
+ { FirstTraceCode = empty },
+ { LaterTraceCode = empty }
+ ),
+
+ { FirstDisjunctCode =
+ tree(SaveHeapCode,
+ tree(SaveTicketCode,
+ FirstTraceCode))
+ },
+ { LaterDisjunctCode =
+ tree(RestoreHeapCode,
+ tree(RestoreTicketCode,
+ LaterTraceCode))
+ },
+
+ {
+ SaveRegs = "\tsave_registers();\n",
+ RestoreRegs = "\trestore_registers();\n",
+
+ Succeed = "\tsucceed();\n",
+ SucceedDiscard = "\tsucceed_discard();\n",
+
+ CallDef1 = "#define\tSUCCEED \tgoto MR_call_success\n",
+ CallDef2 = "#define\tSUCCEED_LAST\tgoto MR_call_success_last\n",
+ CallDef3 = "#define\tFAIL\tfail()\n",
+
+ CallSuccessLabel = "MR_call_success:\n",
+ CallLastSuccessLabel = "MR_call_success_last:\n",
+
+ RetryDef1 = "#define\tSUCCEED \tgoto MR_retry_success\n",
+ RetryDef2 = "#define\tSUCCEED_LAST\tgoto MR_retry_success_last\n",
+ RetryDef3 = "#define\tFAIL\tfail()\n",
+
+ RetrySuccessLabel = "MR_retry_success:\n",
+ RetryLastSuccessLabel = "MR_retry_success_last:\n",
+
+ Undef1 = "#undef\tSUCCEED\n",
+ Undef2 = "#undef\tSUCCEED_LAST\n",
+ Undef3 = "#undef\tFAIL\n"
+ },
+
+ (
+ {
+ Treat = duplicate
+ ;
+ Treat = automatic,
+ string__length(Shared, Len),
+ Len < 1024
+ }
+ ->
+ {
+ CallDecls = [SaveStructDecl | Decls],
+ CallComponents = [
+ pragma_c_inputs(InputDescs),
+ pragma_c_raw_code(InitSaveStruct),
+ pragma_c_raw_code(SaveRegs),
+ pragma_c_raw_code(CallDef1),
+ pragma_c_raw_code(CallDef2),
+ pragma_c_raw_code(CallDef3),
+ pragma_c_user_code(FirstContext, First),
+ pragma_c_user_code(SharedContext, Shared),
+ pragma_c_raw_code(CallSuccessLabel),
+ pragma_c_raw_code(RestoreRegs),
+ pragma_c_outputs(OutputDescs),
+ pragma_c_raw_code(Succeed),
+ pragma_c_raw_code(CallLastSuccessLabel),
+ pragma_c_raw_code(RestoreRegs),
+ pragma_c_outputs(OutputDescs),
+ pragma_c_raw_code(SucceedDiscard),
+ pragma_c_raw_code(Undef1),
+ pragma_c_raw_code(Undef2),
+ pragma_c_raw_code(Undef3)
+ ],
+ CallBlockCode = node([
+ pragma_c(CallDecls, CallComponents,
+ MayCallMercury, no)
+ - "Call and shared pragma C inclusion"
+ ]),
+
+ RetryDecls = [SaveStructDecl | OutDecls],
+ RetryComponents = [
+ pragma_c_raw_code(InitSaveStruct),
+ pragma_c_raw_code(SaveRegs),
+ pragma_c_raw_code(RetryDef1),
+ pragma_c_raw_code(RetryDef2),
+ pragma_c_raw_code(RetryDef3),
+ pragma_c_user_code(LaterContext, Later),
+ pragma_c_user_code(SharedContext, Shared),
+ pragma_c_raw_code(RetrySuccessLabel),
+ pragma_c_raw_code(RestoreRegs),
+ pragma_c_outputs(OutputDescs),
+ pragma_c_raw_code(Succeed),
+ pragma_c_raw_code(RetryLastSuccessLabel),
+ pragma_c_raw_code(RestoreRegs),
+ pragma_c_outputs(OutputDescs),
+ pragma_c_raw_code(SucceedDiscard),
+ pragma_c_raw_code(Undef1),
+ pragma_c_raw_code(Undef2),
+ pragma_c_raw_code(Undef3)
+ ],
+ RetryBlockCode = node([
+ pragma_c(RetryDecls, RetryComponents,
+ MayCallMercury, no)
+ - "Retry and shared pragma C inclusion"
+ ]),
+
+ Code =
+ tree(ModFrameCode,
+ tree(FirstDisjunctCode,
+ tree(CallBlockCode,
+ tree(RetryLabelCode,
+ tree(LaterDisjunctCode,
+ RetryBlockCode)))))
+ }
+ ;
+ code_info__get_next_label(SharedLabel),
+ {
+ SharedLabelCode = node([
+ label(SharedLabel) -
+ "Start of the shared block"
+ ]),
+
+ SharedDef1 = "#define\tSUCCEED \tgoto MR_shared_success\n",
+ SharedDef2 = "#define\tSUCCEED_LAST\tgoto MR_shared_success_last\n",
+ SharedDef3 = "#define\tFAIL\tfail()\n",
+
+ SharedSuccessLabel = "MR_shared_success:\n",
+ SharedLastSuccessLabel = "MR_shared_success_last:\n",
+
+ llds_out__get_label(SharedLabel, yes, LabelStr),
+ string__format("\tGOTO_LABEL(%s);\n", [s(LabelStr)],
+ GotoSharedLabel),
+
+ CallDecls = [SaveStructDecl | Decls],
+ CallComponents = [
+ pragma_c_inputs(InputDescs),
+ pragma_c_raw_code(InitSaveStruct),
+ pragma_c_raw_code(SaveRegs),
+ pragma_c_raw_code(CallDef1),
+ pragma_c_raw_code(CallDef2),
+ pragma_c_raw_code(CallDef3),
+ pragma_c_user_code(FirstContext, First),
+ pragma_c_raw_code(GotoSharedLabel),
+ pragma_c_raw_code(CallSuccessLabel),
+ pragma_c_raw_code(RestoreRegs),
+ pragma_c_outputs(OutputDescs),
+ pragma_c_raw_code(Succeed),
+ pragma_c_raw_code(CallLastSuccessLabel),
+ pragma_c_raw_code(RestoreRegs),
+ pragma_c_outputs(OutputDescs),
+ pragma_c_raw_code(SucceedDiscard),
+ pragma_c_raw_code(Undef1),
+ pragma_c_raw_code(Undef2),
+ pragma_c_raw_code(Undef3)
+ ],
+ CallBlockCode = node([
+ pragma_c(CallDecls, CallComponents,
+ MayCallMercury, yes(SharedLabel))
+ - "Call pragma C inclusion"
+ ]),
+
+ RetryDecls = [SaveStructDecl | OutDecls],
+ RetryComponents = [
+ pragma_c_raw_code(InitSaveStruct),
+ pragma_c_raw_code(SaveRegs),
+ pragma_c_raw_code(RetryDef1),
+ pragma_c_raw_code(RetryDef2),
+ pragma_c_raw_code(RetryDef3),
+ pragma_c_user_code(LaterContext, Later),
+ pragma_c_raw_code(GotoSharedLabel),
+ pragma_c_raw_code(RetrySuccessLabel),
+ pragma_c_raw_code(RestoreRegs),
+ pragma_c_outputs(OutputDescs),
+ pragma_c_raw_code(Succeed),
+ pragma_c_raw_code(RetryLastSuccessLabel),
+ pragma_c_raw_code(RestoreRegs),
+ pragma_c_outputs(OutputDescs),
+ pragma_c_raw_code(SucceedDiscard),
+ pragma_c_raw_code(Undef1),
+ pragma_c_raw_code(Undef2),
+ pragma_c_raw_code(Undef3)
+ ],
+ RetryBlockCode = node([
+ pragma_c(RetryDecls, RetryComponents,
+ MayCallMercury, yes(SharedLabel))
+ - "Retry pragma C inclusion"
+ ]),
+
+ SharedDecls = [SaveStructDecl | OutDecls],
+ SharedComponents = [
+ pragma_c_raw_code(InitSaveStruct),
+ pragma_c_raw_code(SaveRegs),
+ pragma_c_raw_code(SharedDef1),
+ pragma_c_raw_code(SharedDef2),
+ pragma_c_raw_code(SharedDef3),
+ pragma_c_user_code(SharedContext, Shared),
+ pragma_c_raw_code(SharedSuccessLabel),
+ pragma_c_raw_code(RestoreRegs),
+ pragma_c_outputs(OutputDescs),
+ pragma_c_raw_code(Succeed),
+ pragma_c_raw_code(SharedLastSuccessLabel),
+ pragma_c_raw_code(RestoreRegs),
+ pragma_c_outputs(OutputDescs),
+ pragma_c_raw_code(SucceedDiscard),
+ pragma_c_raw_code(Undef1),
+ pragma_c_raw_code(Undef2),
+ pragma_c_raw_code(Undef3)
+ ],
+ SharedBlockCode = node([
+ pragma_c(SharedDecls, SharedComponents,
+ MayCallMercury, no)
+ - "Shared pragma C inclusion"
+ ]),
+
+ Code =
+ tree(ModFrameCode,
+ tree(FirstDisjunctCode,
+ tree(CallBlockCode,
+ tree(RetryLabelCode,
+ tree(LaterDisjunctCode,
+ tree(RetryBlockCode,
+ tree(SharedLabelCode,
+ SharedBlockCode)))))))
+ }
+ ).
+
+%---------------------------------------------------------------------------%
+
:- type c_arg
---> c_arg(
var,
@@ -207,13 +712,30 @@
arg_info
).
-:- pred make_c_arg_list(list(var)::in, list(maybe(string))::in,
+:- pred make_c_arg_list(list(var)::in, list(maybe(pair(string, mode)))::in,
list(type)::in, list(arg_info)::in, list(c_arg)::out) is det.
-make_c_arg_list(Vars, Names, Types, ArgInfos, ArgList) :-
- ( Vars = [], Names = [], Types = [], ArgInfos = [] ->
+make_c_arg_list(Vars, ArgInfo, Types, ArgInfos, ArgList) :-
+ (
+ Vars = [],
+ ArgInfo = [],
+ Types = [],
+ ArgInfos = []
+ ->
ArgList = []
- ; Vars = [V|Vs], Names = [N|Ns], Types = [T|Ts], ArgInfos = [A|As] ->
+ ;
+ Vars = [V|Vs],
+ ArgInfo = [MN|Ns],
+ Types = [T|Ts],
+ ArgInfos = [A|As]
+ ->
+ (
+ MN = yes(Name - _),
+ N = yes(Name)
+ ;
+ MN = no,
+ N = no
+ ),
Arg = c_arg(V, N, T, A),
make_c_arg_list(Vs, Ns, Ts, As, Args),
ArgList = [Arg | Args]
@@ -269,7 +791,7 @@
%---------------------------------------------------------------------------%
% make_pragma_decls returns the list of pragma_decls for the pragma_c
-% data structure in the llds. It is essentially a list of pairs of type and
+% data structure in the LLDS. It is essentially a list of pairs of type and
% variable name, so that declarations of the form "Type Name;" can be made.
:- pred make_pragma_decls(list(c_arg)::in, list(pragma_c_decl)::out) is det.
@@ -278,7 +800,7 @@
make_pragma_decls([Arg | Args], Decls) :-
Arg = c_arg(_Var, ArgName, OrigType, _ArgInfo),
( ArgName = yes(Name) ->
- Decl = pragma_c_decl(OrigType, Name),
+ Decl = pragma_c_arg_decl(OrigType, Name),
make_pragma_decls(Args, Decls1),
Decls = [Decl | Decls1]
;
@@ -290,7 +812,7 @@
%---------------------------------------------------------------------------%
% get_pragma_input_vars returns a list of pragma_c_inputs for the pragma_c
-% data structure in the llds. It is essentially a list of the input variables,
+% data structure in the LLDS. It is essentially a list of the input variables,
% and the corresponding rvals assigned to those (C) variables.
:- pred get_pragma_input_vars(list(c_arg)::in, list(pragma_c_input)::out,
@@ -353,8 +875,53 @@
%---------------------------------------------------------------------------%
-pragma_c_gen__generate_backtrack_pragma_c_code(_, _, _, _, _, _, _, _, _, _,
- _, _) -->
- { error("Sorry, nondet pragma_c_codes not yet implemented") }.
+% input_descs_from_arg_info returns a list of pragma_c_inputs, which
+% are pairs of rvals and (C) variables which receive the input value.
+
+:- pred input_descs_from_arg_info(list(c_arg)::in, list(pragma_c_input)::out)
+ is det.
+
+input_descs_from_arg_info([], []).
+input_descs_from_arg_info([Arg | Args], Inputs) :-
+ Arg = c_arg(_Var, MaybeName, OrigType, ArgInfo),
+ ( MaybeName = yes(Name) ->
+ ArgInfo = arg_info(N, _),
+ Reg = reg(r, N),
+ Input = pragma_c_input(Name, OrigType, lval(Reg)),
+ Inputs = [Input | Inputs1],
+ input_descs_from_arg_info(Args, Inputs1)
+ ;
+ input_descs_from_arg_info(Args, Inputs)
+ ).
+
+%---------------------------------------------------------------------------%
+
+% output_descs_from_arg_info returns a list of pragma_c_outputs, which
+% are pairs of names of output registers and (C) variables which hold the
+% output value.
+
+:- pred output_descs_from_arg_info(list(c_arg)::in, list(pragma_c_output)::out)
+ is det.
+
+output_descs_from_arg_info([], []).
+output_descs_from_arg_info([Arg | Args], [Output | Outputs]) :-
+ Arg = c_arg(_Var, MaybeName, OrigType, ArgInfo),
+ ( MaybeName = yes(Name) ->
+ ArgInfo = arg_info(N, _),
+ Reg = reg(r, N),
+ Output = pragma_c_output(Reg, OrigType, Name)
+ ;
+ error("output_descs_from_arg_info: unnamed arg")
+ ),
+ output_descs_from_arg_info(Args, Outputs).
+
+%---------------------------------------------------------------------------%
+
+pragma_c_gen__struct_name(ModuleName, PredName, Arity, ProcId, StructName) :-
+ proc_id_to_int(ProcId, ProcNum),
+ string__int_to_string(Arity, ArityStr),
+ string__int_to_string(ProcNum, ProcNumStr),
+ string__append_list(["mercury_save__", ModuleName, "__",
+ PredName, "__", ArityStr, "_", ProcNumStr], StructName).
%---------------------------------------------------------------------------%
Index: compiler/prog_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.29
diff -u -u -r1.29 prog_data.m
--- prog_data.m 1997/12/22 09:56:16 1.29
+++ prog_data.m 1998/01/06 07:17:35
@@ -99,18 +99,10 @@
; c_code(string)
; c_code(may_call_mercury, sym_name, pred_or_func,
- list(pragma_var), varset, string)
+ list(pragma_var), varset, pragma_code)
% Whether or not the C code may call Mercury,
% PredName, Predicate or Function, Vars/Mode,
- % VarNames, C Code
-
- ; c_code(may_call_mercury, sym_name,
- pred_or_func, list(pragma_var),
- list(string), list(string),
- varset, string)
- % Whether or not the C code may call Mercury,
- % PredName, Predicate or Function, Vars/Mode,
- % SavedeVars, LabelNames, VarNames, C Code
+ % VarNames, C Code Info
; memo(sym_name, arity)
% Predname, Arity
@@ -166,6 +158,47 @@
; check_termination(sym_name, arity).
% Predname, Arity
+
+ % All the strings in this type are accompanied by the context
+ % of their appearance in the source code. These contexts are
+ % used to tell the C compiler where the included C code comes from,
+ % to allow it to generate error messages that refer to the original
+ % appearance of the code in the Mercury program.
+:- type pragma_code
+ ---> ordinary( % This is a C definition of a model_det
+ % or model_semi procedure. (We also
+ % allow model_non, until everyone has
+ % had time to adapt to the new way
+ % of handling model_non pragmas.
+ string, % The C code of the procedure.
+ term__context
+ )
+ ; nondet( % This is a C definition of a model_non
+ % procedure.
+ string, % The info saved for the time when
+ term__context, % backtracking reenters this procedure
+ % is stored in a C struct. This arg
+ % contains the field declarations.
+ string, % Gives the code to be executed when
+ term__context, % the procedure is called for the first
+ % time. This code may access the input
+ % variables.
+ string, % Gives the code to be executed when
+ term__context, % control backtracks into the procedure.
+ % This code may not access the input
+ % variables.
+ pragma_shared_code_treatment,
+ % How should the shared code be
+ % treated during code generation.
+ string, % Shared code that is executed after
+ term__context % both the previous code fragments.
+ % May not access the input variables.
+ ).
+
+:- type pragma_shared_code_treatment
+ ---> duplicate
+ ; share
+ ; automatic.
:- type class_constraint ---> constraint(class_name, list(type)).
Index: compiler/prog_io_pragma.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io_pragma.m,v
retrieving revision 1.10
diff -u -u -r1.10 prog_io_pragma.m
--- prog_io_pragma.m 1997/12/22 09:56:18 1.10
+++ prog_io_pragma.m 1998/01/08 06:37:18
@@ -23,7 +23,7 @@
:- implementation.
:- import_module prog_io_goal, hlds_pred, term_util, term_errors.
-:- import_module string, std_util, bool, require.
+:- import_module int, string, std_util, bool, require.
parse_pragma(ModuleName, VarSet, PragmaTerms, Result) :-
(
@@ -106,42 +106,97 @@
% XXX we should issue a warning; this syntax is deprecated.
% Result = error("pragma c_code doesn't say whether it can call mercury", PredAndVarsTerm)
MayCallMercury = will_not_call_mercury,
- parse_pragma_c_code(ModuleName, MayCallMercury, PredAndVarsTerm,
- no, C_CodeTerm, VarSet, Result)
+ (
+ C_CodeTerm = term__functor(term__string(C_Code), [], Context)
+ ->
+ parse_pragma_c_code(ModuleName, MayCallMercury, PredAndVarsTerm,
+ ordinary(C_Code, Context), VarSet, Result)
+ ;
+ Result = error("invalid `:- pragma c_code' declaration -- expecting either `may_call_mercury' or `will_not_call_mercury', and a string for C code",
+ C_CodeTerm)
+ )
;
PragmaTerms = [PredAndVarsTerm, MayCallMercuryTerm, C_CodeTerm]
->
- ( parse_may_call_mercury(MayCallMercuryTerm, MayCallMercury) ->
- parse_pragma_c_code(ModuleName, MayCallMercury, PredAndVarsTerm,
- no, C_CodeTerm, VarSet, Result)
- ; parse_may_call_mercury(PredAndVarsTerm, MayCallMercury) ->
- % XXX we should issue a warning; this syntax is deprecated
- parse_pragma_c_code(ModuleName, MayCallMercury,
- MayCallMercuryTerm, no, C_CodeTerm, VarSet, Result)
- ;
- Result = error("invalid second argument in `:- pragma c_code(..., ..., ...)' declaration -- expecting either `may_call_mercury' or `will_not_call_mercury'",
+ (
+ C_CodeTerm = term__functor(term__string(C_Code), [], Context)
+ ->
+ ( parse_may_call_mercury(MayCallMercuryTerm, MayCallMercury) ->
+ parse_pragma_c_code(ModuleName, MayCallMercury,
+ PredAndVarsTerm, ordinary(C_Code, Context),
+ VarSet, Result)
+ ; parse_may_call_mercury(PredAndVarsTerm, MayCallMercury) ->
+ % XXX we should issue a warning; this syntax is deprecated
+ parse_pragma_c_code(ModuleName, MayCallMercury,
+ MayCallMercuryTerm, ordinary(C_Code, Context),
+ VarSet, Result)
+ ;
+ Result = error("invalid second argument in `:- pragma c_code' declaration -- expecting either `may_call_mercury' or `will_not_call_mercury'",
MayCallMercuryTerm)
+ )
+ ;
+ Result = error("invalid third argument in `:- pragma c_code' declaration -- expecting string for C code",
+ C_CodeTerm)
)
;
- PragmaTerms = [PredAndVarsTerm, MayCallMercuryTerm,
- SavedVarsTerm, LabelNamesTerm, C_CodeTerm]
+ (
+ PragmaTerms = [PredAndVarsTerm, MayCallMercuryTerm,
+ FieldsTerm, FirstTerm, LaterTerm],
+ term__context_init(DummyContext),
+ SharedTerm = term__functor(term__atom("common_code"),
+ [term__functor(term__string(""), [], DummyContext)],
+ DummyContext)
+ ;
+ PragmaTerms = [PredAndVarsTerm, MayCallMercuryTerm,
+ FieldsTerm, FirstTerm, LaterTerm, SharedTerm]
+ )
->
( parse_may_call_mercury(MayCallMercuryTerm, MayCallMercury) ->
- ( parse_ident_list(SavedVarsTerm, SavedVars) ->
- ( parse_ident_list(LabelNamesTerm, LabelNames) ->
- parse_pragma_c_code(ModuleName, MayCallMercury,
- PredAndVarsTerm, yes(SavedVars - LabelNames),
- C_CodeTerm, VarSet, Result)
+ ( parse_pragma_keyword("local_vars", FieldsTerm, Fields, FieldsContext) ->
+ ( parse_pragma_keyword("first_code", FirstTerm, First, FirstContext) ->
+ ( parse_pragma_keyword("retry_code", LaterTerm, Later, LaterContext) ->
+ ( parse_pragma_keyword("shared_code", SharedTerm, Shared, SharedContext) ->
+ parse_pragma_c_code(ModuleName, MayCallMercury,
+ PredAndVarsTerm,
+ nondet(Fields, FieldsContext,
+ First, FirstContext,
+ Later, LaterContext,
+ share, Shared, SharedContext),
+ VarSet, Result)
+ ; parse_pragma_keyword("duplicated_code", SharedTerm, Shared, SharedContext) ->
+ parse_pragma_c_code(ModuleName, MayCallMercury,
+ PredAndVarsTerm,
+ nondet(Fields, FieldsContext,
+ First, FirstContext,
+ Later, LaterContext,
+ duplicate, Shared, SharedContext),
+ VarSet, Result)
+ ; parse_pragma_keyword("common_code", SharedTerm, Shared, SharedContext) ->
+ parse_pragma_c_code(ModuleName, MayCallMercury,
+ PredAndVarsTerm,
+ nondet(Fields, FieldsContext,
+ First, FirstContext,
+ Later, LaterContext,
+ automatic, Shared, SharedContext),
+ VarSet, Result)
+ ;
+ Result = error("invalid sixth argument in `:- pragma c_code' declaration -- expecting `shared_code(<code>')",
+ LaterTerm)
+ )
+ ;
+ Result = error("invalid fifth argument in `:- pragma c_code' declaration -- expecting `later_code(<code>')",
+ LaterTerm)
+ )
;
- Result = error("invalid fourth argument in `:- pragma c_code/5' declaration -- expecting a list of C identifiers",
- MayCallMercuryTerm)
+ Result = error("invalid fourth argument in `:- pragma c_code' declaration -- expecting `first_code(<code>')",
+ FirstTerm)
)
;
- Result = error("invalid third argument in `:- pragma c_code/5' declaration -- expecting a list of C identifiers",
- MayCallMercuryTerm)
+ Result = error("invalid third argument in `:- pragma c_code' declaration -- expecting `local_vars(<fields>)'",
+ FieldsTerm)
)
;
- Result = error("invalid second argument in `:- pragma c_code/3' declaration -- expecting either `may_call_mercury' or `will_not_call_mercury'",
+ Result = error("invalid second argument in `:- pragma c_code' declaration -- expecting either `may_call_mercury' or `will_not_call_mercury'",
MayCallMercuryTerm)
)
;
@@ -426,7 +481,6 @@
Pragma = check_termination(Name, Arity)),
PragmaTerms, ErrorTerm, Result).
-
:- pred parse_simple_pragma(module_name, string,
pred(sym_name, int, pragma_type),
list(term), term, maybe1(item)).
@@ -468,6 +522,24 @@
%-----------------------------------------------------------------------------%
+:- pred parse_pragma_keyword(string, term, string, term__context).
+:- mode parse_pragma_keyword(in, in, out, out) is semidet.
+
+parse_pragma_keyword(ExpectedKeyword, Term, StringArg, StartContext) :-
+ Term = term__functor(term__atom(ExpectedKeyword), [Arg], _),
+ Arg = term__functor(term__string(StringArg), [], StartContext).
+% EndContext = term__context(File, EndLine),
+% AddOneIfNewline = lambda([Char::in, Count0::in, Count::out] is det, (
+% ( Char = '\n' ->
+% Count is Count0 + 1
+% ;
+% Count = Count0
+% )
+% )),
+% string__foldl(AddOneIfNewline, StringArg, 0, LinesInString),
+% StartLine is EndLine - LinesInString - 1,
+% StartContext = term__context(File, StartLine).
+
:- pred parse_may_call_mercury(term, may_call_mercury).
:- mode parse_may_call_mercury(in, out) is semidet.
@@ -477,27 +549,17 @@
will_not_call_mercury).
parse_may_call_mercury(term__functor(term__atom("may_call_mercury"), [], _),
may_call_mercury).
-parse_may_call_mercury(term__functor(term__atom("will_not_call_mercury"), [], _),
- will_not_call_mercury).
-
-:- pred parse_ident_list(term, list(string)).
-:- mode parse_ident_list(in, out) is semidet.
-
-parse_ident_list(term__functor(term__atom("[]"), [], _), []).
-parse_ident_list(term__functor(term__atom("."), [Head, Tail], _),
- [SavedVar | SavedVars]) :-
- % XXX liberalize this
- Head = term__functor(term__atom(SavedVar), [], _),
- parse_ident_list(Tail, SavedVars).
+parse_may_call_mercury(term__functor(term__atom("will_not_call_mercury"), [],
+ _), will_not_call_mercury).
% parse a pragma c_code declaration
:- pred parse_pragma_c_code(module_name, may_call_mercury, term,
- maybe(pair(list(string))), term, varset, maybe1(item)).
-:- mode parse_pragma_c_code(in, in, in, in, in, in, out) is det.
+ pragma_code, varset, maybe1(item)).
+:- mode parse_pragma_c_code(in, in, in, in, in, out) is det.
-parse_pragma_c_code(ModuleName, MayCallMercury, PredAndVarsTerm0, ExtraInfo,
- C_CodeTerm, VarSet, Result) :-
+parse_pragma_c_code(ModuleName, MayCallMercury, PredAndVarsTerm0, PragmaCode,
+ VarSet, Result) :-
(
PredAndVarsTerm0 = term__functor(Const, Terms0, _)
->
@@ -509,7 +571,7 @@
% function
PredOrFunc = function,
PredAndVarsTerm = FuncAndVarsTerm,
- FuncResultTerms = [ FuncResultTerm0 ]
+ FuncResultTerms = [FuncResultTerm0]
;
% predicate
PredOrFunc = predicate,
@@ -517,7 +579,7 @@
FuncResultTerms = []
),
parse_qualified_term(ModuleName, PredAndVarsTerm, PredAndVarsTerm0,
- "pragma c_code declaration", PredNameResult),
+ "pragma c_code declaration", PredNameResult),
(
PredNameResult = ok(PredName, VarList0),
(
@@ -527,29 +589,14 @@
PredOrFunc = function,
list__append(VarList0, FuncResultTerms, VarList)
),
+ parse_pragma_c_code_varlist(VarSet, VarList, PragmaVars, Error),
(
- C_CodeTerm = term__functor(term__string(C_Code), [], _)
- ->
- parse_pragma_c_code_varlist(VarSet,
- VarList, PragmaVars, Error),
- (
- Error = no,
- (
- ExtraInfo = no,
- Result = ok(pragma(c_code(MayCallMercury, PredName,
- PredOrFunc, PragmaVars, VarSet, C_Code)))
- ;
- ExtraInfo = yes(SavedVars - LabelNames),
- Result = ok(pragma(c_code(MayCallMercury, PredName,
- PredOrFunc, PragmaVars, SavedVars, LabelNames,
- VarSet, C_Code)))
- )
- ;
- Error = yes(ErrorMessage),
- Result = error(ErrorMessage, PredAndVarsTerm)
- )
+ Error = no,
+ Result = ok(pragma(c_code(MayCallMercury, PredName,
+ PredOrFunc, PragmaVars, VarSet, PragmaCode)))
;
- Result = error("expected string for C code", C_CodeTerm)
+ Error = yes(ErrorMessage),
+ Result = error(ErrorMessage, PredAndVarsTerm)
)
;
PredNameResult = error(Msg, Term),
Index: compiler/purity.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/purity.m,v
retrieving revision 1.5
diff -u -u -r1.5 purity.m
--- purity.m 1998/01/06 06:31:36 1.5
+++ purity.m 1998/01/08 08:01:09
@@ -587,7 +587,7 @@
{ worst_purity(Purity12, Purity3, Purity) }.
compute_expr_purity(Ccode, Ccode, _, _, ModuleInfo, _, Purity,
NumErrors, NumErrors) -->
- { Ccode = pragma_c_code(_,_,PredId,_,_,_,_,_) },
+ { Ccode = pragma_c_code(_,PredId,_,_,_,_,_) },
{ module_info_preds(ModuleInfo, Preds) },
{ map__lookup(Preds, PredId, PredInfo) },
{ pred_info_get_purity(PredInfo, Purity) }.
Index: compiler/quantification.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/quantification.m,v
retrieving revision 1.55
diff -u -u -r1.55 quantification.m
--- quantification.m 1997/12/22 09:56:21 1.55
+++ quantification.m 1998/01/02 04:42:33
@@ -317,8 +317,8 @@
{ set__union(NonLocalVars1, NonLocalVars2, NonLocalVars) },
quantification__set_nonlocals(NonLocalVars).
-implicitly_quantify_goal_2(pragma_c_code(A,B,C,D,Vars,F,G,H), _,
- pragma_c_code(A,B,C,D,Vars,F,G,H)) -->
+implicitly_quantify_goal_2(pragma_c_code(A,B,C,Vars,E,F,G), _,
+ pragma_c_code(A,B,C,Vars,E,F,G)) -->
implicitly_quantify_atomic_goal(Vars).
:- pred implicitly_quantify_atomic_goal(list(var), quant_info, quant_info).
@@ -642,7 +642,7 @@
set__union(Set5, Set6, Set),
set__union(LambdaSet5, LambdaSet6, LambdaSet).
-quantification__goal_vars_2(pragma_c_code(_, _, _, _, ArgVars, _, _, _),
+quantification__goal_vars_2(pragma_c_code(_, _, _, ArgVars, _, _, _),
Set0, LambdaSet, Set, LambdaSet) :-
set__insert_list(Set0, ArgVars, Set).
Index: compiler/saved_vars.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/saved_vars.m,v
retrieving revision 1.13
diff -u -u -r1.13 saved_vars.m
--- saved_vars.m 1997/12/22 09:56:22 1.13
+++ saved_vars.m 1998/01/02 04:42:41
@@ -122,7 +122,7 @@
Goal = GoalExpr0 - GoalInfo0,
SlotInfo = SlotInfo0
;
- GoalExpr0 = pragma_c_code(_, _, _, _, _, _, _, _),
+ GoalExpr0 = pragma_c_code(_, _, _, _, _, _, _),
Goal = GoalExpr0 - GoalInfo0,
SlotInfo = SlotInfo0
),
@@ -287,7 +287,7 @@
IsNonLocal, SlotInfo1, Goals1, SlotInfo),
Goals = [NewConstruct, Goal1 | Goals1]
;
- Goal0Expr = pragma_c_code(_, _, _, _, _, _, _, _),
+ Goal0Expr = pragma_c_code(_, _, _, _, _, _, _),
rename_var(SlotInfo0, Var, _NewVar, Subst, SlotInfo1),
goal_util__rename_vars_in_goal(Construct, Subst,
NewConstruct),
Index: compiler/simplify.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/simplify.m,v
retrieving revision 1.50
diff -u -u -r1.50 simplify.m
--- simplify.m 1997/12/22 09:56:24 1.50
+++ simplify.m 1998/01/02 06:09:11
@@ -784,9 +784,10 @@
Goal = some(Vars, Goal3).
simplify__goal_2(Goal0, GoalInfo, Goal, GoalInfo, Info0, Info) :-
- Goal0 = pragma_c_code(_, _, PredId, ProcId, Args, _, _, _),
- ( simplify_do_calls(Info0),
- goal_info_is_pure(GoalInfo)
+ Goal0 = pragma_c_code(_, PredId, ProcId, Args, _, _, _),
+ (
+ simplify_do_calls(Info0),
+ goal_info_is_pure(GoalInfo)
->
common__optimise_call(PredId, ProcId, Args, Goal0,
GoalInfo, Goal, Info0, Info)
@@ -1597,7 +1598,7 @@
Goal = GoalExpr - _,
GoalExpr \= call(_, _, _, _, _, _),
GoalExpr \= higher_order_call(_, _, _, _, _, _),
- GoalExpr \= pragma_c_code(_, _, _, _, _, _, _, _)
+ GoalExpr \= pragma_c_code(_, _, _, _, _, _, _)
)
->
simplify_info_get_common_info(Info0, CommonInfo0),
Index: compiler/store_alloc.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/store_alloc.m,v
retrieving revision 1.56
diff -u -u -r1.56 store_alloc.m
--- store_alloc.m 1997/12/19 03:08:12 1.56
+++ store_alloc.m 1998/01/02 07:15:04
@@ -177,8 +177,8 @@
store_alloc_in_goal_2(unify(A,B,C,D,E), Liveness, _, _,
unify(A,B,C,D,E), Liveness).
-store_alloc_in_goal_2(pragma_c_code(A, B, C, D, E, F, G, H), Liveness, _, _,
- pragma_c_code(A, B, C, D, E, F, G, H), Liveness).
+store_alloc_in_goal_2(pragma_c_code(A, B, C, D, E, F, G), Liveness, _, _,
+ pragma_c_code(A, B, C, D, E, F, G), Liveness).
%-----------------------------------------------------------------------------%
Index: compiler/stratify.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/stratify.m,v
retrieving revision 1.12
diff -u -u -r1.12 stratify.m
--- stratify.m 1997/12/19 03:08:15 1.12
+++ stratify.m 1998/01/02 04:43:23
@@ -37,7 +37,6 @@
:- import_module hlds_module, io.
-
% Perform stratification analysis, for the given module.
% If the "warn-non-stratification" option is set this
% pred will check the entire module for stratification
@@ -49,7 +48,6 @@
io__state, io__state).
:- mode stratify__check_stratification(in, out, di, uo) is det.
-
:- implementation.
:- import_module dependency_graph, hlds_pred, hlds_goal, hlds_data.
@@ -58,8 +56,6 @@
:- import_module assoc_list, map, list, set, bool, std_util, relation, require.
-
-
stratify__check_stratification(Module0, Module) -->
{ module_info_ensure_dependency_info(Module0, Module1) },
{ module_info_dependency_info(Module1, DepInfo) },
@@ -81,8 +77,6 @@
%{ dep_sets_to_lists_and_sets(HOSCCs1, [], HOSCCs) },
%higher_order_check_sccs(HOSCCs, HOInfo, Module2, Module).
-
-
%-----------------------------------------------------------------------------%
:- pred dep_sets_to_lists_and_sets(list(set(pred_proc_id)),
@@ -186,7 +180,7 @@
WholeScc, ThisPredProcId, Error, Module0, Module) -->
first_order_check_goal(Goal, GoalInfo, yes, WholeScc, ThisPredProcId,
Error, Module0, Module).
-first_order_check_goal(pragma_c_code(_, _IsRec, CPred, CProc, _, _, _, _),
+first_order_check_goal(pragma_c_code(_IsRec, CPred, CProc, _, _, _, _),
GoalInfo, Negated, WholeScc, ThisPredProcId,
Error, Module0, Module) -->
(
@@ -372,7 +366,7 @@
ThisPredProcId, HighOrderLoops, Error, Module0, Module) -->
higher_order_check_goal(Goal, GoalInfo, yes, WholeScc, ThisPredProcId,
HighOrderLoops, Error, Module0, Module).
-higher_order_check_goal(pragma_c_code(_, _IsRec, _, _, _, _, _, _), _GoalInfo,
+higher_order_check_goal(pragma_c_code(_IsRec, _, _, _, _, _, _), _GoalInfo,
_Negated, _WholeScc, _ThisPredProcId, _HighOrderLoops,
_, Module, Module) --> [].
higher_order_check_goal(unify(_Var, _RHS, _Mode, _Uni, _Context), _GoalInfo,
@@ -505,7 +499,6 @@
map__to_assoc_list(HOInfo, HOInfoL),
add_new_arcs(HOInfoL, CallsHO, DepGraph0, DepGraph).
-
% For a given module collects for each non imported proc a set
% of called procs and a higher order info structure. This pred
% also returns a set of all non imported procs that make a
@@ -521,7 +514,6 @@
expand_predids(PredIds, Module, ProcCalls0, ProcCalls, HOInfo0,
HOInfo, CallsHO0, CallsHO).
-
% find the transitive closure of a given list of procs
% this pred is used to see how face a higher order address can
% reach though proc calls
@@ -554,7 +546,6 @@
Changed0, Changed1),
tc(Ps, ProcCalls, CallsHO, HOInfo1, HOInfo, Changed1, Changed).
-
% merge any higher order addresses that can pass between the
% given caller and callees. This code also merges any possible
% addresses that can pass in and out of higher order calls
@@ -650,7 +641,6 @@
Changed0, Changed)
).
-
% given the set of procs that make higher order calls and a
% list of procs and higher order call info this pred rebuilds
% the given call graph with new arcs for every possible higher
@@ -685,8 +675,6 @@
relation__add(DepGraph0, CallerKey, CalleeKey, DepGraph1),
add_new_arcs2(Cs, CallerKey, DepGraph1, DepGraph).
-
-
% for each given pred id pass all non imported procs onto the
% process_procs pred
:- pred expand_predids(list(pred_id), module_info, call_map, call_map,
@@ -705,7 +693,6 @@
expand_predids(PredIds, Module, ProcCalls1, ProcCalls, HOInfo1,
HOInfo, CallsHO1, CallsHO).
-
% for each given proc id generate the set of procs it calls and
% its higher order info structure
:- pred process_procs(list(proc_id), module_info, pred_id, list(type),
@@ -736,7 +723,6 @@
process_procs(Procs, Module, PredId, ArgTypes, ProcTable, ProcCalls1,
ProcCalls, HOInfo1, HOInfo, CallsHO1, CallsHO).
-
% determine if a given set of modes and types indicates that
% higher order values can be passed into and/or out of a proc
:- pred higherorder_in_out(list(type), list(mode), module_info, ho_in_out).
@@ -791,7 +777,6 @@
),
higherorder_in_out1(Types, Modes, Module, HOIn1, HOIn, HOOut1, HOOut).
-
% return the set of all procs called in and all addresses
% taken, in a given goal
:- pred check_goal(hlds_goal_expr, set(pred_proc_id), set(pred_proc_id),
@@ -878,9 +863,8 @@
CallsHO) :-
check_goal1(Goal, Calls0, Calls, HasAT0, HasAT, CallsHO0, CallsHO).
-check_goal1(pragma_c_code(_, _IsRec, _CPred, _CProc, _, _, _, _), Calls, Calls,
+check_goal1(pragma_c_code(_IsRec, _CPred, _CProc, _, _, _, _), Calls, Calls,
HasAT, HasAT, CallsHO, CallsHO).
-
:- pred check_goal_list(list(hlds_goal), set(pred_proc_id), set(pred_proc_id),
set(pred_proc_id), set(pred_proc_id), bool, bool).
@@ -903,7 +887,6 @@
check_goal1(Goal, Calls0, Calls1, HasAT0, HasAT1, CallsHO0, CallsHO1),
check_case_list(Goals, Calls1, Calls, HasAT1, HasAT, CallsHO1, CallsHO).
-
% This pred returns a list of all the calls in a given set of
% goals including calls in unification lambda functions and
% pred_proc_id's in constructs
@@ -943,7 +926,6 @@
Calls = Calls0
).
-
% add this call to the call list
get_called_procs(call(CPred, CProc, _Args, _Builtin, _Contex, _Sym), Calls0,
Calls) :-
@@ -955,7 +937,6 @@
get_called_procs(class_method_call(_Var, _Num,_Vars, _Types, _Modes, _Det),
Calls, Calls).
-
get_called_procs(conj(Goals), Calls0, Calls) :-
check_goal_list(Goals, Calls0, Calls).
get_called_procs(disj(Goals, _Follow), Calls0, Calls) :-
@@ -971,10 +952,9 @@
get_called_procs(Goal, Calls0, Calls).
get_called_procs(not(Goal - _GoalInfo), Calls0, Calls) :-
get_called_procs(Goal, Calls0, Calls).
-get_called_procs(pragma_c_code(_, _IsRec, _CPred, _CProc, _, _, _, _),
+get_called_procs(pragma_c_code(_IsRec, _CPred, _CProc, _, _, _, _),
Calls, Calls).
-
:- pred check_goal_list(list(hlds_goal), list(pred_proc_id),
list(pred_proc_id)).
:- mode check_goal_list(in, in, out) is det.
@@ -995,8 +975,6 @@
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
-
-
:- pred emit_message(pred_proc_id, term__context, string, bool,
module_info, module_info, io__state, io__state).
Index: compiler/switch_detection.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/switch_detection.m,v
retrieving revision 1.77
diff -u -u -r1.77 switch_detection.m
--- switch_detection.m 1997/12/19 03:08:17 1.77
+++ switch_detection.m 1998/01/02 04:43:36
@@ -190,8 +190,8 @@
VarTypes, ModuleInfo, switch(Var, CanFail, Cases, SM)) :-
detect_switches_in_cases(Cases0, InstMap, VarTypes, ModuleInfo, Cases).
-detect_switches_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)).
+detect_switches_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/term_traversal.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/term_traversal.m,v
retrieving revision 1.1
diff -u -u -r1.1 term_traversal.m
--- term_traversal.m 1997/12/22 09:56:32 1.1
+++ term_traversal.m 1998/01/02 04:43:44
@@ -179,7 +179,7 @@
traverse_goal(Else, Params, Info0, Info2),
combine_paths(Info1, Info2, Params, Info).
-traverse_goal_2(pragma_c_code(_, _, CallPredId, CallProcId, Args, _, _, _),
+traverse_goal_2(pragma_c_code(_, CallPredId, CallProcId, Args, _, _, _),
GoalInfo, Params, Info0, Info) :-
params_get_module_info(Params, Module),
module_info_pred_proc_info(Module, CallPredId, CallProcId, _,
Index: compiler/typecheck.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/typecheck.m,v
retrieving revision 1.224
diff -u -u -r1.224 typecheck.m
--- typecheck.m 1998/01/02 00:10:51 1.224
+++ typecheck.m 1998/01/02 04:44:05
@@ -762,8 +762,7 @@
typecheck_goal_2(switch(_, _, _, _), _) -->
{ error("unexpected switch") }.
% no need to typecheck pragmas
-typecheck_goal_2(pragma_c_code(A,B,C,D,E,F,G,H),
- pragma_c_code(A,B,C,D,E,F,G,H))
+typecheck_goal_2(pragma_c_code(A,B,C,D,E,F,G), pragma_c_code(A,B,C,D,E,F,G))
--> [].
%-----------------------------------------------------------------------------%
Index: compiler/unique_modes.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/unique_modes.m,v
retrieving revision 1.43
diff -u -u -r1.43 unique_modes.m
--- unique_modes.m 1998/01/05 07:26:22 1.43
+++ unique_modes.m 1998/01/08 03:08:54
@@ -423,14 +423,14 @@
% to modecheck a pragma_c_code, we just modecheck the proc for
% which it is the goal.
-unique_modes__check_goal_2(pragma_c_code(IsRecursive, C_Code, PredId, ProcId0,
- Args, ArgNameMap, OrigArgTypes, ExtraPragmaInfo),
+unique_modes__check_goal_2(pragma_c_code(IsRecursive, PredId, ProcId0,
+ Args, ArgNameMap, OrigArgTypes, PragmaCode),
_GoalInfo, Goal) -->
mode_checkpoint(enter, "pragma_c_code"),
mode_info_set_call_context(call(PredId)),
unique_modes__check_call(PredId, ProcId0, Args, ProcId),
- { Goal = pragma_c_code(IsRecursive, C_Code, PredId, ProcId, Args,
- ArgNameMap, OrigArgTypes, ExtraPragmaInfo) },
+ { Goal = pragma_c_code(IsRecursive, PredId, ProcId, Args,
+ ArgNameMap, OrigArgTypes, PragmaCode) },
mode_info_unset_call_context,
mode_checkpoint(exit, "pragma_c_code").
Index: compiler/unused_args.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/unused_args.m,v
retrieving revision 1.39
diff -u -u -r1.39 unused_args.m
--- unused_args.m 1997/12/22 09:56:39 1.39
+++ unused_args.m 1998/01/02 06:09:28
@@ -444,7 +444,7 @@
set_list_vars_used(UseInf0, [PredVar|Args], UseInf).
% handle pragma(c_code, ...) - pragma_c_code uses all its args
-traverse_goal(_, pragma_c_code(_, _, _, _, Args, _, _, _), UseInf0, UseInf) :-
+traverse_goal(_, pragma_c_code(_, _, _, Args, _, _, _), UseInf0, UseInf) :-
set_list_vars_used(UseInf0, Args, UseInf).
% cases to handle all the different types of unification
@@ -1246,7 +1246,7 @@
fixup_goal_expr(_ModuleInfo, _UnusedVars, _ProcCallInfo, no,
GoalExpr - GoalInfo, GoalExpr - GoalInfo) :-
- GoalExpr = pragma_c_code(_, _, _, _, _, _, _, _).
+ GoalExpr = pragma_c_code(_, _, _, _, _, _, _).
% Remove useless unifications from a list of conjuncts.
:- pred fixup_conjuncts(module_info::in, list(var)::in, proc_call_info::in,
Index: compiler/value_number.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/value_number.m,v
retrieving revision 1.88
diff -u -u -r1.88 value_number.m
--- value_number.m 1997/12/22 06:58:44 1.88
+++ value_number.m 1998/01/06 08:24:03
@@ -172,7 +172,7 @@
Target = succfr(_)
)
;
- Uinstr0 = mkframe(_, _, _)
+ Uinstr0 = mkframe(_, _, _, _)
)
->
N1 is N0 + 1,
@@ -1075,7 +1075,7 @@
value_number__boundary_instr(block(_, _, _), no).
value_number__boundary_instr(assign(_,_), no).
value_number__boundary_instr(call(_, _, _, _), yes).
-value_number__boundary_instr(mkframe(_, _, _), yes).
+value_number__boundary_instr(mkframe(_, _, _, _), yes).
value_number__boundary_instr(modframe(_), yes).
value_number__boundary_instr(label(_), yes).
value_number__boundary_instr(goto(_), yes).
@@ -1092,7 +1092,7 @@
value_number__boundary_instr(discard_tickets_to(_), no).
value_number__boundary_instr(incr_sp(_, _), yes).
value_number__boundary_instr(decr_sp(_), yes).
-value_number__boundary_instr(pragma_c(_, _, _, _, _), yes).
+value_number__boundary_instr(pragma_c(_, _, _, _), yes).
%-----------------------------------------------------------------------------%
Index: compiler/vn_block.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/vn_block.m,v
retrieving revision 1.50
diff -u -u -r1.50 vn_block.m
--- vn_block.m 1997/12/05 15:48:02 1.50
+++ vn_block.m 1998/01/06 08:15:33
@@ -229,10 +229,10 @@
vn_block__new_ctrl_node(vn_call(Proc, Return, Info, CallModel), Livemap,
Params, VnTables0, VnTables,
Liveset0, Liveset, Tuple0, Tuple).
-vn_block__handle_instr(mkframe(Name, Size, Redoip), Livemap, Params,
+vn_block__handle_instr(mkframe(Name, Size, Pragma, Redoip), Livemap, Params,
VnTables0, VnTables, Liveset0, Liveset,
SeenIncr0, SeenIncr, Tuple0, Tuple) :-
- vn_block__new_ctrl_node(vn_mkframe(Name, Size, Redoip),
+ vn_block__new_ctrl_node(vn_mkframe(Name, Size, Pragma, Redoip),
Livemap, Params, VnTables0, VnTables1,
Liveset0, Liveset1, Tuple0, Tuple1),
vn_block__handle_instr(assign(redoip(lval(maxfr)),
@@ -353,7 +353,7 @@
vn_block__new_ctrl_node(vn_decr_sp(N), Livemap,
Params, VnTables0, VnTables,
Liveset0, Liveset, Tuple0, Tuple).
-vn_block__handle_instr(pragma_c(_, _, _, _, _),
+vn_block__handle_instr(pragma_c(_, _, _, _),
_Livemap, _Params, VnTables, VnTables, Liveset, Liveset,
SeenIncr, SeenIncr, Tuple, Tuple) :-
error("value numbering not supported for pragma_c").
@@ -388,7 +388,7 @@
LabelNo = LabelNo0,
Parallels = []
;
- VnInstr = vn_mkframe(_, _, _),
+ VnInstr = vn_mkframe(_, _, _, _),
VnTables = VnTables0,
Liveset = Liveset0,
FlushEntry = FlushEntry0,
@@ -874,7 +874,7 @@
vn_block__is_ctrl_instr(block(_, _, _), no).
vn_block__is_ctrl_instr(assign(_, _), no).
vn_block__is_ctrl_instr(call(_, _, _, _), yes).
-vn_block__is_ctrl_instr(mkframe(_, _, _), yes).
+vn_block__is_ctrl_instr(mkframe(_, _, _, _), yes).
vn_block__is_ctrl_instr(modframe(_), no).
vn_block__is_ctrl_instr(label(_), yes).
vn_block__is_ctrl_instr(goto(_), yes).
@@ -891,7 +891,7 @@
vn_block__is_ctrl_instr(discard_tickets_to(_), yes).
vn_block__is_ctrl_instr(incr_sp(_, _), yes).
vn_block__is_ctrl_instr(decr_sp(_), yes).
-vn_block__is_ctrl_instr(pragma_c(_, _, _, _, _), no).
+vn_block__is_ctrl_instr(pragma_c(_, _, _, _), no).
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
Index: compiler/vn_cost.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/vn_cost.m,v
retrieving revision 1.29
diff -u -u -r1.29 vn_cost.m
--- vn_cost.m 1997/12/05 15:48:05 1.29
+++ vn_cost.m 1998/01/06 08:15:39
@@ -111,7 +111,7 @@
Uinstr = call(_, _, _, _),
Cost = 0
;
- Uinstr = mkframe(_, _, _),
+ Uinstr = mkframe(_, _, _, _),
Cost = 0
;
Uinstr = modframe(_),
@@ -181,7 +181,7 @@
Uinstr = decr_sp(_),
Cost = 0
;
- Uinstr = pragma_c(_, _, _, _, _),
+ Uinstr = pragma_c(_, _, _, _),
error("pragma_c found in vn_block_cost")
).
Index: compiler/vn_filter.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/vn_filter.m,v
retrieving revision 1.13
diff -u -u -r1.13 vn_filter.m
--- vn_filter.m 1997/12/05 15:48:06 1.13
+++ vn_filter.m 1998/01/06 08:15:56
@@ -136,7 +136,7 @@
error("inappropriate instruction in vn__filter").
vn_filter__user_instr(assign(_, Rval), yes(Rval)).
vn_filter__user_instr(call(_, _, _, _), no).
-vn_filter__user_instr(mkframe(_, _, _), no).
+vn_filter__user_instr(mkframe(_, _, _, _), no).
vn_filter__user_instr(modframe(_), no).
vn_filter__user_instr(label(_), no).
vn_filter__user_instr(goto(_), no).
@@ -154,7 +154,7 @@
vn_filter__user_instr(discard_tickets_to(Rval), yes(Rval)).
vn_filter__user_instr(incr_sp(_, _), no).
vn_filter__user_instr(decr_sp(_), no).
-vn_filter__user_instr(pragma_c(_, _, _, _, _), _):-
+vn_filter__user_instr(pragma_c(_, _, _, _), _):-
error("inappropriate instruction in vn__filter").
% vn_filter__replace_in_user_instr(Instr0, Old, New, Instr):
@@ -176,7 +176,7 @@
vn_filter__replace_in_rval(Rval0, Temp, Defn, Rval).
vn_filter__replace_in_user_instr(call(_, _, _, _), _, _, _) :-
error("non-user instruction in vn_filter__replace_in_user_instr").
-vn_filter__replace_in_user_instr(mkframe(_, _, _), _, _, _) :-
+vn_filter__replace_in_user_instr(mkframe(_, _, _, _), _, _, _) :-
error("non-user instruction in vn_filter__replace_in_user_instr").
vn_filter__replace_in_user_instr(modframe(_), _, _, _) :-
error("non-user instruction in vn_filter__replace_in_user_instr").
@@ -216,7 +216,7 @@
error("non-user instruction in vn_filter__replace_in_user_instr").
vn_filter__replace_in_user_instr(decr_sp(_), _, _, _) :-
error("non-user instruction in vn_filter__replace_in_user_instr").
-vn_filter__replace_in_user_instr(pragma_c(_, _, _, _, _), _, _, _):-
+vn_filter__replace_in_user_instr(pragma_c(_, _, _, _), _, _, _):-
error("inappropriate instruction in vn__filter").
% Check whether this instruction defines the value of any lval.
@@ -230,7 +230,7 @@
error("inappropriate instruction in vn__filter").
vn_filter__defining_instr(assign(Lval, _), yes(Lval)).
vn_filter__defining_instr(call(_, _, _, _), no).
-vn_filter__defining_instr(mkframe(_, _, _), no).
+vn_filter__defining_instr(mkframe(_, _, _, _), no).
vn_filter__defining_instr(modframe(_), no).
vn_filter__defining_instr(label(_), no).
vn_filter__defining_instr(goto(_), no).
@@ -248,7 +248,7 @@
vn_filter__defining_instr(discard_tickets_to(_), no).
vn_filter__defining_instr(incr_sp(_, _), no).
vn_filter__defining_instr(decr_sp(_), no).
-vn_filter__defining_instr(pragma_c(_, _, _, _, _), _):-
+vn_filter__defining_instr(pragma_c(_, _, _, _), _):-
error("inappropriate instruction in vn__filter").
% vn_filter__replace_in_defining_instr(Instr0, Old, New, Instr):
@@ -270,7 +270,7 @@
vn_filter__replace_in_lval(Lval0, Temp, Defn, Lval).
vn_filter__replace_in_defining_instr(call(_, _, _, _), _, _, _) :-
error("non-def instruction in vn_filter__replace_in_defining_instr").
-vn_filter__replace_in_defining_instr(mkframe(_, _, _), _, _, _) :-
+vn_filter__replace_in_defining_instr(mkframe(_, _, _, _), _, _, _) :-
error("non-def instruction in vn_filter__replace_in_defining_instr").
vn_filter__replace_in_defining_instr(modframe(_), _, _, _) :-
error("non-def instruction in vn_filter__replace_in_defining_instr").
@@ -308,7 +308,7 @@
error("non-def instruction in vn_filter__replace_in_defining_instr").
vn_filter__replace_in_defining_instr(decr_sp(_), _, _, _) :-
error("non-def instruction in vn_filter__replace_in_defining_instr").
-vn_filter__replace_in_defining_instr(pragma_c(_, _, _, _, _), _, _, _):-
+vn_filter__replace_in_defining_instr(pragma_c(_, _, _, _), _, _, _):-
error("inappropriate instruction in vn__filter").
% vn_filter__replace_in_lval(Lval0, Old, New, Lval):
Index: compiler/vn_flush.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/vn_flush.m,v
retrieving revision 1.44
diff -u -u -r1.44 vn_flush.m
--- vn_flush.m 1997/12/05 15:48:09 1.44
+++ vn_flush.m 1998/01/05 08:25:10
@@ -190,7 +190,7 @@
Templocs = Templocs0,
Instrs = [call(ProcAddr, RetAddr, LiveInfo, CodeModel) - ""]
;
- Vn_instr = vn_mkframe(Name, Size, Redoip),
+ Vn_instr = vn_mkframe(Name, Size, Pragma, Redoip),
vn_util__rval_to_vn(const(code_addr_const(Redoip)), AddrVn,
VnTables0, VnTables1),
vn_util__lval_to_vnlval(redoip(lval(maxfr)), SlotVnlval,
@@ -198,7 +198,7 @@
vn_table__set_current_value(SlotVnlval, AddrVn,
VnTables2, VnTables),
Templocs = Templocs0,
- Instrs = [mkframe(Name, Size, Redoip) - ""]
+ Instrs = [mkframe(Name, Size, Pragma, Redoip) - ""]
;
Vn_instr = vn_label(Label),
VnTables = VnTables0,
Index: compiler/vn_order.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/vn_order.m,v
retrieving revision 1.43
diff -u -u -r1.43 vn_order.m
--- vn_order.m 1997/12/05 15:48:11 1.43
+++ vn_order.m 1998/01/01 06:23:52
@@ -328,7 +328,7 @@
Predmap1 = Predmap0,
VnTables1 = VnTables0
;
- Vn_instr = vn_mkframe(_, _, _),
+ Vn_instr = vn_mkframe(_, _, _, _),
Succmap1 = Succmap0,
Predmap1 = Predmap0,
VnTables1 = VnTables0
Index: compiler/vn_type.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/vn_type.m,v
retrieving revision 1.36
diff -u -u -r1.36 vn_type.m
--- vn_type.m 1997/12/22 06:58:47 1.36
+++ vn_type.m 1998/01/05 08:29:11
@@ -70,7 +70,8 @@
:- type vn_instr ---> vn_livevals(lvalset)
; vn_call(code_addr, code_addr,
list(liveinfo), call_model)
- ; vn_mkframe(string, int, code_addr)
+ ; vn_mkframe(string, int, maybe(pragma_struct),
+ code_addr)
; vn_label(label)
; vn_goto(code_addr)
; vn_computed_goto(vn, list(label))
Index: compiler/vn_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/vn_util.m,v
retrieving revision 1.58
diff -u -u -r1.58 vn_util.m
--- vn_util.m 1997/12/05 15:48:14 1.58
+++ vn_util.m 1998/01/01 06:23:58
@@ -1219,7 +1219,7 @@
VnInstr = vn_call(_, _, _, _),
VnTables1 = VnTables0
;
- VnInstr = vn_mkframe(_, _, _),
+ VnInstr = vn_mkframe(_, _, _, _),
VnTables1 = VnTables0
;
VnInstr = vn_label(_),
Index: compiler/vn_verify.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/vn_verify.m,v
retrieving revision 1.14
diff -u -u -r1.14 vn_verify.m
--- vn_verify.m 1997/12/05 15:48:16 1.14
+++ vn_verify.m 1998/01/06 08:16:01
@@ -298,7 +298,7 @@
NoDeref = NoDeref0,
Tested = Tested0
;
- Instr = mkframe(_, _, _),
+ Instr = mkframe(_, _, _, _),
NoDeref = NoDeref0,
Tested = Tested0
;
@@ -373,7 +373,7 @@
NoDeref = NoDeref0,
Tested = Tested0
;
- Instr = pragma_c(_, _, _, _, _),
+ Instr = pragma_c(_, _, _, _),
error("found c_code in vn_verify__tags_instr")
).
cvs diff: Diffing compiler/notes
cvs diff: Diffing doc
cvs diff: Diffing extras
cvs diff: Diffing extras/cgi
cvs diff: Diffing extras/complex_numbers
cvs diff: Diffing extras/complex_numbers/samples
cvs diff: Diffing extras/complex_numbers/tests
cvs diff: Diffing extras/graphics
cvs diff: Diffing extras/graphics/Togl-1.2
cvs diff: Diffing extras/graphics/samples
cvs diff: Diffing extras/graphics/samples/calc
cvs diff: Diffing extras/graphics/samples/maze
cvs diff: Diffing extras/odbc
cvs diff: Diffing extras/trailed_update
cvs diff: Diffing extras/trailed_update/samples
cvs diff: Diffing library
cvs diff: Diffing lp_solve
cvs diff: Diffing lp_solve/lp_examples
cvs diff: Diffing profiler
cvs diff: Diffing runtime
Index: runtime/mercury_stacks.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_stacks.h,v
retrieving revision 1.2
diff -u -u -r1.2 mercury_stacks.h
--- mercury_stacks.h 1997/11/23 07:21:35 1.2
+++ mercury_stacks.h 1998/01/05 10:50:31
@@ -108,16 +108,15 @@
#define mkframe_save_prednm(prednm) /* nothing */
#endif
-
-#define mkframe(prednm, numslots, redoip) \
+#define mkframe(prednm, numslots, redoip) \
do { \
reg Word *prevfr; \
reg Word *succfr; \
\
- prevfr = MR_maxfr; \
- succfr = MR_curfr; \
+ prevfr = MR_maxfr; \
+ succfr = MR_curfr; \
MR_maxfr += (NONDET_FIXED_SIZE + numslots);\
- MR_curfr = MR_maxfr; \
+ MR_curfr = MR_maxfr; \
curredoip = redoip; \
curprevfr = prevfr; \
cursuccip = MR_succip; \
@@ -127,7 +126,24 @@
nondstack_overflow_check(); \
} while (0)
-
+#define mkpragmaframe(prednm, numslots, structname, redoip) \
+ do { \
+ reg Word *prevfr; \
+ reg Word *succfr; \
+ \
+ prevfr = MR_maxfr; \
+ succfr = MR_curfr; \
+ MR_maxfr += (NONDET_FIXED_SIZE + numslots \
+ + sizeof(struct structname)); \
+ MR_curfr = MR_maxfr; \
+ curredoip = redoip; \
+ curprevfr = prevfr; \
+ cursuccip = MR_succip; \
+ cursuccfr = succfr; \
+ mkframe_save_prednm(prednm); \
+ debugmkframe(); \
+ nondstack_overflow_check(); \
+ } while (0)
#define modframe(redoip) \
do { \
@@ -135,7 +151,6 @@
debugmodframe(); \
} while (0)
-
#define succeed() do { \
reg Word *childfr; \
\
@@ -156,7 +171,6 @@
GOTO(bt_succip(childfr)); \
} while (0)
-
#define fail() do { \
debugfail(); \
MR_maxfr = curprevfr; \
@@ -164,7 +178,6 @@
nondstack_underflow_check(); \
GOTO(curredoip); \
} while (0)
-
#define redo() do { \
debugredo(); \
cvs diff: Diffing runtime/machdeps
cvs diff: Diffing samples
cvs diff: Diffing samples/c_interface
cvs diff: Diffing samples/c_interface/c_calls_mercury
cvs diff: Diffing samples/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/c_interface/mercury_calls_c
cvs diff: Diffing samples/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/diff
cvs diff: Diffing scripts
cvs diff: Diffing tests
cvs diff: Diffing tests/benchmarks
cvs diff: Diffing tests/general
cvs diff: Diffing tests/hard_coded
cvs diff: Diffing tests/invalid
cvs diff: Diffing tests/misc_tests
cvs diff: Diffing tests/term
cvs diff: Diffing tests/valid
cvs diff: Diffing tests/warnings
cvs diff: Diffing tools
cvs diff: Diffing trial
cvs diff: Diffing util
More information about the developers
mailing list