[m-rev.] for review: --use-atomic-cells
Zoltan Somogyi
zs at csse.unimelb.edu.au
Fri Aug 18 17:11:03 AEST 2006
I would like to commit this on monday. If there are no reviews by about noon,
I will address any comments after commit.
Zoltan.
One of Hans Boehm's papers says that heap cells allocated by GC_MALLOC_ATOMIC
are grouped together into pages, and these pages aren't scanned during the
sweep phase of the garbage collector. I therefore modified the compiler
to use GC_MALLOC_ATOMIC instead of GC_MALLOC whereever possible, i.e
when the cell being allocated is guaranteed not to have any pointer to
GCable memory inside it.
My first benchmarking run showed a speedup of 4.5% in asm_fast.gc:
EXTRA_MCFLAGS = --use-atomic-cells
mercury_compile.01 average of 6 with ignore=1 18.30
EXTRA_MCFLAGS = --no-use-atomic-cells
mercury_compile.02 average of 6 with ignore=1 19.17
However, later benchmarks, after the upgrade to version 7.0 of boehm_gc,
show a less favourable and more mixed picture, with e.g. a 4% speedup
in hlc.gc at -O3, a 3% slowdown in asm_fast.gc at -O4, and little effect
otherwise:
EXTRA_MCFLAGS = -O1 --use-atomic-cells
GRADE = asm_fast.gc
mercury_compile.01 average of 6 with ignore=1 23.30
EXTRA_MCFLAGS = -O1 --no-use-atomic-cells
GRADE = asm_fast.gc
mercury_compile.02 average of 6 with ignore=1 23.28
EXTRA_MCFLAGS = -O2 --use-atomic-cells
GRADE = asm_fast.gc
mercury_compile.03 average of 6 with ignore=1 18.51
EXTRA_MCFLAGS = -O2 --no-use-atomic-cells
GRADE = asm_fast.gc
mercury_compile.04 average of 6 with ignore=1 18.66
EXTRA_MCFLAGS = -O3 --use-atomic-cells
GRADE = asm_fast.gc
mercury_compile.05 average of 6 with ignore=1 18.44
EXTRA_MCFLAGS = -O3 --no-use-atomic-cells
GRADE = asm_fast.gc
mercury_compile.06 average of 6 with ignore=1 18.48
EXTRA_MCFLAGS = -O4 --use-atomic-cells
GRADE = asm_fast.gc
mercury_compile.07 average of 6 with ignore=1 18.28
EXTRA_MCFLAGS = -O4 --no-use-atomic-cells
GRADE = asm_fast.gc
mercury_compile.08 average of 6 with ignore=1 17.70
EXTRA_MCFLAGS = -O1 --use-atomic-cells
GRADE = hlc.gc
mercury_compile.09 average of 6 with ignore=1 24.78
EXTRA_MCFLAGS = -O1 --no-use-atomic-cells
GRADE = hlc.gc
mercury_compile.10 average of 6 with ignore=1 24.69
EXTRA_MCFLAGS = -O2 --use-atomic-cells
GRADE = hlc.gc
mercury_compile.11 average of 6 with ignore=1 19.36
EXTRA_MCFLAGS = -O2 --no-use-atomic-cells
GRADE = hlc.gc
mercury_compile.12 average of 6 with ignore=1 19.26
EXTRA_MCFLAGS = -O3 --use-atomic-cells
GRADE = hlc.gc
mercury_compile.13 average of 6 with ignore=1 18.64
EXTRA_MCFLAGS = -O3 --no-use-atomic-cells
GRADE = hlc.gc
mercury_compile.14 average of 6 with ignore=1 19.38
EXTRA_MCFLAGS = -O4 --use-atomic-cells
GRADE = hlc.gc
mercury_compile.15 average of 6 with ignore=1 19.39
EXTRA_MCFLAGS = -O4 --no-use-atomic-cells
GRADE = hlc.gc
mercury_compile.16 average of 6 with ignore=1 19.41
runtime/mercury_heap.h:
Define atomic equivalents of the few heap allocation macros
that didn't already have one. These macros are used by the LLDS
backend.
runtime/mercury.h:
Define an atomic equivalent of the MR_new_object macro.
These macros are used by the MLDS backend.
Use MR_new_object_atomic instead of MR_new_object to box floats.
compiler/hlds_data.m:
compiler/llds.m:
compiler/mlds.m:
Modify the representations of the heap allocations constructs
to include a flag that says whether we should use the atomic variants
of the heap allocation macros.
compiler/llds_out.m:
compiler/mlds_to_c.m:
Respect this extract flag when emitting C code.
In mlds_to_c.m, also add some white space that makes the code easier
for humans to read.
compiler/type_util.m:
Add a mechanism for finding out whether we can put a value of a given
type into an atomic cell.
Put the definitions of functions and predicates in this module
in the same order as their declarations.
Turn some predicates into functions. Change the argument order of
some predicates to conform to our usual conventions.
compiler/unify_gen.m:
compiler/ml_unify_gen.m:
Use the new mechanism in type_util.m to generate code that creates
atomic heap cells if this is possible and is requested.
compiler/code_info.m:
compiler/var_locn.m:
Act on the information provided by unify_gen.m.
compiler/options.m:
doc/user_guide.texi:
Add an option to control whether the compiler should try to use
atomic cells.
compiler/dupelim.m:
compiler/dupproc.m:
compiler/exprn_aux.m:
compiler/higher_order.m:
compiler/jumpopt.m:
compiler/livemap.m:
compiler/middle_rec.m:
compiler/ml_code_util.m:
compiler/ml_elim_nested.m:
compiler/ml_optimize.m:
compiler/ml_util.m:
compiler/mlds_to_gcc.m:
compiler/mlds_to_il.m:
compiler/mlds_to_java.m:
compiler/modecheck_unify.m:
compiler/opt_debug.m:
compiler/opt_util.m:
compiler/par_conj_gen.m:
compiler/polymorphism.m:
compiler/reassign.m:
compiler/size_prof.m:
compiler/structure_sharing.domain.m:
compiler/use_local_vars.m:
Minor diffs to conform to the changes above.
compiler/structure_reuse.direct.choose_reuse.m:
Add an XXX comment about the interaction of the new capability
with structure reuse.
cvs diff: Diffing .
cvs diff: Diffing analysis
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/doc
cvs diff: Diffing boehm_gc/include
cvs diff: Diffing boehm_gc/include/private
cvs diff: Diffing boehm_gc/libatomic_ops-1.2
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/doc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/gcc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/hpc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/ibmc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/icc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/msftc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/sunc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/tests
cvs diff: Diffing boehm_gc/tests
cvs diff: Diffing boehm_gc/windows-untested
cvs diff: Diffing boehm_gc/windows-untested/vc60
cvs diff: Diffing boehm_gc/windows-untested/vc70
cvs diff: Diffing boehm_gc/windows-untested/vc71
cvs diff: Diffing browser
cvs diff: Diffing bytecode
cvs diff: Diffing compiler
Index: compiler/code_info.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/code_info.m,v
retrieving revision 1.326
diff -u -b -r1.326 code_info.m
--- compiler/code_info.m 1 Aug 2006 00:45:53 -0000 1.326
+++ compiler/code_info.m 7 Aug 2006 14:56:46 -0000
@@ -3097,11 +3097,12 @@
code_info::in, code_info::out) is det.
% assign_cell_to_var(Var, ReserveWordAtStart, Ptag, Vector,
- % MaybeSize, TypeMsg, Where, Code, !CI).
+ % MaybeSize, TypeMsg, MayUseAtomic, Where, Code, !CI).
%
:- pred assign_cell_to_var(prog_var::in, bool::in, tag::in,
list(maybe(rval))::in, maybe(term_size_value)::in, string::in,
- code_tree::out, code_info::in, code_info::out) is det.
+ may_use_atomic_alloc::in, code_tree::out,
+ code_info::in, code_info::out) is det.
:- pred place_var(prog_var::in, lval::in, code_tree::out,
code_info::in, code_info::out) is det.
@@ -3239,13 +3240,13 @@
set_var_locn_info(VarLocnInfo, !CI).
assign_cell_to_var(Var, ReserveWordAtStart, Ptag, Vector, MaybeSize,
- TypeMsg, Code, !CI) :-
+ TypeMsg, MayUseAtomic, Code, !CI) :-
get_var_locn_info(!.CI, VarLocnInfo0),
get_static_cell_info(!.CI, StaticCellInfo0),
get_module_info(!.CI, ModuleInfo),
var_locn.assign_cell_to_var(ModuleInfo, Var, ReserveWordAtStart, Ptag,
- Vector, MaybeSize, TypeMsg, Code, StaticCellInfo0, StaticCellInfo,
- VarLocnInfo0, VarLocnInfo),
+ Vector, MaybeSize, TypeMsg, MayUseAtomic, Code,
+ StaticCellInfo0, StaticCellInfo, VarLocnInfo0, VarLocnInfo),
set_static_cell_info(StaticCellInfo, !CI),
set_var_locn_info(VarLocnInfo, !CI).
Index: compiler/dupelim.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/dupelim.m,v
retrieving revision 1.82
diff -u -b -r1.82 dupelim.m
--- compiler/dupelim.m 31 Jul 2006 08:31:35 -0000 1.82
+++ compiler/dupelim.m 7 Aug 2006 14:52:54 -0000
@@ -366,10 +366,12 @@
standardize_lval(Lval1, Lval),
Instr = restore_maxfr(Lval)
;
- Instr1 = incr_hp(Lval1, MaybeTag, MaybeOffset, Rval1, Msg),
+ Instr1 = incr_hp(Lval1, MaybeTag, MaybeOffset, Rval1, Msg,
+ MayUseAtomic),
standardize_lval(Lval1, Lval),
standardize_rval(Rval1, Rval),
- Instr = incr_hp(Lval, MaybeTag, MaybeOffset, Rval, Msg)
+ Instr = incr_hp(Lval, MaybeTag, MaybeOffset, Rval, Msg,
+ MayUseAtomic)
;
Instr1 = mark_hp(Lval1),
standardize_lval(Lval1, Lval),
@@ -629,17 +631,20 @@
MaybeInstr = no
)
;
- Instr1 = incr_hp(Lval1, MaybeTag1, MaybeOffset1, Rval1, Msg1),
+ Instr1 = incr_hp(Lval1, MaybeTag1, MaybeOffset1, Rval1, Msg1,
+ MayUseAtomic1),
(
- Instr2 = incr_hp(Lval2, MaybeTag2, MaybeOffset2, Rval2, Msg2),
+ Instr2 = incr_hp(Lval2, MaybeTag2, MaybeOffset2, Rval2, Msg2,
+ MayUseAtomic2),
most_specific_lval(Lval1, Lval2, Lval),
most_specific_rval(Rval1, Rval2, Rval),
MaybeTag1 = MaybeTag2,
MaybeOffset1 = MaybeOffset2,
- Msg1 = Msg2
+ Msg1 = Msg2,
+ MayUseAtomic1 = MayUseAtomic2
->
MaybeInstr = yes(incr_hp(Lval, MaybeTag1, MaybeOffset1, Rval,
- Msg1))
+ Msg1, MayUseAtomic1))
;
MaybeInstr = no
)
Index: compiler/dupproc.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/dupproc.m,v
retrieving revision 1.10
diff -u -b -r1.10 dupproc.m
--- compiler/dupproc.m 28 Jul 2006 05:08:07 -0000 1.10
+++ compiler/dupproc.m 7 Aug 2006 13:04:53 -0000
@@ -229,7 +229,7 @@
standardize_code_addr(Target, StdTarget, DupProcMap),
StdInstr = if_val(StdRval, StdTarget)
;
- Instr = incr_hp(_, _, _, _, _),
+ Instr = incr_hp(_, _, _, _, _, _),
StdInstr = Instr
;
Instr = mark_hp(_),
Index: compiler/exprn_aux.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/exprn_aux.m,v
retrieving revision 1.73
diff -u -b -r1.73 exprn_aux.m
--- compiler/exprn_aux.m 31 Jul 2006 08:31:36 -0000 1.73
+++ compiler/exprn_aux.m 7 Aug 2006 13:05:24 -0000
@@ -383,10 +383,10 @@
substitute_lval_in_lval_count(OldLval, NewLval, Lval0, Lval, !N),
Uinstr = restore_maxfr(Lval)
;
- Uinstr0 = incr_hp(Lval0, MaybeTag, MO, Rval0, TypeCtor),
+ Uinstr0 = incr_hp(Lval0, MaybeTag, MO, Rval0, TypeCtor, MayUseAtomic),
substitute_lval_in_lval_count(OldLval, NewLval, Lval0, Lval, !N),
substitute_lval_in_rval_count(OldLval, NewLval, Rval0, Rval, !N),
- Uinstr = incr_hp(Lval, MaybeTag, MO, Rval, TypeCtor)
+ Uinstr = incr_hp(Lval, MaybeTag, MO, Rval, TypeCtor, MayUseAtomic)
;
Uinstr0 = mark_hp(Lval0),
substitute_lval_in_lval_count(OldLval, NewLval, Lval0, Lval, !N),
Index: compiler/higher_order.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/higher_order.m,v
retrieving revision 1.157
diff -u -b -r1.157 higher_order.m
--- compiler/higher_order.m 31 Jul 2006 08:31:39 -0000 1.157
+++ compiler/higher_order.m 10 Aug 2006 11:23:03 -0000
@@ -2040,7 +2040,7 @@
% cases: here it is a call to a builtin predicate, perhaps preceded
% by casts; there it is a call to a compiler-generated predicate.
- type_is_atomic(SpecialPredType, ModuleInfo)
+ type_is_atomic(ModuleInfo, SpecialPredType)
->
specialize_unify_or_compare_pred_for_atomic(SpecialPredType,
MaybeResult, Arg1, Arg2, MaybeContext, OrigGoalInfo, Goal,
@@ -2064,7 +2064,7 @@
% This could be done for non-atomic types, but it would be a bit
% more complicated because the type-info for the wrapped type
% would need to be extracted first.
- type_is_atomic(WrappedType, ModuleInfo)
+ type_is_atomic(ModuleInfo, WrappedType)
->
specialize_unify_or_compare_pred_for_no_tag(WrappedType,
Constructor, MaybeResult, Arg1, Arg2, MaybeContext,
Index: compiler/hlds_data.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_data.m,v
retrieving revision 1.107
diff -u -b -r1.107 hlds_data.m
--- compiler/hlds_data.m 8 Jun 2006 08:19:13 -0000 1.107
+++ compiler/hlds_data.m 10 Aug 2006 08:06:21 -0000
@@ -351,6 +351,19 @@
%
:- func get_secondary_tag(cons_tag) = maybe(int).
+ % The atomic variants of the Boehm gc allocator calls (e.g.
+ % GC_malloc_atomic instead of GC_malloc) may yield slightly faster code
+ % since atomic blocks are not scanned for included pointers. However,
+ % this makes them safe to use *only* if the block allocated this way
+ % can never contain any pointer the Boehm collector would be interested
+ % in tracing. In particular, it even if the cell initially contains no
+ % pointers, we must still use may_not_use_atomic_alloc for it if the cell
+ % could possibly be reused later by compile-time garbage collection.
+ %
+:- type may_use_atomic_alloc
+ ---> may_use_atomic_alloc
+ ; may_not_use_atomic_alloc.
+
:- implementation.
% In some of the cases where we return `no' here,
Index: compiler/jumpopt.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/jumpopt.m,v
retrieving revision 1.90
diff -u -b -r1.90 jumpopt.m
--- compiler/jumpopt.m 28 Jul 2006 05:08:08 -0000 1.90
+++ compiler/jumpopt.m 7 Aug 2006 13:07:53 -0000
@@ -799,7 +799,7 @@
; Uinstr0 = mark_ticket_stack(_)
; Uinstr0 = mark_hp(_)
; Uinstr0 = free_heap(_)
- ; Uinstr0 = incr_hp(_, _, _, _, _)
+ ; Uinstr0 = incr_hp(_, _, _, _, _, _)
; Uinstr0 = restore_hp(_)
; Uinstr0 = init_sync_term(_, _)
; Uinstr0 = join_and_terminate(_)
Index: compiler/livemap.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/livemap.m,v
retrieving revision 1.78
diff -u -b -r1.78 livemap.m
--- compiler/livemap.m 31 Jul 2006 08:31:45 -0000 1.78
+++ compiler/livemap.m 7 Aug 2006 13:08:20 -0000
@@ -229,7 +229,7 @@
Uinstr0 = restore_maxfr(Lval),
livemap.make_live_in_rval(lval(Lval), !Livevals)
;
- Uinstr0 = incr_hp(Lval, _, _, Rval, _),
+ Uinstr0 = incr_hp(Lval, _, _, Rval, _, _),
% Make dead the variable assigned, but make any variables
% needed to access it live. Make the variables in the size
Index: compiler/llds.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/llds.m,v
retrieving revision 1.335
diff -u -b -r1.335 llds.m
--- compiler/llds.m 28 Jul 2006 05:08:09 -0000 1.335
+++ compiler/llds.m 10 Aug 2006 08:11:48 -0000
@@ -21,6 +21,7 @@
:- import_module backend_libs.builtin_ops.
:- import_module backend_libs.rtti.
:- import_module hlds.code_model.
+:- import_module hlds.hlds_data.
:- import_module hlds.hlds_goal.
:- import_module hlds.hlds_llds.
:- import_module hlds.hlds_pred.
@@ -313,12 +314,15 @@
% Restore maxfr from the saved copy in the given lval. Assumes the
% lval was saved with save_maxfr.
- ; incr_hp(lval, maybe(tag), maybe(int), rval, string)
+ ; incr_hp(lval, maybe(tag), maybe(int), rval, string,
+ may_use_atomic_alloc)
% Get a memory block of a size given by an rval and put its address
% in the given lval, possibly after incrementing it by N words
% (if the maybe(int) is bound to `yes(N)') and/or after tagging it
% with a given tag. The string gives the name of the type
% constructor of the memory cell for use in memory profiling.
+ % The last argument says whether we can use the atomic variants
+ % of the Boehm gc allocator calls.
; mark_hp(lval)
% Tell the heap sub-system to store a marker (for later use in
Index: compiler/llds_out.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/llds_out.m,v
retrieving revision 1.286
diff -u -b -r1.286 llds_out.m
--- compiler/llds_out.m 31 Jul 2006 08:31:45 -0000 1.286
+++ compiler/llds_out.m 10 Aug 2006 11:20:49 -0000
@@ -187,6 +187,7 @@
:- import_module backend_libs.proc_label.
:- import_module backend_libs.rtti.
:- import_module check_hlds.type_util.
+:- import_module hlds.hlds_data.
:- import_module hlds.hlds_pred.
:- import_module hlds.passes_aux.
:- import_module libs.compiler_util.
@@ -1935,7 +1936,7 @@
output_lval_decls(Lval, !DeclSet, !IO).
output_instr_decls(_, restore_maxfr(Lval), !DeclSet, !IO) :-
output_lval_decls(Lval, !DeclSet, !IO).
-output_instr_decls(_, incr_hp(Lval, _Tag, _, Rval, _), !DeclSet, !IO) :-
+output_instr_decls(_, incr_hp(Lval, _Tag, _, Rval, _, _), !DeclSet, !IO) :-
output_lval_decls(Lval, !DeclSet, !IO),
output_rval_decls(Rval, !DeclSet, !IO).
output_instr_decls(_, mark_hp(Lval), !DeclSet, !IO) :-
@@ -2365,18 +2366,30 @@
output_lval(Lval, !IO),
io.write_string(");\n", !IO).
-output_instruction(incr_hp(Lval, MaybeTag, MaybeOffset, Rval, TypeMsg),
- ProfInfo, !IO) :-
+output_instruction(incr_hp(Lval, MaybeTag, MaybeOffset, Rval, TypeMsg,
+ MayUseAtomicAlloc), ProfInfo, !IO) :-
globals.io_lookup_bool_option(profile_memory, ProfMem, !IO),
(
ProfMem = yes,
(
MaybeTag = no,
- io.write_string("\tMR_offset_incr_hp_msg(", !IO),
+ (
+ MayUseAtomicAlloc = may_not_use_atomic_alloc,
+ io.write_string("\tMR_offset_incr_hp_msg(", !IO)
+ ;
+ MayUseAtomicAlloc = may_use_atomic_alloc,
+ io.write_string("\tMR_offset_incr_hp_atomic_msg(", !IO)
+ ),
output_lval_as_word(Lval, !IO)
;
MaybeTag = yes(Tag),
- io.write_string("\tMR_tag_offset_incr_hp_msg(", !IO),
+ (
+ MayUseAtomicAlloc = may_not_use_atomic_alloc,
+ io.write_string("\tMR_tag_offset_incr_hp_msg(", !IO)
+ ;
+ MayUseAtomicAlloc = may_use_atomic_alloc,
+ io.write_string("\tMR_tag_offset_incr_hp_atomic_msg(", !IO)
+ ),
output_lval_as_word(Lval, !IO),
io.write_string(", ", !IO),
output_tag(Tag, !IO)
@@ -2403,23 +2416,47 @@
MaybeTag = no,
(
MaybeOffset = yes(_),
+ (
+ MayUseAtomicAlloc = may_not_use_atomic_alloc,
io.write_string("\tMR_offset_incr_hp(", !IO)
;
+ MayUseAtomicAlloc = may_use_atomic_alloc,
+ io.write_string("\tMR_offset_incr_hp_atomic(", !IO)
+ )
+ ;
MaybeOffset = no,
+ (
+ MayUseAtomicAlloc = may_not_use_atomic_alloc,
io.write_string("\tMR_alloc_heap(", !IO)
+ ;
+ MayUseAtomicAlloc = may_use_atomic_alloc,
+ io.write_string("\tMR_alloc_heap_atomic(", !IO)
+ )
),
output_lval_as_word(Lval, !IO)
;
MaybeTag = yes(Tag),
(
MaybeOffset = yes(_),
- io.write_string("\tMR_tag_offset_incr_hp(", !IO),
+ (
+ MayUseAtomicAlloc = may_not_use_atomic_alloc,
+ io.write_string("\tMR_tag_offset_incr_hp(", !IO)
+ ;
+ MayUseAtomicAlloc = may_use_atomic_alloc,
+ io.write_string("\tMR_tag_offset_incr_hp_atomic(", !IO)
+ ),
output_lval_as_word(Lval, !IO),
io.write_string(", ", !IO),
output_tag(Tag, !IO)
;
MaybeOffset = no,
- io.write_string("\tMR_tag_alloc_heap(", !IO),
+ (
+ MayUseAtomicAlloc = may_not_use_atomic_alloc,
+ io.write_string("\tMR_tag_alloc_heap(", !IO)
+ ;
+ MayUseAtomicAlloc = may_use_atomic_alloc,
+ io.write_string("\tMR_tag_alloc_heap_atomic(", !IO)
+ ),
output_lval_as_word(Lval, !IO),
io.write_string(", ", !IO),
io.write_int(Tag, !IO)
Index: compiler/middle_rec.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/middle_rec.m,v
retrieving revision 1.120
diff -u -b -r1.120 middle_rec.m
--- compiler/middle_rec.m 28 Jul 2006 05:08:09 -0000 1.120
+++ compiler/middle_rec.m 7 Aug 2006 14:19:24 -0000
@@ -509,7 +509,7 @@
find_used_registers_lval(Lval, !Used).
find_used_registers_instr(restore_maxfr(Lval), !Used) :-
find_used_registers_lval(Lval, !Used).
-find_used_registers_instr(incr_hp(Lval, _, _, Rval, _), !Used) :-
+find_used_registers_instr(incr_hp(Lval, _, _, Rval, _, _), !Used) :-
find_used_registers_lval(Lval, !Used),
find_used_registers_rval(Rval, !Used).
find_used_registers_instr(mark_hp(Lval), !Used) :-
Index: compiler/ml_code_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_code_util.m,v
retrieving revision 1.113
diff -u -b -r1.113 ml_code_util.m
--- compiler/ml_code_util.m 31 Jul 2006 08:31:49 -0000 1.113
+++ compiler/ml_code_util.m 11 Aug 2006 03:29:47 -0000
@@ -2283,7 +2283,8 @@
fixup_newobj_in_atomic_statement(AtomicStatement0, Stmt, !Fixup) :-
(
AtomicStatement0 = new_object(Lval, MaybeTag, _HasSecTag, PointerType,
- _MaybeSizeInWordsRval, _MaybeCtorName, ArgRvals, _ArgTypes)
+ _MaybeSizeInWordsRval, _MaybeCtorName, ArgRvals, _ArgTypes,
+ _MayUseAtomic)
->
% Generate the declaration of the new local variable.
%
Index: compiler/ml_elim_nested.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_elim_nested.m,v
retrieving revision 1.83
diff -u -b -r1.83 ml_elim_nested.m
--- compiler/ml_elim_nested.m 31 Jul 2006 08:31:50 -0000 1.83
+++ compiler/ml_elim_nested.m 11 Aug 2006 03:40:04 -0000
@@ -438,6 +438,7 @@
:- implementation.
:- import_module check_hlds.type_util.
+:- import_module hlds.hlds_data.
:- import_module libs.compiler_util.
:- import_module libs.globals.
:- import_module libs.options.
@@ -785,7 +786,7 @@
ml_create_env(Action, EnvClassName, EnvTypeName, LocalVars, Context,
ModuleName, FuncName, Globals, EnvTypeDefn, EnvDecls, InitEnv,
GCTraceFuncDefns) :-
- % generate the following type:
+ % Generate the following type:
%
% struct <EnvClassName> {
% #ifdef ACCURATE_GC
@@ -866,9 +867,12 @@
(
OnHeap = yes,
EnvVarAddr = lval(var(EnvVar, EnvTypeName)),
+ % OnHeap should be "yes" only on for the IL backend, for which
+ % the value of MayUseAtomic is immaterial.
+ MayUseAtomic = may_not_use_atomic_alloc,
NewObj = [statement(
atomic(new_object(var(EnvVar, EnvTypeName),
- no, no, EnvTypeName, no, no, [], [])),
+ no, no, EnvTypeName, no, no, [], [], MayUseAtomic)),
Context)]
;
OnHeap = no,
@@ -882,9 +886,8 @@
:- pred ml_chain_stack_frames(mlds_defns::in, statements::in,
mlds_type::in, mlds_context::in, mlds_entity_name::in,
- mlds_module_name::in, globals::in, mlds_defns::out,
- mlds_initializer::out, statements::out, mlds_defns::out)
- is det.
+ mlds_module_name::in, globals::in, mlds_defns::out, mlds_initializer::out,
+ statements::out, mlds_defns::out) is det.
ml_chain_stack_frames(Fields0, GCTraceStatements, EnvTypeName, Context,
FuncName, ModuleName, Globals, Fields,
@@ -1756,9 +1759,9 @@
fixup_atomic_stmt(delete_object(Lval0), delete_object(Lval), !Info) :-
fixup_lval(Lval0, Lval, !Info).
fixup_atomic_stmt(new_object(Target0, MaybeTag, HasSecTag, Type, MaybeSize,
- MaybeCtorName, Args0, ArgTypes),
+ MaybeCtorName, Args0, ArgTypes, MayUseAtomic),
new_object(Target, MaybeTag, HasSecTag, Type, MaybeSize,
- MaybeCtorName, Args, ArgTypes), !Info) :-
+ MaybeCtorName, Args, ArgTypes, MayUseAtomic), !Info) :-
fixup_lval(Target0, Target, !Info),
fixup_rvals(Args0, Args, !Info).
fixup_atomic_stmt(gc_check, gc_check, !Info).
Index: compiler/ml_optimize.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_optimize.m,v
retrieving revision 1.42
diff -u -b -r1.42 ml_optimize.m
--- compiler/ml_optimize.m 31 Jul 2006 08:31:50 -0000 1.42
+++ compiler/ml_optimize.m 11 Aug 2006 03:35:15 -0000
@@ -1163,9 +1163,9 @@
!VarElimInfo) :-
eliminate_var_in_lval(Lval0, Lval, !VarElimInfo).
eliminate_var_in_atomic_stmt(new_object(Target0, MaybeTag, HasSecTag, Type,
- MaybeSize, MaybeCtorName, Args0, ArgTypes),
+ MaybeSize, MaybeCtorName, Args0, ArgTypes, MayUseAtomic),
new_object(Target, MaybeTag, HasSecTag, Type,
- MaybeSize, MaybeCtorName, Args, ArgTypes),
+ MaybeSize, MaybeCtorName, Args, ArgTypes, MayUseAtomic),
!VarElimInfo) :-
eliminate_var_in_lval(Target0, Target, !VarElimInfo),
eliminate_var_in_rvals(Args0, Args, !VarElimInfo).
Index: compiler/ml_unify_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_unify_gen.m,v
retrieving revision 1.102
diff -u -b -r1.102 ml_unify_gen.m
--- compiler/ml_unify_gen.m 31 Jul 2006 08:31:51 -0000 1.102
+++ compiler/ml_unify_gen.m 12 Aug 2006 03:38:34 -0000
@@ -627,9 +627,18 @@
get_maybe_cons_id_arg_types(MaybeConsId, ArgTypes, Type,
ModuleInfo, ConsArgTypes),
FirstOffset = length(ExtraRvals),
+ module_info_get_globals(ModuleInfo, Globals),
+ globals.lookup_bool_option(Globals, use_atomic_cells, UseAtomicCells),
+ (
+ UseAtomicCells = yes,
+ MayUseAtomic0 = may_use_atomic_alloc
+ ;
+ UseAtomicCells = no,
+ MayUseAtomic0 = may_not_use_atomic_alloc
+ ),
ml_gen_cons_args(ArgVars, ArgLvals, ArgTypes, ConsArgTypes, ArgModes,
FirstOffset, 1, TakeAddr, ModuleInfo, ArgRvals0, MLDS_ArgTypes0,
- TakeAddrInfos, !Info),
+ TakeAddrInfos, MayUseAtomic0, MayUseAtomic, !Info),
% Insert the extra rvals at the start.
ArgRvals = ExtraRvals ++ ArgRvals0,
@@ -643,7 +652,8 @@
% for this term from the heap. The `new_object' statement will also
% initialize the fields of this term with the specified arguments.
MakeNewObject = new_object(VarLval, MaybeTag, HasSecTag, MLDS_Type,
- yes(SizeInWordsRval), MaybeCtorName, ArgRvals, MLDS_ArgTypes),
+ yes(SizeInWordsRval), MaybeCtorName, ArgRvals, MLDS_ArgTypes,
+ MayUseAtomic),
Stmt = atomic(MakeNewObject),
Statement = statement(Stmt, mlds_make_context(Context)),
@@ -1179,19 +1189,18 @@
list(mer_type)::in, list(mer_type)::in, list(uni_mode)::in,
int::in, int::in, list(int)::in, module_info::in, list(mlds_rval)::out,
list(mlds_type)::out, list(take_addr_info)::out,
+ may_use_atomic_alloc::in, may_use_atomic_alloc::out,
ml_gen_info::in, ml_gen_info::out) is det.
ml_gen_cons_args(Vars, Lvals, ArgTypes, ConsArgTypes, UniModes, FirstOffset,
- FirstArgNum, TakeAddr, ModuleInfo, Rvals, MLDS_Types, TakeAddrInfos,
- !Info) :-
+ FirstArgNum, TakeAddr, ModuleInfo, !:Rvals, !:MLDS_Types,
+ !:TakeAddrInfos, !MayUseAtomic, !Info) :-
(
ml_gen_cons_args_2(Vars, Lvals, ArgTypes, ConsArgTypes, UniModes,
- FirstOffset, FirstArgNum, TakeAddr, ModuleInfo, RvalsPrime,
- MLDS_TypesPrime, TakeAddrInfosPrime, !Info)
+ FirstOffset, FirstArgNum, TakeAddr, ModuleInfo, !:Rvals,
+ !:MLDS_Types, !:TakeAddrInfos, !MayUseAtomic, !Info)
->
- Rvals = RvalsPrime,
- MLDS_Types = MLDS_TypesPrime,
- TakeAddrInfos = TakeAddrInfosPrime
+ true
;
unexpected(this_file, "ml_gen_cons_args: length mismatch")
).
@@ -1200,14 +1209,25 @@
list(mer_type)::in, list(mer_type)::in, list(uni_mode)::in,
int::in, int::in, list(int)::in, module_info::in, list(mlds_rval)::out,
list(mlds_type)::out, list(take_addr_info)::out,
+ may_use_atomic_alloc::in, may_use_atomic_alloc::out,
ml_gen_info::in, ml_gen_info::out) is semidet.
ml_gen_cons_args_2([], [], [], [], [], _FirstOffset, _FirstArgNum, _TakeAddr,
- _ModuleInfo, [], [], [], !Info).
+ _ModuleInfo, [], [], [], !MayUseAtomic, !Info).
ml_gen_cons_args_2([Var | Vars], [Lval | Lvals], [ArgType | ArgTypes],
[ConsArgType | ConsArgTypes], [UniMode | UniModes], FirstOffset,
CurArgNum, !.TakeAddr, ModuleInfo, [Rval | Rvals],
- [MLDS_Type | MLDS_Types], TakeAddrInfos, !Info) :-
+ [MLDS_Type | MLDS_Types], TakeAddrInfos, !MayUseAtomic, !Info) :-
+ % It is important to use ArgType instead of ConsArgType here. ConsArgType
+ % is the declared type of the argument of the cons_id, while ArgType is
+ % the actual type of the variable being assigned to the given slot.
+ % ConsArgType may be a type such as pred_id, which is a user-defined type
+ % that may not appear in atomic cells, while ArgType may be a type such
+ % as int, which may appear in atomic cells. This is because the actual type
+ % may see behind abstraction barriers, and may thus see that e.g. pred_id
+ % is actually the same as integer.
+ update_type_may_use_atomic_alloc(ModuleInfo, ArgType, !MayUseAtomic),
+
% Figure out the type of the field. Note that for the MLDS->C and
% MLDS->asm back-ends, we need to box floating point fields.
module_info_get_globals(ModuleInfo, Globals),
@@ -1221,7 +1241,7 @@
Rval = const(null(MLDS_Type)),
ml_gen_cons_args_2(Vars, Lvals, ArgTypes, ConsArgTypes, UniModes,
FirstOffset, CurArgNum + 1, !.TakeAddr, ModuleInfo, Rvals,
- MLDS_Types, TakeAddrInfosTail, !Info),
+ MLDS_Types, TakeAddrInfosTail, !MayUseAtomic, !Info),
% Whereas CurArgNum starts numbering the arguments from 1, offsets
% into fields start from zero. However, if FirstOffset > 0, then the
% cell contains FirstOffset other things (e.g. a secondary tag) before
@@ -1243,7 +1263,7 @@
),
ml_gen_cons_args_2(Vars, Lvals, ArgTypes, ConsArgTypes, UniModes,
FirstOffset, CurArgNum + 1, !.TakeAddr, ModuleInfo, Rvals,
- MLDS_Types, TakeAddrInfos, !Info)
+ MLDS_Types, TakeAddrInfos, !MayUseAtomic, !Info)
).
%-----------------------------------------------------------------------------%
Index: compiler/ml_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_util.m,v
retrieving revision 1.49
diff -u -b -r1.49 ml_util.m
--- compiler/ml_util.m 31 Jul 2006 08:31:52 -0000 1.49
+++ compiler/ml_util.m 11 Aug 2006 03:35:29 -0000
@@ -439,7 +439,7 @@
; rval_contains_var(Rval, Name)
).
atomic_stmt_contains_var(new_object(Target, _MaybeTag, _HasSecTag, _Type,
- _MaybeSize, _MaybeCtorName, Args, _ArgTypes), Name) :-
+ _MaybeSize, _MaybeCtorName, Args, _ArgTypes, _MayUseAtomic), Name) :-
( lval_contains_var(Target, Name)
; rvals_contains_var(Args, Name)
).
Index: compiler/mlds.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mlds.m,v
retrieving revision 1.137
diff -u -b -r1.137 mlds.m
--- compiler/mlds.m 31 Jul 2006 08:31:52 -0000 1.137
+++ compiler/mlds.m 11 Aug 2006 03:22:58 -0000
@@ -335,6 +335,7 @@
:- import_module backend_libs.foreign.
:- import_module backend_libs.rtti.
:- import_module hlds.code_model.
+:- import_module hlds.hlds_data.
:- import_module hlds.hlds_module.
:- import_module hlds.hlds_pred.
:- import_module libs.globals.
@@ -1222,7 +1223,7 @@
; new_object(
% new_object(Target, Tag, Type,
- % Size, CtorName, Args, ArgTypes):
+ % Size, CtorName, Args, ArgTypes, MayUseAtomic):
% Allocate a memory block of the given size,
% initialize it with a new object of the given
% type by calling the constructor with the specified
@@ -1258,14 +1259,18 @@
% The types of the arguments to the constructor.
%
% Note that for --low-level-data, we box all fields of objects
- % created with new_object, i.e. they are reprsented with type
+ % created with new_object, i.e. they are represented with type
% mlds_generic_type. We also do that for some fields even
% for --high-level-data (e.g. floating point fields for the
% MLDS->C and MLDS->asm back-ends). In such cases, the type
% here should be mlds_generic_type; it is the responsibility
% of the HLDS->MLDS code generator to insert code to box/unbox
% the arguments.
- list(mlds_type)
+ list(mlds_type),
+
+ % Can we use a cell allocated with GC_malloc_atomic to hold
+ % this object in the C backend?
+ may_use_atomic_alloc
)
; gc_check
Index: compiler/mlds_to_c.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mlds_to_c.m,v
retrieving revision 1.194
diff -u -b -r1.194 mlds_to_c.m
--- compiler/mlds_to_c.m 31 Jul 2006 08:31:52 -0000 1.194
+++ compiler/mlds_to_c.m 12 Aug 2006 02:25:38 -0000
@@ -80,6 +80,7 @@
:- import_module backend_libs.name_mangle.
:- import_module check_hlds.type_util.
:- import_module hlds.code_model.
+:- import_module hlds.hlds_data.
:- import_module hlds.hlds_pred. % for pred_proc_id.
:- import_module hlds.passes_aux.
:- import_module libs.compiler_util.
@@ -867,9 +868,8 @@
mlds_pragma_export::in, io::di, io::uo) is det.
mlds_output_pragma_export_func_name(ModuleName, Indent, Export, !IO) :-
- Export = ml_pragma_export(Lang, ExportName, _MLDS_Name, Signature, Context),
- expect(unify(Lang, lang_c), this_file,
- "export to language other than C."),
+ Export = ml_pragma_export(Lang, ExportName, _MLDSName, Signature, Context),
+ expect(unify(Lang, lang_c), this_file, "export to language other than C."),
Name = qual(ModuleName, module_qual, entity_export(ExportName)),
mlds_indent(Context, Indent, !IO),
% For functions exported using `pragma export',
@@ -943,13 +943,13 @@
mlds_output_pragma_export_type(prefix, mlds_rtti_type(_), !IO) :-
io.write_string("MR_Word", !IO).
mlds_output_pragma_export_type(prefix, mlds_tabling_type(_), !IO) :-
- % These types should never occur in procedures exported to C, so the
- % fact the could generate a more accurate type shouldn't matter.
+ % These types should never occur in procedures exported to C, so the fact
+ % that we could generate a more accurate type shouldn't matter.
io.write_string("MR_Word", !IO).
mlds_output_pragma_export_type(prefix, mlds_unknown_type, !IO) :-
unexpected(this_file, "mlds_output_pragma_export_type: unknown_type").
- % Output the definition body for a pragma export
+ % Output the definition body for a pragma export.
%
:- pred mlds_output_pragma_export_defn_body(mlds_module_name::in,
mlds_qualified_entity_name::in, mlds_func_params::in, io::di, io::uo)
@@ -958,8 +958,7 @@
mlds_output_pragma_export_defn_body(ModuleName, FuncName, Signature, !IO) :-
Signature = mlds_func_params(Parameters, RetTypes),
- % Declare local variables corresponding to any foreign_type
- % parameters.
+ % Declare local variables corresponding to any foreign_type parameters.
IsCForeignType = (pred(Arg::in) is semidet :-
Arg = mlds_argument(_Name, Type, _GCTraceCode),
Type = mlds_foreign_type(c(_))
@@ -975,7 +974,7 @@
io.write_list(CForeignTypeOutputs, "",
mlds_output_pragma_export_output_defns(ModuleName), !IO),
- % Declare a local variable or two for the return value, if needed
+ % Declare a local variable or two for the return value, if needed.
( RetTypes = [RetType1] ->
( RetType1 = mlds_foreign_type(c(_)) ->
io.write_string("\t", !IO),
@@ -1027,8 +1026,8 @@
io.write_list(CForeignTypeOutputs, "",
mlds_output_pragma_output_arg(ModuleName), !IO),
- % Generate the final statement to unbox and return the
- % return value, if needed.
+ % Generate the final statement to unbox and return the return value,
+ % if needed.
( RetTypes = [RetType3] ->
( RetType3 = mlds_foreign_type(c(_)) ->
io.write_string("\tMR_MAYBE_UNBOX_FOREIGN_TYPE(", !IO),
@@ -1183,7 +1182,7 @@
io::di, io::uo) is det.
mlds_output_decls(Indent, ModuleName, Defns, !IO) :-
- list.foldl(mlds_output_decl(Indent, ModuleName), Defns, !IO).
+ list.foldl(mlds_output_decl_blank_line(Indent, ModuleName), Defns, !IO).
:- pred mlds_output_defns(indent::in, bool::in, mlds_module_name::in,
mlds_defns::in, io::di, io::uo) is det.
@@ -1204,6 +1203,13 @@
list.foldl(OutputDefn, Defns, !IO)
).
+:- pred mlds_output_decl_blank_line(indent::in, mlds_module_name::in,
+ mlds_defn::in, io::di, io::uo) is det.
+
+mlds_output_decl_blank_line(Indent, ModuleName, Defn, !IO) :-
+ io.nl(!IO),
+ mlds_output_decl(Indent, ModuleName, Defn, !IO).
+
:- pred mlds_output_decl(indent::in, mlds_module_name::in, mlds_defn::in,
io::di, io::uo) is det.
@@ -1727,6 +1733,7 @@
),
io.write_char(' ', !IO),
io.write_string(CallingConvention, !IO),
+ io.nl(!IO),
mlds_output_fully_qualified_name(QualifiedName, !IO),
QualifiedName = qual(ModuleName, _, _),
mlds_output_params(OutputPrefix, OutputSuffix,
@@ -2981,7 +2988,7 @@
mlds_output_atomic_stmt(Indent, FuncInfo, NewObject, Context, !IO) :-
NewObject = new_object(Target, MaybeTag, _HasSecTag, Type, MaybeSize,
- MaybeCtorName, Args, ArgTypes),
+ MaybeCtorName, Args, ArgTypes, MayUseAtomic),
mlds_indent(Indent, !IO),
io.write_string("{\n", !IO),
@@ -3055,7 +3062,13 @@
mlds_output_cast(Type, !IO),
EndMkword = ""
),
- io.write_string("MR_new_object(", !IO),
+ (
+ MayUseAtomic = may_not_use_atomic_alloc,
+ io.write_string("MR_new_object(", !IO)
+ ;
+ MayUseAtomic = may_use_atomic_alloc,
+ io.write_string("MR_new_object_atomic(", !IO)
+ ),
mlds_output_type(Type, !IO),
io.write_string(", ", !IO),
(
Index: compiler/mlds_to_gcc.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mlds_to_gcc.m,v
retrieving revision 1.120
diff -u -b -r1.120 mlds_to_gcc.m
--- compiler/mlds_to_gcc.m 31 Jul 2006 03:13:45 -0000 1.120
+++ compiler/mlds_to_gcc.m 11 Aug 2006 03:38:51 -0000
@@ -3093,7 +3093,7 @@
gen_atomic_stmt(DefnInfo, NewObject, Context) -->
{ NewObject = new_object(Target, MaybeTag, _HasSecTag, Type, MaybeSize,
- _MaybeCtorName, Args, ArgTypes) },
+ _MaybeCtorName, Args, ArgTypes, _MayUseAtomic) },
%
% Calculate the size that we're going to allocate.
Index: compiler/mlds_to_il.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mlds_to_il.m,v
retrieving revision 1.166
diff -u -b -r1.166 mlds_to_il.m
--- compiler/mlds_to_il.m 31 Jul 2006 08:31:53 -0000 1.166
+++ compiler/mlds_to_il.m 11 Aug 2006 03:37:55 -0000
@@ -530,9 +530,9 @@
rename_atomic(assign(L, R)) = assign(rename_lval(L), rename_rval(R)).
rename_atomic(delete_object(O)) = delete_object(rename_lval(O)).
rename_atomic(new_object(L, Tag, HasSecTag, Type, MaybeSize, Ctxt, Args,
- Types))
+ Types, MayUseAtomic))
= new_object(rename_lval(L), Tag, HasSecTag, Type, MaybeSize,
- Ctxt, list.map(rename_rval, Args), Types).
+ Ctxt, list.map(rename_rval, Args), Types, MayUseAtomic).
rename_atomic(gc_check) = gc_check.
rename_atomic(mark_hp(L)) = mark_hp(rename_lval(L)).
rename_atomic(restore_hp(R)) = restore_hp(rename_rval(R)).
@@ -2016,7 +2016,7 @@
Instrs = tree_list([LoadInstrs, instr_node(ldnull), StoreInstrs]).
atomic_statement_to_il(new_object(Target, _MaybeTag, HasSecTag, Type, Size,
- MaybeCtorName, Args0, ArgTypes0), Instrs, !Info) :-
+ MaybeCtorName, Args0, ArgTypes0, _MayUseAtomic), Instrs, !Info) :-
DataRep = !.Info ^ il_data_rep,
(
(
Index: compiler/mlds_to_java.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mlds_to_java.m,v
retrieving revision 1.81
diff -u -b -r1.81 mlds_to_java.m
--- compiler/mlds_to_java.m 31 Jul 2006 08:31:53 -0000 1.81
+++ compiler/mlds_to_java.m 11 Aug 2006 03:38:09 -0000
@@ -671,7 +671,7 @@
method_ptrs_in_stmt(atomic(AtomicStatement), !CodeAddrs) :-
(
AtomicStatement = new_object(Lval, _MaybeTag, _Bool,
- _Type, _MemRval, _MaybeCtorName, Rvals, _Types)
+ _Type, _MemRval, _MaybeCtorName, Rvals, _Types, _MayUseAtomic)
->
% We don't need to check "_MemRval" since this just stores
% the amount of memory needed for the new object.
@@ -2777,7 +2777,7 @@
output_atomic_stmt(Indent, ModuleInfo, FuncInfo, NewObject, Context, !IO) :-
NewObject = new_object(Target, _MaybeTag, HasSecTag, Type,
- _MaybeSize, MaybeCtorName, Args, ArgTypes),
+ _MaybeSize, MaybeCtorName, Args, ArgTypes, _MayUseAtomic),
ModuleName = FuncInfo ^ func_info_name ^ mod_name,
indent_line(Indent, !IO),
Index: compiler/modecheck_unify.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/modecheck_unify.m,v
retrieving revision 1.106
diff -u -b -r1.106 modecheck_unify.m
--- compiler/modecheck_unify.m 31 Jul 2006 08:31:56 -0000 1.106
+++ compiler/modecheck_unify.m 10 Aug 2006 11:19:12 -0000
@@ -945,7 +945,7 @@
;
map.lookup(VarTypes, X, Type),
(
- type_is_atomic(Type, ModuleInfo0),
+ type_is_atomic(ModuleInfo0, Type),
not type_has_user_defined_equality_pred(ModuleInfo0, Type, _)
->
Unification = simple_test(X, Y)
Index: compiler/opt_debug.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/opt_debug.m,v
retrieving revision 1.171
diff -u -b -r1.171 opt_debug.m
--- compiler/opt_debug.m 28 Jul 2006 05:08:14 -0000 1.171
+++ compiler/opt_debug.m 10 Aug 2006 11:21:06 -0000
@@ -121,6 +121,7 @@
:- import_module backend_libs.name_mangle.
:- import_module backend_libs.proc_label.
+:- import_module hlds.hlds_data.
:- import_module hlds.hlds_pred.
:- import_module hlds.hlds_rtti.
:- import_module hlds.special_pred.
@@ -712,7 +713,7 @@
Instr = restore_maxfr(Lval),
Str = "restore_maxfr(" ++ dump_lval(Lval) ++ ")"
;
- Instr = incr_hp(Lval, MaybeTag, MaybeOffset, Size, _),
+ Instr = incr_hp(Lval, MaybeTag, MaybeOffset, Size, _, MayUseAtomic),
(
MaybeTag = no,
T_str = "no"
@@ -728,7 +729,8 @@
string.int_to_string(Offset, O_str)
),
Str = "incr_hp(" ++ dump_lval(Lval) ++ ", " ++ T_str ++ ", " ++ O_str
- ++ ", " ++ dump_rval(Size) ++ ")"
+ ++ ", " ++ dump_rval(Size) ++
+ ", " ++ dump_may_use_atomic(MayUseAtomic) ++ ")"
;
Instr = mark_hp(Lval),
Str = "mark_hp(" ++ dump_lval(Lval) ++ ")"
@@ -812,6 +814,11 @@
dump_bool(Msg, no) = Msg ++ " no\n".
dump_bool(Msg, yes) = Msg ++ " yes\n".
+:- func dump_may_use_atomic(may_use_atomic_alloc) = string.
+
+dump_may_use_atomic(may_use_atomic_alloc) = "may_use_atomic_alloc".
+dump_may_use_atomic(may_not_use_atomic_alloc) = "may_not_use_atomic_alloc".
+
:- func dump_decls(list(pragma_c_decl)) = string.
dump_decls([]) = "".
Index: compiler/opt_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/opt_util.m,v
retrieving revision 1.151
diff -u -b -r1.151 opt_util.m
--- compiler/opt_util.m 28 Jul 2006 05:08:14 -0000 1.151
+++ compiler/opt_util.m 7 Aug 2006 14:59:21 -0000
@@ -742,7 +742,7 @@
Between = [Instr0 | Between0]
)
;
- Uinstr0 = incr_hp(Lval, _, _, Rval, _),
+ Uinstr0 = incr_hp(Lval, _, _, Rval, _, _),
lval_refers_stackvars(Lval) = no,
rval_refers_stackvars(Rval) = no,
no_stackvars_til_decr_sp(Instrs0, FrameSize, Between0, Remain),
@@ -814,7 +814,7 @@
Uinstr = restore_maxfr(Lval),
Refers = lval_refers_stackvars(Lval)
;
- Uinstr = incr_hp(Lval, _, _, Rval, _),
+ Uinstr = incr_hp(Lval, _, _, Rval, _, _),
Refers = bool.or(
lval_refers_stackvars(Lval),
rval_refers_stackvars(Rval))
@@ -986,7 +986,7 @@
can_instr_branch_away(if_val(_, _), yes).
can_instr_branch_away(save_maxfr(_), no).
can_instr_branch_away(restore_maxfr(_), no).
-can_instr_branch_away(incr_hp(_, _, _, _, _), no).
+can_instr_branch_away(incr_hp(_, _, _, _, _, _), no).
can_instr_branch_away(mark_hp(_), no).
can_instr_branch_away(restore_hp(_), no).
can_instr_branch_away(free_heap(_), no).
@@ -1063,7 +1063,7 @@
can_instr_fall_through(if_val(_, _), yes).
can_instr_fall_through(save_maxfr(_), yes).
can_instr_fall_through(restore_maxfr(_), yes).
-can_instr_fall_through(incr_hp(_, _, _, _, _), yes).
+can_instr_fall_through(incr_hp(_, _, _, _, _, _), yes).
can_instr_fall_through(mark_hp(_), yes).
can_instr_fall_through(restore_hp(_), yes).
can_instr_fall_through(free_heap(_), yes).
@@ -1110,7 +1110,7 @@
can_use_livevals(if_val(_, _), yes).
can_use_livevals(save_maxfr(_), no).
can_use_livevals(restore_maxfr(_), no).
-can_use_livevals(incr_hp(_, _, _, _, _), no).
+can_use_livevals(incr_hp(_, _, _, _, _, _), no).
can_use_livevals(mark_hp(_), no).
can_use_livevals(restore_hp(_), no).
can_use_livevals(free_heap(_), no).
@@ -1174,7 +1174,7 @@
instr_labels_2(if_val(_, Addr), [], [Addr]).
instr_labels_2(save_maxfr(_), [], []).
instr_labels_2(restore_maxfr(_), [], []).
-instr_labels_2(incr_hp(_, _, _, _, _), [], []).
+instr_labels_2(incr_hp(_, _, _, _, _, _), [], []).
instr_labels_2(mark_hp(_), [], []).
instr_labels_2(restore_hp(_), [], []).
instr_labels_2(free_heap(_), [], []).
@@ -1236,7 +1236,7 @@
).
possible_targets(save_maxfr(_), [], []).
possible_targets(restore_maxfr(_), [], []).
-possible_targets(incr_hp(_, _, _, _, _), [], []).
+possible_targets(incr_hp(_, _, _, _, _, _), [], []).
possible_targets(mark_hp(_), [], []).
possible_targets(restore_hp(_), [], []).
possible_targets(free_heap(_), [], []).
@@ -1310,7 +1310,7 @@
instr_rvals_and_lvals(if_val(Rval, _), [Rval], []).
instr_rvals_and_lvals(save_maxfr(Lval), [], [Lval]).
instr_rvals_and_lvals(restore_maxfr(Lval), [], [Lval]).
-instr_rvals_and_lvals(incr_hp(Lval, _, _, Rval, _), [Rval], [Lval]).
+instr_rvals_and_lvals(incr_hp(Lval, _, _, Rval, _, _), [Rval], [Lval]).
instr_rvals_and_lvals(mark_hp(Lval), [], [Lval]).
instr_rvals_and_lvals(restore_hp(Rval), [Rval], []).
instr_rvals_and_lvals(free_heap(Rval), [Rval], []).
@@ -1446,7 +1446,7 @@
count_temps_lval(Lval, !R, !F).
count_temps_instr(restore_maxfr(Lval), !R, !F) :-
count_temps_lval(Lval, !R, !F).
-count_temps_instr(incr_hp(Lval, _, _, Rval, _), !R, !F) :-
+count_temps_instr(incr_hp(Lval, _, _, Rval, _, _), !R, !F) :-
count_temps_lval(Lval, !R, !F),
count_temps_rval(Rval, !R, !F).
count_temps_instr(mark_hp(Lval), !R, !F) :-
@@ -1590,7 +1590,7 @@
touches_nondet_ctrl_rval(Rval, TouchRval),
bool.or(TouchLval, TouchRval, Touch)
;
- Uinstr = incr_hp(Lval, _, _, Rval, _),
+ Uinstr = incr_hp(Lval, _, _, Rval, _, _),
touches_nondet_ctrl_lval(Lval, TouchLval),
touches_nondet_ctrl_rval(Rval, TouchRval),
bool.or(TouchLval, TouchRval, Touch)
@@ -1732,7 +1732,7 @@
count_incr_hp_2([], !N).
count_incr_hp_2([Uinstr0 - _ | Instrs], !N) :-
- ( Uinstr0 = incr_hp(_, _, _, _, _) ->
+ ( Uinstr0 = incr_hp(_, _, _, _, _, _) ->
!:N = !.N + 1
;
true
@@ -1879,8 +1879,8 @@
ReplData = no,
Lval = Lval0
).
-replace_labels_instr(incr_hp(Lval0, MaybeTag, MO, Rval0, Msg),
- ReplMap, ReplData, incr_hp(Lval, MaybeTag, MO, Rval, Msg)) :-
+replace_labels_instr(incr_hp(Lval0, MaybeTag, MO, Rval0, Msg, Atomic),
+ ReplMap, ReplData, incr_hp(Lval, MaybeTag, MO, Rval, Msg, Atomic)) :-
(
ReplData = yes,
replace_labels_lval(Lval0, ReplMap, Lval),
Index: compiler/options.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/options.m,v
retrieving revision 1.523
diff -u -b -r1.523 options.m
--- compiler/options.m 14 Aug 2006 03:31:31 -0000 1.523
+++ compiler/options.m 14 Aug 2006 03:35:01 -0000
@@ -570,6 +570,7 @@
; try_switch_size
; binary_switch_size
; static_ground_terms
+ ; use_atomic_cells
; middle_rec
; simple_neg
; allow_hijacks
@@ -1278,6 +1279,7 @@
try_switch_size - int(3),
binary_switch_size - int(4),
static_ground_terms - bool(no),
+ use_atomic_cells - bool(no),
middle_rec - bool(no),
simple_neg - bool(no),
allow_hijacks - bool(yes),
@@ -2021,6 +2023,7 @@
long_option("try-switch-size", try_switch_size).
long_option("binary-switch-size", binary_switch_size).
long_option("static-ground-terms", static_ground_terms).
+long_option("use-atomic-cells", use_atomic_cells).
long_option("middle-rec", middle_rec).
long_option("simple-neg", simple_neg).
long_option("allow-hijacks", allow_hijacks).
@@ -4153,6 +4156,9 @@
"\tNote that auxiliary data structures created by the compiler",
"\tfor purposes such as debugging will still be created as",
"\tstatic constants.",
+ "--no-use-atomic-cells",
+ "\tDon't use the atomic variants of the Boehm gc allocator calls,",
+ "\teven when this would otherwise be possible.",
"--no-middle-rec",
"\tDisable the middle recursion optimization.",
"--no-simple-neg",
Index: compiler/par_conj_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/par_conj_gen.m,v
retrieving revision 1.26
diff -u -b -r1.26 par_conj_gen.m
--- compiler/par_conj_gen.m 28 Jun 2006 04:46:17 -0000 1.26
+++ compiler/par_conj_gen.m 7 Aug 2006 14:59:54 -0000
@@ -170,8 +170,9 @@
MakeTerm = node([
assign(SpSlot, lval(sp))
- "save the parent stack pointer",
+ % The may_not_use_atomic here is conservative.
incr_hp(RegLval, no, no, const(int_const(STSize)),
- "synchronization vector")
+ "synchronization vector", may_not_use_atomic_alloc)
- "allocate a synchronization vector",
init_sync_term(RegLval, NumGoals)
- "initialize sync term",
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/polymorphism.m,v
retrieving revision 1.302
diff -u -b -r1.302 polymorphism.m
--- compiler/polymorphism.m 4 Aug 2006 10:51:19 -0000 1.302
+++ compiler/polymorphism.m 10 Aug 2006 11:19:32 -0000
@@ -2729,8 +2729,8 @@
init_const_type_ctor_info_var(Type, TypeCtor, TypeCtorInfoVar,
TypeCtorInfoGoal, ModuleInfo, !VarSet, !VarTypes, !RttiVarMaps) :-
- type_util.type_ctor_module(ModuleInfo, TypeCtor, ModuleName),
- type_util.type_ctor_name(ModuleInfo, TypeCtor, TypeName),
+ ModuleName = type_util.type_ctor_module(ModuleInfo, TypeCtor),
+ TypeName = type_util.type_ctor_name(ModuleInfo, TypeCtor),
TypeCtor = type_ctor(_, Arity),
ConsId = type_ctor_info_const(ModuleName, TypeName, Arity),
TypeInfoTerm = functor(ConsId, no, []),
Index: compiler/reassign.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/reassign.m,v
retrieving revision 1.18
diff -u -b -r1.18 reassign.m
--- compiler/reassign.m 31 Jul 2006 08:31:58 -0000 1.18
+++ compiler/reassign.m 7 Aug 2006 14:46:16 -0000
@@ -220,7 +220,7 @@
!:RevInstrs = [Instr0 | !.RevInstrs],
clobber_dependents(hp, !KnownContentsMap, !DepLvalMap)
;
- Uinstr0 = incr_hp(Target, _, _, _, _),
+ Uinstr0 = incr_hp(Target, _, _, _, _, _),
!:RevInstrs = [Instr0 | !.RevInstrs],
clobber_dependents(Target, !KnownContentsMap, !DepLvalMap),
clobber_dependents(hp, !KnownContentsMap, !DepLvalMap)
Index: compiler/size_prof.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/size_prof.m,v
retrieving revision 1.45
diff -u -b -r1.45 size_prof.m
--- compiler/size_prof.m 16 Aug 2006 01:25:47 -0000 1.45
+++ compiler/size_prof.m 16 Aug 2006 01:30:43 -0000
@@ -609,8 +609,8 @@
unexpected(this_file,
"size_prof.process_construct: constructing term of variable type")
),
- type_ctor_module(!.Info ^ module_info, VarTypeCtor, VarTypeCtorModule),
- type_ctor_name(!.Info ^ module_info, VarTypeCtor, VarTypeCtorName),
+ VarTypeCtorModule = type_ctor_module(!.Info ^ module_info, VarTypeCtor),
+ VarTypeCtorName = type_ctor_name(!.Info ^ module_info, VarTypeCtor),
(
ctor_is_type_info_related(VarTypeCtorModule, VarTypeCtorName)
->
@@ -672,8 +672,8 @@
unexpected(this_file,
"process_deconstruct: deconstructing term of variable type")
),
- type_ctor_module(!.Info ^ module_info, VarTypeCtor, VarTypeCtorModule),
- type_ctor_name(!.Info ^ module_info, VarTypeCtor, VarTypeCtorName),
+ VarTypeCtorModule = type_ctor_module(!.Info ^ module_info, VarTypeCtor),
+ VarTypeCtorName = type_ctor_name(!.Info ^ module_info, VarTypeCtor),
(
ctor_is_type_info_related(VarTypeCtorModule, VarTypeCtorName)
->
Index: compiler/structure_reuse.direct.choose_reuse.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/structure_reuse.direct.choose_reuse.m,v
retrieving revision 1.4
diff -u -b -r1.4 structure_reuse.direct.choose_reuse.m
--- compiler/structure_reuse.direct.choose_reuse.m 31 Jul 2006 08:32:02 -0000 1.4
+++ compiler/structure_reuse.direct.choose_reuse.m 18 Aug 2006 06:56:43 -0000
@@ -154,6 +154,28 @@
% constructions and the 'matches' we want to derive from them.
%
+% XXX With the --use-atomic-cells option, the compiler generates code
+% that uses GC_MALLOC_ATOMIC to allocate memory for heap cells that contain
+% no pointers to GCable memory. If we later reuse such a cell and put a pointer
+% to GCable memory into it, the Boehm collector will not see that pointer,
+% which may lead to the heap cell being pointed to being reclaimed prematurely,
+% a bug that will probably be very hard to find.
+%
+% To avoid this situation, we should
+%
+% (1) extend deconstruction_spec with a field of type may_use_atomic_alloc,
+% indicating whether the potentially reused cell may be atomic or not, and
+% (2) ensure that we reuse atomically-created cells only for connstructions
+% in which all arguments can be put into atomic cells.
+%
+% These will require applying type_may_use_atomic_alloc to the arguments of
+% both the reused deconstruction unifications and the reusing construction
+% unifications.
+%
+% However, a fix to this problem can wait until structure reuse starts to be
+% used in earnest. Until then, Nancy can simply avoid turning on
+% --use-atomic-cells.
+
% Details of a deconstruction yielding garbage.
%
:- type deconstruction_spec
Index: compiler/structure_sharing.domain.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/structure_sharing.domain.m,v
retrieving revision 1.14
diff -u -b -r1.14 structure_sharing.domain.m
--- compiler/structure_sharing.domain.m 31 Jul 2006 08:32:03 -0000 1.14
+++ compiler/structure_sharing.domain.m 10 Aug 2006 11:22:45 -0000
@@ -521,7 +521,7 @@
arg_has_primitive_type(ModuleInfo, ProcInfo, Var):-
proc_info_get_vartypes(ProcInfo, VarTypes),
map.lookup(VarTypes, Var, Type),
- type_is_atomic(Type, ModuleInfo).
+ type_is_atomic(ModuleInfo, Type).
% When two positions within the constructed term refer to the same variable,
% this must be recorded as an extra sharing pair.
@@ -904,7 +904,7 @@
ArgMode = top_out,
% type is not primitive
- \+ type_is_atomic(Type, ModuleInfo)
+ \+ type_is_atomic(ModuleInfo, Type)
),
list.filter(Test, ModeTypePairs, TrueModeTypePairs),
TrueModeTypePairs = [].
Index: compiler/type_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/type_util.m,v
retrieving revision 1.166
diff -u -b -r1.166 type_util.m
--- compiler/type_util.m 16 Aug 2006 01:25:48 -0000 1.166
+++ compiler/type_util.m 16 Aug 2006 03:06:54 -0000
@@ -29,12 +29,18 @@
%-----------------------------------------------------------------------------%
+ % Given a type_ctor, look up its module/name/arity.
+ %
+:- func type_ctor_module(module_info, type_ctor) = module_name.
+:- func type_ctor_name(module_info, type_ctor) = string.
+:- func type_ctor_arity(module_info, type_ctor) = arity.
+
% Succeed iff type is an "atomic" type - one which can be unified
% using a simple_test rather than a complicated_unify.
%
-:- pred type_is_atomic(mer_type::in, module_info::in) is semidet.
+:- pred type_is_atomic(module_info::in, mer_type::in) is semidet.
-:- pred type_ctor_is_atomic(type_ctor::in, module_info::in) is semidet.
+:- pred type_ctor_is_atomic(module_info::in, type_ctor::in) is semidet.
% Obtain the type definition and type definition body respectively,
% if known, for the principal type constructor of the given type.
@@ -80,6 +86,8 @@
:- pred is_solver_type(module_info::in, mer_type::in) is semidet.
+ % Succeed if the type body is for a solver type.
+ %
:- pred type_body_is_solver_type(module_info::in, hlds_type_body::in)
is semidet.
@@ -115,14 +123,21 @@
%
:- func classify_type_ctor(module_info, type_ctor) = type_category.
- % Given a type_ctor, look up its module/name/arity
+ % Report whether it is OK to include a value of the given time
+ % in a heap cell allocated with GC_malloc_atomic.
%
-:- pred type_ctor_module(module_info::in, type_ctor::in,
- module_name::out) is det.
-
-:- pred type_ctor_name(module_info::in, type_ctor::in, string::out) is det.
+:- func type_may_use_atomic_alloc(module_info, mer_type) =
+ may_use_atomic_alloc.
-:- pred type_ctor_arity(module_info::in, type_ctor::in, arity::out) is det.
+ % update_type_may_use_atomic_alloc(ModuleInfo, Type, !MaybeUseAtomic):
+ %
+ % Find out whether it is OK to include a value of the given time
+ % in a heap cell allocated with GC_malloc_atomic. If yes, leave
+ % !MaybeUseAtomic alone. If no, set !:MaybeUseAtomic to
+ % may_not_use_atomic_alloc.
+ %
+:- pred update_type_may_use_atomic_alloc(module_info::in, mer_type::in,
+ may_use_atomic_alloc::in, may_use_atomic_alloc::out) is det.
% If the type is a du type or a tuple type, return the list of its
% constructors.
@@ -134,7 +149,7 @@
% return the number of alternatives. (It is possible to have a complete
% switch on any du type and on the builtin type character. It is not
% feasible to have a complete switch on the builtin types integer,
- % float, and switch. One cannot have a switch on an abstract type,
+ % float, and string. One cannot have a switch on an abstract type,
% and equivalence types will have been expanded out by the time
% we consider switches.)
%
@@ -172,7 +187,7 @@
:- pred get_type_and_cons_defn(module_info::in, mer_type::in,
cons_id::in, hlds_type_defn::out, hlds_cons_defn::out) is det.
- % Like gget_type_and_cons_defn (above), except that it only returns
+ % Like get_type_and_cons_defn (above), except that it only returns
% the definition of the constructor, not the type.
%
:- pred get_cons_defn(module_info::in, type_ctor::in, cons_id::in,
@@ -307,20 +322,19 @@
%-----------------------------------------------------------------------------%
-
-type_ctor_module(_ModuleInfo, type_ctor(TypeName, _Arity), ModuleName) :-
+type_ctor_module(_ModuleInfo, type_ctor(TypeName, _Arity)) = ModuleName :-
sym_name_get_module_name(TypeName, unqualified(""), ModuleName).
-type_ctor_name(_ModuleInfo, type_ctor(Name0, _Arity), Name) :-
+type_ctor_name(_ModuleInfo, type_ctor(Name0, _Arity)) = Name :-
unqualify_name(Name0, Name).
-type_ctor_arity(_ModuleInfo, type_ctor(_Name, Arity), Arity).
+type_ctor_arity(_ModuleInfo, type_ctor(_Name, Arity)) = Arity.
-type_is_atomic(Type, ModuleInfo) :-
+type_is_atomic(ModuleInfo, Type) :-
type_to_ctor_and_args(Type, TypeCtor, _),
- type_ctor_is_atomic(TypeCtor, ModuleInfo).
+ type_ctor_is_atomic(ModuleInfo, TypeCtor).
-type_ctor_is_atomic(TypeCtor, ModuleInfo) :-
+type_ctor_is_atomic(ModuleInfo, TypeCtor) :-
TypeCategory = classify_type_ctor(ModuleInfo, TypeCtor),
type_category_is_atomic(TypeCategory) = yes.
@@ -342,85 +356,14 @@
type_category_is_atomic(type_cat_void) = yes.
type_category_is_atomic(type_cat_user_ctor) = no.
-type_ctor_has_hand_defined_rtti(Type, Body) :-
- Type = type_ctor(qualified(mercury_private_builtin_module, Name), 0),
- ( Name = "type_info"
- ; Name = "type_ctor_info"
- ; Name = "typeclass_info"
- ; Name = "base_typeclass_info"
- ),
- \+ ( Body = du_type(_, _, _, _, _, yes(_))
- ; Body = foreign_type(_)
- ; Body = solver_type(_, _)
- ).
-
-%-----------------------------------------------------------------------------%
-
-classify_type(ModuleInfo, VarType) = TypeCategory :-
- ( type_to_ctor_and_args(VarType, TypeCtor, _) ->
- TypeCategory = classify_type_ctor(ModuleInfo, TypeCtor)
- ;
- TypeCategory = type_cat_variable
- ).
+type_to_type_defn(ModuleInfo, Type, TypeDefn) :-
+ module_info_get_type_table(ModuleInfo, TypeTable),
+ type_to_ctor_and_args(Type, TypeCtor, _TypeArgs),
+ map.search(TypeTable, TypeCtor, TypeDefn).
-classify_type_ctor(ModuleInfo, TypeCtor) = TypeCategory :-
- TypeCtor = type_ctor(TypeSymName, Arity),
- (
- TypeSymName = unqualified(TypeName),
- Arity = 0,
- (
- TypeName = "character",
- TypeCategoryPrime = type_cat_char
- ;
- TypeName = "int",
- TypeCategoryPrime = type_cat_int
- ;
- TypeName = "float",
- TypeCategoryPrime = type_cat_float
- ;
- TypeName = "string",
- TypeCategoryPrime = type_cat_string
- ;
- TypeName = "void",
- TypeCategoryPrime = type_cat_void
- )
- ->
- TypeCategory = TypeCategoryPrime
- ;
- TypeSymName = qualified(ModuleSymName, TypeName),
- ModuleSymName = mercury_private_builtin_module,
- Arity = 0,
- (
- TypeName = "type_info",
- TypeCategoryPrime = type_cat_type_info
- ;
- TypeName = "type_ctor_info",
- TypeCategoryPrime = type_cat_type_ctor_info
- ;
- TypeName = "typeclass_info",
- TypeCategoryPrime = type_cat_typeclass_info
- ;
- TypeName = "base_typeclass_info",
- TypeCategoryPrime = type_cat_base_typeclass_info
- )
- ->
- TypeCategory = TypeCategoryPrime
- ;
- TypeSymName = qualified(unqualified(ModuleName), TypeName),
- is_builtin_dummy_argument_type(ModuleName, TypeName, Arity)
- ->
- TypeCategory = type_cat_dummy
- ;
- ( type_ctor_is_higher_order(TypeCtor, _, _, _) ->
- TypeCategory = type_cat_higher_order
- ; type_ctor_is_tuple(TypeCtor) ->
- TypeCategory = type_cat_tuple
- ; type_ctor_is_enumeration(TypeCtor, ModuleInfo) ->
- TypeCategory = type_cat_enum
- ;
- TypeCategory = type_cat_user_ctor
- )
- ).
+type_to_type_defn_body(ModuleInfo, Type, TypeBody) :-
+ type_to_type_defn(ModuleInfo, Type, TypeDefn),
+ hlds_data.get_type_defn_body(TypeDefn, TypeBody).
type_has_user_defined_equality_pred(ModuleInfo, Type, UserEqComp) :-
type_to_type_defn_body(ModuleInfo, Type, TypeBody),
@@ -470,15 +413,6 @@
eqv_type(Type), SolverTypeDetails) :-
type_has_solver_type_details(ModuleInfo, Type, SolverTypeDetails).
-type_to_type_defn(ModuleInfo, Type, TypeDefn) :-
- module_info_get_type_table(ModuleInfo, TypeTable),
- type_to_ctor_and_args(Type, TypeCtor, _TypeArgs),
- map.search(TypeTable, TypeCtor, TypeDefn).
-
-type_to_type_defn_body(ModuleInfo, Type, TypeBody) :-
- type_to_type_defn(ModuleInfo, Type, TypeDefn),
- hlds_data.get_type_defn_body(TypeDefn, TypeBody).
-
% XXX We can't assume that type variables refer to solver types
% because otherwise the compiler will try to construct initialisation
% forwarding predicates for exported abstract types defined to be
@@ -493,8 +427,6 @@
type_to_type_defn_body(ModuleInfo, Type, TypeBody),
type_body_is_solver_type(ModuleInfo, TypeBody).
- % Succeed if the type body is for a solver type.
- %
type_body_is_solver_type(ModuleInfo, TypeBody) :-
(
TypeBody = solver_type(_, _)
@@ -534,6 +466,86 @@
fail
).
+type_ctor_has_hand_defined_rtti(Type, Body) :-
+ Type = type_ctor(qualified(mercury_private_builtin_module, Name), 0),
+ ( Name = "type_info"
+ ; Name = "type_ctor_info"
+ ; Name = "typeclass_info"
+ ; Name = "base_typeclass_info"
+ ),
+ \+ ( Body = du_type(_, _, _, _, _, yes(_))
+ ; Body = foreign_type(_)
+ ; Body = solver_type(_, _)
+ ).
+
+%-----------------------------------------------------------------------------%
+
+classify_type(ModuleInfo, VarType) = TypeCategory :-
+ ( type_to_ctor_and_args(VarType, TypeCtor, _) ->
+ TypeCategory = classify_type_ctor(ModuleInfo, TypeCtor)
+ ;
+ TypeCategory = type_cat_variable
+ ).
+
+classify_type_ctor(ModuleInfo, TypeCtor) = TypeCategory :-
+ TypeCtor = type_ctor(TypeSymName, Arity),
+ (
+ TypeSymName = unqualified(TypeName),
+ Arity = 0,
+ (
+ TypeName = "character",
+ TypeCategoryPrime = type_cat_char
+ ;
+ TypeName = "int",
+ TypeCategoryPrime = type_cat_int
+ ;
+ TypeName = "float",
+ TypeCategoryPrime = type_cat_float
+ ;
+ TypeName = "string",
+ TypeCategoryPrime = type_cat_string
+ ;
+ TypeName = "void",
+ TypeCategoryPrime = type_cat_void
+ )
+ ->
+ TypeCategory = TypeCategoryPrime
+ ;
+ TypeSymName = qualified(ModuleSymName, TypeName),
+ ModuleSymName = mercury_private_builtin_module,
+ Arity = 0,
+ (
+ TypeName = "type_info",
+ TypeCategoryPrime = type_cat_type_info
+ ;
+ TypeName = "type_ctor_info",
+ TypeCategoryPrime = type_cat_type_ctor_info
+ ;
+ TypeName = "typeclass_info",
+ TypeCategoryPrime = type_cat_typeclass_info
+ ;
+ TypeName = "base_typeclass_info",
+ TypeCategoryPrime = type_cat_base_typeclass_info
+ )
+ ->
+ TypeCategory = TypeCategoryPrime
+ ;
+ TypeSymName = qualified(unqualified(ModuleName), TypeName),
+ is_builtin_dummy_argument_type(ModuleName, TypeName, Arity)
+ ->
+ TypeCategory = type_cat_dummy
+ ;
+ ( type_ctor_is_higher_order(TypeCtor, _, _, _) ->
+ TypeCategory = type_cat_higher_order
+ ; type_ctor_is_tuple(TypeCtor) ->
+ TypeCategory = type_cat_tuple
+ ; type_ctor_is_enumeration(TypeCtor, ModuleInfo) ->
+ TypeCategory = type_cat_enum
+ ;
+ TypeCategory = type_cat_user_ctor
+ )
+ ).
+
:- pred type_ctor_is_enumeration(type_ctor::in, module_info::in) is semidet.
type_ctor_is_enumeration(TypeCtor, ModuleInfo) :-
@@ -544,7 +556,51 @@
%-----------------------------------------------------------------------------%
- % If the type is a du type, return the list of its constructors.
+update_type_may_use_atomic_alloc(ModuleInfo, Type, !MayUseAtomic) :-
+ (
+ !.MayUseAtomic = may_not_use_atomic_alloc
+ % There is no point in testing Type.
+ ;
+ !.MayUseAtomic = may_use_atomic_alloc,
+ !:MayUseAtomic = type_may_use_atomic_alloc(ModuleInfo, Type)
+ ).
+
+type_may_use_atomic_alloc(ModuleInfo, Type) = TypeMayUseAtomic :-
+ TypeCategory = classify_type(ModuleInfo, Type),
+ (
+ ( TypeCategory = type_cat_int
+ ; TypeCategory = type_cat_char
+ ; TypeCategory = type_cat_enum
+ ; TypeCategory = type_cat_dummy
+ ; TypeCategory = type_cat_type_ctor_info
+ ),
+ TypeMayUseAtomic = may_use_atomic_alloc
+ ;
+ TypeCategory = type_cat_float,
+ module_info_get_globals(ModuleInfo, Globals),
+ globals.lookup_bool_option(Globals, unboxed_float, UBF),
+ (
+ UBF = yes,
+ TypeMayUseAtomic = may_use_atomic_alloc
+ ;
+ UBF = no,
+ TypeMayUseAtomic = may_not_use_atomic_alloc
+ )
+ ;
+ ( TypeCategory = type_cat_string
+ ; TypeCategory = type_cat_higher_order
+ ; TypeCategory = type_cat_tuple
+ ; TypeCategory = type_cat_variable
+ ; TypeCategory = type_cat_type_info
+ ; TypeCategory = type_cat_typeclass_info
+ ; TypeCategory = type_cat_base_typeclass_info
+ ; TypeCategory = type_cat_void
+ ; TypeCategory = type_cat_user_ctor
+ ),
+ TypeMayUseAtomic = may_not_use_atomic_alloc
+ ).
+
+%-----------------------------------------------------------------------------%
type_constructors(Type, ModuleInfo, Constructors) :-
type_to_ctor_and_args(Type, TypeCtor, TypeArgs),
@@ -564,6 +620,45 @@
Constructors)
).
+ % Substitute the actual values of the type parameters in list of
+ % constructors, for a particular instance of a polymorphic type.
+ %
+:- pred substitute_type_args(list(type_param)::in, list(mer_type)::in,
+ list(constructor)::in, list(constructor)::out) is det.
+
+substitute_type_args(TypeParams, TypeArgs, Constructors0, Constructors) :-
+ (
+ TypeParams = [],
+ Constructors = Constructors0
+ ;
+ TypeParams = [_ | _],
+ map.from_corresponding_lists(TypeParams, TypeArgs, Subst),
+ substitute_type_args_2(Subst, Constructors0, Constructors)
+ ).
+
+:- pred substitute_type_args_2(tsubst::in, list(constructor)::in,
+ list(constructor)::out) is det.
+
+substitute_type_args_2(_, [], []).
+substitute_type_args_2(Subst, [Ctor0 | Ctors0], [Ctor | Ctors]) :-
+ % Note: prog_io.m ensures that the existentially quantified variables,
+ % if any, are distinct from the parameters, and that the (existential)
+ % constraints can only contain existentially quantified variables,
+ % so there's no need to worry about applying the substitution to ExistQVars
+ % or Constraints.
+ Ctor0 = ctor(ExistQVars, Constraints, Name, Args0),
+ substitute_type_args_3(Subst, Args0, Args),
+ substitute_type_args_2(Subst, Ctors0, Ctors),
+ Ctor = ctor(ExistQVars, Constraints, Name, Args).
+
+:- pred substitute_type_args_3(tsubst::in, list(constructor_arg)::in,
+ list(constructor_arg)::out) is det.
+
+substitute_type_args_3(_, [], []).
+substitute_type_args_3(Subst, [Name - Arg0 | Args0], [Name - Arg | Args]) :-
+ apply_subst_to_type(Subst, Arg0, Arg),
+ substitute_type_args_3(Subst, Args0, Args).
+
%-----------------------------------------------------------------------------%
switch_type_num_functors(ModuleInfo, Type, NumFunctors) :-
@@ -674,30 +769,6 @@
:- pred is_existq_cons(module_info::in, mer_type::in, cons_id::in,
hlds_cons_defn::out) is semidet.
-is_existq_cons(ModuleInfo, VarType, ConsId, ConsDefn) :-
- type_to_ctor_and_args(VarType, TypeCtor, _),
- get_cons_defn(ModuleInfo, TypeCtor, ConsId, ConsDefn),
- ConsDefn = hlds_cons_defn(ExistQVars, _, _, _, _),
- ExistQVars = [_ | _].
-
- % Given a type and a cons_id, look up the definition of that constructor;
- % if it is existentially typed, return its definition, otherwise fail.
-get_existq_cons_defn(ModuleInfo, VarType, ConsId, CtorDefn) :-
- is_existq_cons(ModuleInfo, VarType, ConsId, ConsDefn),
- ConsDefn = hlds_cons_defn(ExistQVars, Constraints, Args, _, _),
- assoc_list.values(Args, ArgTypes),
- module_info_get_type_table(ModuleInfo, Types),
- type_to_ctor_and_args(VarType, TypeCtor, _),
- map.lookup(Types, TypeCtor, TypeDefn),
- hlds_data.get_type_defn_tvarset(TypeDefn, TypeVarSet),
- hlds_data.get_type_defn_tparams(TypeDefn, TypeParams),
- hlds_data.get_type_defn_kind_map(TypeDefn, KindMap),
- prog_type.var_list_to_type_list(KindMap, TypeParams, TypeCtorArgs),
- type_to_ctor_and_args(VarType, TypeCtor, _),
- construct_type(TypeCtor, TypeCtorArgs, RetType),
- CtorDefn = ctor_defn(TypeVarSet, ExistQVars, KindMap, Constraints,
- ArgTypes, RetType).
-
get_type_and_cons_defn(ModuleInfo, Type, ConsId, TypeDefn, ConsDefn) :-
(
type_to_ctor_and_args(Type, TypeCtor, _),
@@ -728,6 +799,30 @@
),
list.filter(MatchingCons, ConsDefns, [ConsDefn]).
+ % Given a type and a cons_id, look up the definition of that constructor;
+ % if it is existentially typed, return its definition, otherwise fail.
+get_existq_cons_defn(ModuleInfo, VarType, ConsId, CtorDefn) :-
+ is_existq_cons(ModuleInfo, VarType, ConsId, ConsDefn),
+ ConsDefn = hlds_cons_defn(ExistQVars, Constraints, Args, _, _),
+ assoc_list.values(Args, ArgTypes),
+ module_info_get_type_table(ModuleInfo, Types),
+ type_to_ctor_and_args(VarType, TypeCtor, _),
+ map.lookup(Types, TypeCtor, TypeDefn),
+ hlds_data.get_type_defn_tvarset(TypeDefn, TypeVarSet),
+ hlds_data.get_type_defn_tparams(TypeDefn, TypeParams),
+ hlds_data.get_type_defn_kind_map(TypeDefn, KindMap),
+ prog_type.var_list_to_type_list(KindMap, TypeParams, TypeCtorArgs),
+ type_to_ctor_and_args(VarType, TypeCtor, _),
+ construct_type(TypeCtor, TypeCtorArgs, RetType),
+ CtorDefn = ctor_defn(TypeVarSet, ExistQVars, KindMap, Constraints,
+ ArgTypes, RetType).
+
+is_existq_cons(ModuleInfo, VarType, ConsId, ConsDefn) :-
+ type_to_ctor_and_args(VarType, TypeCtor, _),
+ get_cons_defn(ModuleInfo, TypeCtor, ConsId, ConsDefn),
+ ConsDefn = hlds_cons_defn(ExistQVars, _, _, _, _),
+ ExistQVars = [_ | _].
+
%-----------------------------------------------------------------------------%
type_is_no_tag_type(ModuleInfo, Type, Ctor, ArgType) :-
@@ -746,47 +841,6 @@
%-----------------------------------------------------------------------------%
- % Substitute the actual values of the type parameters in list of
- % constructors, for a particular instance of a polymorphic type.
- %
-:- pred substitute_type_args(list(type_param)::in, list(mer_type)::in,
- list(constructor)::in, list(constructor)::out) is det.
-
-substitute_type_args(TypeParams, TypeArgs, Constructors0, Constructors) :-
- (
- TypeParams = [],
- Constructors = Constructors0
- ;
- TypeParams = [_ | _],
- map.from_corresponding_lists(TypeParams, TypeArgs, Subst),
- substitute_type_args_2(Subst, Constructors0, Constructors)
- ).
-
-:- pred substitute_type_args_2(tsubst::in, list(constructor)::in,
- list(constructor)::out) is det.
-
-substitute_type_args_2(_, [], []).
-substitute_type_args_2(Subst, [Ctor0 | Ctors0], [Ctor | Ctors]) :-
- % Note: prog_io.m ensures that the existentially quantified variables,
- % if any, are distinct from the parameters, and that the (existential)
- % constraints can only contain existentially quantified variables,
- % so there's no need to worry about applying the substitution to ExistQVars
- % or Constraints.
- Ctor0 = ctor(ExistQVars, Constraints, Name, Args0),
- substitute_type_args_3(Subst, Args0, Args),
- substitute_type_args_2(Subst, Ctors0, Ctors),
- Ctor = ctor(ExistQVars, Constraints, Name, Args).
-
-:- pred substitute_type_args_3(tsubst::in, list(constructor_arg)::in,
- list(constructor_arg)::out) is det.
-
-substitute_type_args_3(_, [], []).
-substitute_type_args_3(Subst, [Name - Arg0 | Args0], [Name - Arg | Args]) :-
- apply_subst_to_type(Subst, Arg0, Arg),
- substitute_type_args_3(Subst, Args0, Args).
-
-%-----------------------------------------------------------------------------%
-
cons_id_adjusted_arity(ModuleInfo, Type, ConsId) = AdjustedArity :-
% Figure out the arity of this constructor, _including_ any type-infos
% or typeclass-infos inserted for existential data types.
Index: compiler/unify_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/unify_gen.m,v
retrieving revision 1.168
diff -u -b -r1.168 unify_gen.m
--- compiler/unify_gen.m 31 Jul 2006 08:32:09 -0000 1.168
+++ compiler/unify_gen.m 12 Aug 2006 13:15:13 -0000
@@ -419,17 +419,19 @@
code_info.get_module_info(!.CI, ModuleInfo),
var_types(!.CI, Args, ArgTypes),
generate_cons_args(Args, ArgTypes, Modes, 0, 1, TakeAddr, ModuleInfo,
- Rvals, FieldAddrs),
- construct_cell(Var, Ptag, Rvals, MaybeSize, FieldAddrs, Code, !CI)
+ MaybeRvals, FieldAddrs, MayUseAtomic),
+ construct_cell(Var, Ptag, MaybeRvals, MaybeSize, FieldAddrs,
+ MayUseAtomic, Code, !CI)
;
ConsTag = shared_remote_tag(Ptag, Sectag),
code_info.get_module_info(!.CI, ModuleInfo),
var_types(!.CI, Args, ArgTypes),
generate_cons_args(Args, ArgTypes, Modes, 1, 1, TakeAddr, ModuleInfo,
- Rvals0, FieldAddrs),
+ MaybeRvals0, FieldAddrs, MayUseAtomic),
% The first field holds the secondary tag.
- Rvals = [yes(const(int_const(Sectag))) | Rvals0],
- construct_cell(Var, Ptag, Rvals, MaybeSize, FieldAddrs, Code, !CI)
+ MaybeRvals = [yes(const(int_const(Sectag))) | MaybeRvals0],
+ construct_cell(Var, Ptag, MaybeRvals, MaybeSize, FieldAddrs,
+ MayUseAtomic, Code, !CI)
;
ConsTag = shared_local_tag(Bits1, Num1),
code_info.assign_const_to_var(Var,
@@ -601,13 +603,15 @@
NumNewArgsPlusThree_Rval = const(int_const(NumNewArgsPlusThree)),
code_info.produce_variable(CallPred, OldClosureCode,
OldClosure, !CI),
+ % The new closure contains a pointer to the old closure.
+ NewClosureMayUseAtomic = may_not_use_atomic_alloc,
NewClosureCode = node([
comment("build new closure from old closure") - "",
assign(NumOldArgs, lval(field(yes(0), OldClosure, Two)))
- "get number of arguments",
incr_hp(NewClosure, no, no,
binop(int_add, lval(NumOldArgs), NumNewArgsPlusThree_Rval),
- "closure")
+ "closure", NewClosureMayUseAtomic)
- "allocate new closure",
assign(field(yes(0), lval(NewClosure), Zero),
lval(field(yes(0), OldClosure, Zero)))
@@ -652,7 +656,7 @@
CodeAddr = code_info.make_entry_label(!.CI, ModuleInfo,
PredId, ProcId, no),
code_util.extract_proc_label_from_code_addr(CodeAddr, ProcLabel),
- CallArgsRval = const(code_addr_const(CodeAddr)),
+ CodeAddrRval = const(code_addr_const(CodeAddr)),
continuation_info.generate_closure_layout( ModuleInfo, PredId, ProcId,
ClosureInfo),
module_info_get_name(ModuleInfo, ModuleName),
@@ -678,15 +682,18 @@
ClosureLayoutRval = const(data_addr_const(ClosureDataAddr, no)),
list.length(Args, NumArgs),
proc_info_arg_info(ProcInfo, ArgInfo),
- generate_pred_args(Args, ArgInfo, PredArgs),
+ VarTypes = get_var_types(!.CI),
+ MayUseAtomic0 = initial_may_use_atomic(ModuleInfo),
+ generate_pred_args(ModuleInfo, VarTypes, Args, ArgInfo, PredArgs,
+ MayUseAtomic0, MayUseAtomic),
Vector = [
yes(ClosureLayoutRval),
- yes(CallArgsRval),
+ yes(CodeAddrRval),
yes(const(int_const(NumArgs)))
| PredArgs
],
code_info.assign_cell_to_var(Var, no, 0, Vector, no, "closure",
- Code, !CI)
+ MayUseAtomic, Code, !CI)
).
:- pred generate_extra_closure_args(list(prog_var)::in, lval::in,
@@ -706,34 +713,39 @@
generate_extra_closure_args(Vars, LoopCounter, NewClosure, Code2, !CI),
Code = tree_list([Code0, Code1, Code2]).
-:- pred generate_pred_args(list(prog_var)::in, list(arg_info)::in,
- list(maybe(rval))::out) is det.
+:- pred generate_pred_args(module_info::in, vartypes::in, list(prog_var)::in,
+ list(arg_info)::in, list(maybe(rval))::out,
+ may_use_atomic_alloc::in, may_use_atomic_alloc::out) is det.
-generate_pred_args([], _, []).
-generate_pred_args([_ | _], [], _) :-
+generate_pred_args(_, _, [], _, [], !MayUseAtomic).
+generate_pred_args(_, _, [_ | _], [], _, !MayUseAtomic) :-
unexpected(this_file, "generate_pred_args: insufficient args").
-generate_pred_args([Var | Vars], [ArgInfo | ArgInfos],
- [Rval | Rvals]) :-
+generate_pred_args(ModuleInfo, VarTypes, [Var | Vars], [ArgInfo | ArgInfos],
+ [Rval | Rvals], !MayUseAtomic) :-
ArgInfo = arg_info(_, ArgMode),
( ArgMode = top_in ->
Rval = yes(var(Var))
;
Rval = no
),
- generate_pred_args(Vars, ArgInfos, Rvals).
+ map.lookup(VarTypes, Var, Type),
+ update_type_may_use_atomic_alloc(ModuleInfo, Type, !MayUseAtomic),
+ generate_pred_args(ModuleInfo, VarTypes, Vars, ArgInfos, Rvals,
+ !MayUseAtomic).
:- pred generate_cons_args(list(prog_var)::in, list(mer_type)::in,
list(uni_mode)::in, int::in, int::in, list(int)::in, module_info::in,
- list(maybe(rval))::out, assoc_list(int, prog_var)::out) is det.
+ list(maybe(rval))::out, assoc_list(int, prog_var)::out,
+ may_use_atomic_alloc::out) is det.
generate_cons_args(Vars, Types, Modes, FirstOffset, FirstArgNum, TakeAddr,
- ModuleInfo, Args, FieldAddrs) :-
+ ModuleInfo, !:Args, !:FieldAddrs, !:MayUseAtomic) :-
+ !:MayUseAtomic = initial_may_use_atomic(ModuleInfo),
(
generate_cons_args_2(Vars, Types, Modes, FirstOffset, FirstArgNum,
- TakeAddr, ModuleInfo, Args0, FieldAddrs0)
+ TakeAddr, ModuleInfo, !:Args, !:FieldAddrs, !MayUseAtomic)
->
- Args = Args0,
- FieldAddrs = FieldAddrs0
+ true
;
unexpected(this_file, "generate_cons_args: length mismatch")
).
@@ -745,16 +757,19 @@
%
:- pred generate_cons_args_2(list(prog_var)::in, list(mer_type)::in,
list(uni_mode)::in, int::in, int::in, list(int)::in, module_info::in,
- list(maybe(rval))::out, assoc_list(int, prog_var)::out) is semidet.
+ list(maybe(rval))::out, assoc_list(int, prog_var)::out,
+ may_use_atomic_alloc::in, may_use_atomic_alloc::out) is semidet.
-generate_cons_args_2([], [], [], _, _, [], _, [], []).
+generate_cons_args_2([], [], [], _, _, [], _, [], [], !MayUseAtomic).
generate_cons_args_2([Var | Vars], [Type | Types], [UniMode | UniModes],
FirstOffset, CurArgNum, !.TakeAddr, ModuleInfo, [Rval | Rvals],
- FieldAddrs) :-
+ FieldAddrs, !MayUseAtomic) :-
+ update_type_may_use_atomic_alloc(ModuleInfo, Type, !MayUseAtomic),
( !.TakeAddr = [CurArgNum | !:TakeAddr] ->
Rval = no,
- generate_cons_args_2(Vars, Types, UniModes, FirstOffset,
- CurArgNum + 1, !.TakeAddr, ModuleInfo, Rvals, FieldAddrs1),
+ !:MayUseAtomic = may_not_use_atomic_alloc,
+ generate_cons_args_2(Vars, Types, UniModes, FirstOffset, CurArgNum + 1,
+ !.TakeAddr, ModuleInfo, Rvals, FieldAddrs1, !MayUseAtomic),
% Whereas CurArgNum starts numbering the arguments from 1, offsets
% into fields start from zero. However, if FirstOffset = 1, then the
% first word in the cell is the secondary tag.
@@ -768,15 +783,30 @@
;
Rval = no
),
- generate_cons_args_2(Vars, Types, UniModes, FirstOffset,
- CurArgNum + 1, !.TakeAddr, ModuleInfo, Rvals, FieldAddrs)
+ generate_cons_args_2(Vars, Types, UniModes, FirstOffset, CurArgNum + 1,
+ !.TakeAddr, ModuleInfo, Rvals, FieldAddrs, !MayUseAtomic)
+ ).
+
+:- func initial_may_use_atomic(module_info) = may_use_atomic_alloc.
+
+initial_may_use_atomic(ModuleInfo) = InitMayUseAtomic :-
+ module_info_get_globals(ModuleInfo, Globals),
+ globals.lookup_bool_option(Globals, use_atomic_cells, UseAtomicCells),
+ (
+ UseAtomicCells = no,
+ InitMayUseAtomic = may_not_use_atomic_alloc
+ ;
+ UseAtomicCells = yes,
+ InitMayUseAtomic = may_use_atomic_alloc
).
:- pred construct_cell(prog_var::in, tag::in, list(maybe(rval))::in,
- maybe(term_size_value)::in, assoc_list(int, prog_var)::in, code_tree::out,
- code_info::in, code_info::out) is det.
+ maybe(term_size_value)::in, assoc_list(int, prog_var)::in,
+ may_use_atomic_alloc::in, code_tree::out, code_info::in, code_info::out)
+ is det.
-construct_cell(Var, Ptag, MaybeRvals, MaybeSize, FieldAddrs, Code, !CI) :-
+construct_cell(Var, Ptag, MaybeRvals, MaybeSize, FieldAddrs, MayUseAtomic,
+ Code, !CI) :-
VarType = code_info.variable_type(!.CI, Var),
var_type_msg(VarType, VarTypeMsg),
% If we're doing accurate GC, then for types which hold RTTI that
@@ -796,7 +826,7 @@
ReserveWordAtStart = no
),
code_info.assign_cell_to_var(Var, ReserveWordAtStart, Ptag, MaybeRvals,
- MaybeSize, VarTypeMsg, CellCode, !CI),
+ MaybeSize, VarTypeMsg, MayUseAtomic, CellCode, !CI),
(
FieldAddrs = [],
% Optimize common case.
Index: compiler/unused_args.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/unused_args.m,v
retrieving revision 1.131
diff -u -b -r1.131 unused_args.m
--- compiler/unused_args.m 4 Aug 2006 10:51:21 -0000 1.131
+++ compiler/unused_args.m 12 Aug 2006 02:56:46 -0000
@@ -418,21 +418,21 @@
(
MaybeBestResult = yes({_, unused_args(UnusedArgs), _}),
(
- UnusedArgs = [_|_],
+ UnusedArgs = [_ | _],
proc_info_get_headvars(ProcInfo, HeadVars),
list.map(list.index1_det(HeadVars), UnusedArgs,
UnusedVars),
initialise_vardep(UnusedVars, !.VarDep, VarDep),
- svmap.set(proc(PredId, ProcId), VarDep, !VarUsage),
+ PredProcId = proc(PredId, ProcId),
+ svmap.set(PredProcId, VarDep, !VarUsage),
globals.io_lookup_bool_option(optimize_unused_args,
- Optimize, !IO),
+ OptimizeUnusedArgs, !IO),
(
- Optimize = yes,
- make_imported_unused_args_pred_info(
- proc(PredId, ProcId), UnusedArgs, !OptProcs,
- !ModuleInfo)
+ OptimizeUnusedArgs = yes,
+ make_imported_unused_args_pred_info(PredProcId,
+ UnusedArgs, !OptProcs, !ModuleInfo)
;
- Optimize = no
+ OptimizeUnusedArgs = no
)
;
UnusedArgs = []
@@ -448,15 +448,15 @@
MakeAnalysisRegistry, !IO),
(
MakeAnalysisRegistry = yes,
- ( not is_unify_or_compare_pred(PredInfo) ->
+ ( is_unify_or_compare_pred(PredInfo) ->
+ AnalysisInfo = AnalysisInfo1
+ ;
analysis.record_result(PredModuleId, FuncId,
Call, top(Call) : unused_args_answer,
suboptimal, AnalysisInfo1, AnalysisInfo2),
analysis.record_request(analysis_name,
PredModuleId, FuncId, Call, AnalysisInfo2,
AnalysisInfo)
- ;
- AnalysisInfo = AnalysisInfo1
)
;
MakeAnalysisRegistry = no,
@@ -1146,9 +1146,9 @@
% Fix up special pred names.
OrigOrigin = special_pred(_SpecialId - TypeCtor)
->
- type_ctor_module(ModuleInfo, TypeCtor, TypeModule),
- type_ctor_name(ModuleInfo, TypeCtor, TypeName),
- type_ctor_arity(ModuleInfo, TypeCtor, TypeArity),
+ TypeModule = type_ctor_module(ModuleInfo, TypeCtor),
+ TypeName = type_ctor_name(ModuleInfo, TypeCtor),
+ TypeArity = type_ctor_arity(ModuleInfo, TypeCtor),
string.int_to_string(TypeArity, TypeArityStr),
sym_name_to_string(TypeModule, TypeModuleString0),
string.replace_all(TypeModuleString0, ".", "__", TypeModuleString),
Index: compiler/use_local_vars.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/use_local_vars.m,v
retrieving revision 1.24
diff -u -b -r1.24 use_local_vars.m
--- compiler/use_local_vars.m 31 Jul 2006 08:32:11 -0000 1.24
+++ compiler/use_local_vars.m 7 Aug 2006 14:49:23 -0000
@@ -172,7 +172,7 @@
Instr0 = Uinstr0 - _Comment0,
(
( Uinstr0 = assign(ToLval, _FromRval)
- ; Uinstr0 = incr_hp(ToLval, _MaybeTag, _SizeRval, _MO, _Type)
+ ; Uinstr0 = incr_hp(ToLval, _MaybeTag, _SizeRval, _MO, _Type, _Atomic)
),
base_lval_worth_replacing(NumRealRRegs, ToLval)
->
@@ -393,10 +393,10 @@
expect(unify(ToLval, OldLval),
this_file, "substitute_lval_in_defn: mismatch in assign"),
Uinstr = assign(NewLval, FromRval)
- ; Uinstr0 = incr_hp(ToLval, MaybeTag, SizeRval, MO, Type) ->
+ ; Uinstr0 = incr_hp(ToLval, MaybeTag, SizeRval, MO, Type, MayUseAtomic) ->
expect(unify(ToLval, OldLval),
this_file, "substitute_lval_in_defn: mismatch in incr_hp"),
- Uinstr = incr_hp(NewLval, MaybeTag, SizeRval, MO, Type)
+ Uinstr = incr_hp(NewLval, MaybeTag, SizeRval, MO, Type, MayUseAtomic)
;
unexpected(this_file,
"substitute_lval_in_defn: unexpected instruction")
@@ -483,7 +483,7 @@
;
Uinstr0 = restore_maxfr(_)
;
- Uinstr0 = incr_hp(Lval, _, _, _, _),
+ Uinstr0 = incr_hp(Lval, _, _, _, _, _),
( Lval = OldLval ->
% If we alter any lval that occurs in OldLval, we must stop
% the substitutions. At the moment, the only lval OldLval
Index: compiler/var_locn.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/var_locn.m,v
retrieving revision 1.41
diff -u -b -r1.41 var_locn.m
--- compiler/var_locn.m 31 Jul 2006 08:32:11 -0000 1.41
+++ compiler/var_locn.m 12 Aug 2006 02:48:48 -0000
@@ -20,13 +20,14 @@
:- module ll_backend.var_locn.
:- interface.
-:- import_module parse_tree.prog_data.
-:- import_module hlds.hlds_module.
+:- import_module hlds.hlds_data.
:- import_module hlds.hlds_goal.
:- import_module hlds.hlds_llds.
+:- import_module hlds.hlds_module.
+:- import_module libs.options.
:- import_module ll_backend.global_data.
:- import_module ll_backend.llds.
-:- import_module libs.options.
+:- import_module parse_tree.prog_data.
:- import_module assoc_list.
:- import_module bool.
@@ -166,7 +167,7 @@
var_locn_info::in, var_locn_info::out) is det.
% assign_cell_to_var(ModuleInfo, Var, ReserveWordAtStart, Ptag, Vector,
- % SizeInfo, TypeMsg, Where, Code, !StaticCellInfo, !VarLocnInfo):
+ % SizeInfo, TypeMsg, MayUseAtomic, Code, !StaticCellInfo, !VarLocnInfo):
%
% Generates code to assign to Var a pointer, tagged by Ptag, to the cell
% whose contents are given by the other arguments, and updates the state
@@ -178,11 +179,12 @@
% of whether it is allocated statically or dynamically), and initialize
% this word with the value determined by SizeVal. (NOTE: ReserveWordAtStart
% and SizeInfo should not be yes / yes(_), because that will cause an
- % obvious conflict.) Where will say where the created cell is.
+ % obvious conflict.)
%
:- pred assign_cell_to_var(module_info::in, prog_var::in, bool::in, tag::in,
list(maybe(rval))::in, maybe(term_size_value)::in, string::in,
- code_tree::out, static_cell_info::in, static_cell_info::out,
+ may_use_atomic_alloc::in, code_tree::out,
+ static_cell_info::in, static_cell_info::out,
var_locn_info::in, var_locn_info::out) is det.
% place_var(ModuleInfo, Var, Lval, Code, !VarLocnInfo):
@@ -357,6 +359,7 @@
:- import_module check_hlds.type_util.
:- import_module libs.compiler_util.
+:- import_module libs.globals.
:- import_module libs.options.
:- import_module libs.tree.
:- import_module ll_backend.code_util.
@@ -805,7 +808,7 @@
%----------------------------------------------------------------------------%
assign_cell_to_var(ModuleInfo, Var, ReserveWordAtStart, Ptag, MaybeRvals0,
- SizeInfo, TypeMsg, Code, !StaticCellInfo, !VLI) :-
+ SizeInfo, TypeMsg, MayUseAtomic, Code, !StaticCellInfo, !VLI) :-
(
SizeInfo = yes(SizeSource),
(
@@ -832,15 +835,16 @@
Code = empty
;
assign_dynamic_cell_to_var(ModuleInfo, Var, ReserveWordAtStart, Ptag,
- MaybeRvals, MaybeOffset, TypeMsg, Code, !VLI)
+ MaybeRvals, MaybeOffset, TypeMsg, MayUseAtomic, Code, !VLI)
).
:- pred assign_dynamic_cell_to_var(module_info::in, prog_var::in, bool::in,
tag::in, list(maybe(rval))::in, maybe(int)::in, string::in,
- code_tree::out, var_locn_info::in, var_locn_info::out) is det.
+ may_use_atomic_alloc::in, code_tree::out,
+ var_locn_info::in, var_locn_info::out) is det.
assign_dynamic_cell_to_var(ModuleInfo, Var, ReserveWordAtStart, Ptag, Vector,
- MaybeOffset, TypeMsg, Code, !VLI) :-
+ MaybeOffset, TypeMsg, MayUseAtomic, Code, !VLI) :-
check_var_is_unknown(!.VLI, Var),
select_preferred_reg_or_stack_check(!.VLI, Var, Lval),
@@ -865,7 +869,7 @@
),
CellCode = node([
incr_hp(Lval, yes(Ptag), TotalOffset,
- const(int_const(TotalSize)), TypeMsg)
+ const(int_const(TotalSize)), TypeMsg, MayUseAtomic)
- string.append("Allocating heap for ", VarName)
]),
set_magic_var_location(Var, Lval, !VLI),
cvs diff: Diffing compiler/notes
cvs diff: Diffing debian
cvs diff: Diffing debian/patches
cvs diff: Diffing deep_profiler
cvs diff: Diffing deep_profiler/notes
cvs diff: Diffing doc
Index: doc/user_guide.texi
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/doc/user_guide.texi,v
retrieving revision 1.485
diff -u -b -r1.485 user_guide.texi
--- doc/user_guide.texi 9 Aug 2006 04:56:36 -0000 1.485
+++ doc/user_guide.texi 12 Aug 2006 02:33:19 -0000
@@ -7412,6 +7412,13 @@
must be at least this number (default: 4).
@sp 1
+ at item --no-use-atomic-cells
+ at findex --no-use-atomic-cells
+ at findex --use-atomic-cells
+Don't use the atomic variants of the Boehm gc allocator calls,
+even when this would otherwise be possible.
+
+ at sp 1
@item --no-middle-rec
@findex --no-middle-rec
@findex --middle-rec
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/concurrency
cvs diff: Diffing extras/curs
cvs diff: Diffing extras/curs/samples
cvs diff: Diffing extras/curses
cvs diff: Diffing extras/curses/sample
cvs diff: Diffing extras/dynamic_linking
cvs diff: Diffing extras/error
cvs diff: Diffing extras/gator
cvs diff: Diffing extras/gator/generations
cvs diff: Diffing extras/gator/generations/1
cvs diff: Diffing extras/graphics
cvs diff: Diffing extras/graphics/easyx
cvs diff: Diffing extras/graphics/easyx/samples
cvs diff: Diffing extras/graphics/mercury_glut
cvs diff: Diffing extras/graphics/mercury_opengl
cvs diff: Diffing extras/graphics/mercury_tcltk
cvs diff: Diffing extras/graphics/samples
cvs diff: Diffing extras/graphics/samples/calc
cvs diff: Diffing extras/graphics/samples/gears
cvs diff: Diffing extras/graphics/samples/maze
cvs diff: Diffing extras/graphics/samples/pent
cvs diff: Diffing extras/lazy_evaluation
cvs diff: Diffing extras/lex
cvs diff: Diffing extras/lex/samples
cvs diff: Diffing extras/lex/tests
cvs diff: Diffing extras/logged_output
cvs diff: Diffing extras/moose
cvs diff: Diffing extras/moose/samples
cvs diff: Diffing extras/moose/tests
cvs diff: Diffing extras/morphine
cvs diff: Diffing extras/morphine/non-regression-tests
cvs diff: Diffing extras/morphine/scripts
cvs diff: Diffing extras/morphine/source
cvs diff: Diffing extras/odbc
cvs diff: Diffing extras/posix
cvs diff: Diffing extras/quickcheck
cvs diff: Diffing extras/quickcheck/tutes
cvs diff: Diffing extras/references
cvs diff: Diffing extras/references/samples
cvs diff: Diffing extras/references/tests
cvs diff: Diffing extras/solver_types
cvs diff: Diffing extras/solver_types/library
cvs diff: Diffing extras/stream
cvs diff: Diffing extras/trailed_update
cvs diff: Diffing extras/trailed_update/samples
cvs diff: Diffing extras/trailed_update/tests
cvs diff: Diffing extras/windows_installer_generator
cvs diff: Diffing extras/windows_installer_generator/sample
cvs diff: Diffing extras/windows_installer_generator/sample/images
cvs diff: Diffing extras/xml
cvs diff: Diffing extras/xml/samples
cvs diff: Diffing extras/xml_stylesheets
cvs diff: Diffing java
cvs diff: Diffing java/runtime
cvs diff: Diffing library
cvs diff: Diffing mdbcomp
cvs diff: Diffing profiler
cvs diff: Diffing robdd
cvs diff: Diffing runtime
Index: runtime/mercury.h
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury.h,v
retrieving revision 1.74
diff -u -b -r1.74 mercury.h
--- runtime/mercury.h 15 Aug 2006 04:19:38 -0000 1.74
+++ runtime/mercury.h 16 Aug 2006 01:25:09 -0000
@@ -201,9 +201,19 @@
)
#define MR_new_object(type, size, name) \
((type *) MR_GC_MALLOC_INLINE(size))
+ /*
+ ** Since the Boehm collector defined GC_MALLOC_WORDS but not
+ ** GC_MALLOC_WORDS_ATOMIC, we can define MR_new_object_atomic here
+ ** to call either MR_GC_MALLOC_ATOMIC or MR_GC_MALLOC_INLINE,
+ ** depending on whether we value atomicity or inline expansion more.
+ */
+ #define MR_new_object_atomic(type, size, name) \
+ ((type *) MR_GC_MALLOC_ATOMIC(size))
#else /* !MR_INLINE_ALLOC */
#define MR_new_object(type, size, name) \
((type *) GC_MALLOC(size))
+ #define MR_new_object_atomic(type, size, name) \
+ ((type *) GC_MALLOC_ATOMIC(size))
#endif /* !MR_INLINE_ALLOC */
#else /* !MR_CONSERVATIVE_GC */
@@ -219,10 +229,9 @@
/*
** XXX Note that currently we don't need to worry about alignment here,
- ** other than word alignment, because floating point fields will
- ** be boxed if they don't fit in a word.
- ** This would need to change if we ever start using unboxed
- ** fields whose alignment requirement is greater than one word.
+ ** other than word alignment, because floating point fields will be boxed
+ ** if they don't fit in a word. This would need to change if we ever start
+ ** using unboxed fields whose alignment requirement is greater than one word.
*/
#define MR_new_object(type, size, name) \
({ \
@@ -234,6 +243,8 @@
MR_incr_hp(MR_new_object_ptr, MR_new_object_num_words); \
/* return */ (type *) MR_new_object_ptr; \
})
+ #define MR_new_object_atomic(type, size, name) \
+ MR_new_object(type, size, name)
#endif
@@ -250,7 +261,7 @@
\
MR_make_hp_float_aligned(); \
MR_box_float_ptr = \
- MR_new_object(MR_Float, sizeof(MR_Float), "float"); \
+ MR_new_object_atomic(MR_Float, sizeof(MR_Float), "float"); \
*MR_box_float_ptr = (f); \
/* return */ (MR_Box) MR_box_float_ptr; \
})
@@ -262,7 +273,7 @@
MR_Float *ptr;
MR_make_hp_float_aligned();
- ptr = MR_new_object(MR_Float, sizeof(MR_Float), "float");
+ ptr = MR_new_object_atomic(MR_Float, sizeof(MR_Float), "float");
*ptr = f;
return (MR_Box) ptr;
}
Index: runtime/mercury_heap.h
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_heap.h,v
retrieving revision 1.35
diff -u -b -r1.35 mercury_heap.h
--- runtime/mercury_heap.h 15 Aug 2006 04:19:39 -0000 1.35
+++ runtime/mercury_heap.h 16 Aug 2006 01:25:10 -0000
@@ -299,8 +299,12 @@
#define MR_alloc_heap(dest, count) \
MR_tag_offset_incr_hp((dest), MR_mktag(0), 0, (count))
+#define MR_alloc_heap_atomic(dest, count) \
+ MR_tag_offset_incr_hp_atomic((dest), MR_mktag(0), 0, (count))
#define MR_tag_alloc_heap(dest, tag, count) \
MR_tag_offset_incr_hp((dest), MR_mktag(tag), 0, (count))
+#define MR_tag_alloc_heap_atomic(dest, tag, count) \
+ MR_tag_offset_incr_hp_atomic((dest), MR_mktag(tag), 0, (count))
#ifdef MR_HIGHLEVEL_CODE
cvs diff: Diffing runtime/GETOPT
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/mercury_calls_fortran
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 samples/muz
cvs diff: Diffing samples/rot13
cvs diff: Diffing samples/solutions
cvs diff: Diffing samples/tests
cvs diff: Diffing samples/tests/c_interface
cvs diff: Diffing samples/tests/c_interface/c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/tests/c_interface/mercury_calls_c
cvs diff: Diffing samples/tests/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/tests/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/tests/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/tests/diff
cvs diff: Diffing samples/tests/muz
cvs diff: Diffing samples/tests/rot13
cvs diff: Diffing samples/tests/solutions
cvs diff: Diffing samples/tests/toplevel
cvs diff: Diffing scripts
cvs diff: Diffing slice
cvs diff: Diffing tests
cvs diff: Diffing tests/benchmarks
cvs diff: Diffing tests/debugger
cvs diff: Diffing tests/debugger/declarative
cvs diff: Diffing tests/dppd
cvs diff: Diffing tests/general
cvs diff: Diffing tests/general/accumulator
cvs diff: Diffing tests/general/string_format
cvs diff: Diffing tests/general/structure_reuse
cvs diff: Diffing tests/grade_subdirs
cvs diff: Diffing tests/hard_coded
cvs diff: Diffing tests/hard_coded/exceptions
cvs diff: Diffing tests/hard_coded/purity
cvs diff: Diffing tests/hard_coded/sub-modules
cvs diff: Diffing tests/hard_coded/typeclasses
cvs diff: Diffing tests/invalid
cvs diff: Diffing tests/invalid/purity
cvs diff: Diffing tests/misc_tests
cvs diff: Diffing tests/mmc_make
cvs diff: Diffing tests/mmc_make/lib
cvs diff: Diffing tests/par_conj
cvs diff: Diffing tests/recompilation
cvs diff: Diffing tests/tabling
cvs diff: Diffing tests/term
cvs diff: Diffing tests/trailing
cvs diff: Diffing tests/valid
cvs diff: Diffing tests/warnings
cvs diff: Diffing tools
cvs diff: Diffing trace
cvs diff: Diffing util
cvs diff: Diffing vim
cvs diff: Diffing vim/after
cvs diff: Diffing vim/ftplugin
cvs diff: Diffing vim/syntax
--------------------------------------------------------------------------
mercury-reviews mailing list
Post messages to: mercury-reviews at csse.unimelb.edu.au
Administrative Queries: owner-mercury-reviews at csse.unimelb.edu.au
Subscriptions: mercury-reviews-request at csse.unimelb.edu.au
--------------------------------------------------------------------------
More information about the reviews
mailing list