mercurylang/mercury
1
0
Fork 0
mirror of https://github.com/Mercury-Language/mercury.git synced 2026-04-30 08:44:37 +00:00
Code Issues Projects Releases Wiki Activity
Files
083d376e6598628362ee91c2da170febd83590f4
mercury/compiler/mlds_to_c_data.m
Zoltan Somogyi efae0930be Delete unneeded predicates from mlds_to_c_name.m. 
compiler/mlds_to_c_name.m:
    Now that all calls to predicates in the module that do I/O
    have been replaced by calls to the function versions returning strings,
    delete the I/O predicates.

    Update the names of some the functions (most of which were derived
    from the names of the original predicates), fitting them into the
    naming scheme used in the rest of the module.

compiler/add_pragma_tabling.m:
compiler/mlds_to_c_data.m:
compiler/mlds_to_c_export.m:
compiler/mlds_to_c_file.m:
compiler/mlds_to_c_func.m:
compiler/mlds_to_c_global.m:
compiler/mlds_to_c_stmt.m:
    Use the updated function names.
2023-05-16 08:11:56 +10:00

1189 lines
46 KiB
Mathematica
Raw Blame History

%---------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%---------------------------------------------------------------------------%
% Copyright (C) 2018 The Mercury team.
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%---------------------------------------------------------------------------%
%
% Output MLDS lvals and rvals.
%
%---------------------------------------------------------------------------%
:- module ml_backend.mlds_to_c_data.
:- interface.
:- import_module ml_backend.mlds.
:- import_module ml_backend.mlds_to_c_util.
:- import_module io.
%---------------------------------------------------------------------------%
:- pred mlds_output_lval(mlds_to_c_opts::in, mlds_lval::in,
io.text_output_stream::in, io::di, io::uo) is det.
:- pred mlds_output_rval(mlds_to_c_opts::in, mlds_rval::in,
io.text_output_stream::in, io::di, io::uo) is det.
:- pred mlds_output_bracketed_rval(mlds_to_c_opts::in,
io.text_output_stream::in, mlds_rval::in, io::di, io::uo) is det.
:- pred mlds_output_boxed_rval(mlds_to_c_opts::in, io.text_output_stream::in,
mlds_type::in, mlds_rval::in, io::di, io::uo) is det.
%---------------------------------------------------------------------------%
:- pred mlds_output_initializer(mlds_to_c_opts::in, io.text_output_stream::in,
mlds_type::in, mlds_initializer::in, io::di, io::uo) is det.
:- pred mlds_output_initializer_body(mlds_to_c_opts::in,
io.text_output_stream::in, int::in, mlds_initializer::in,
io::di, io::uo) is det.
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
:- implementation.
:- import_module backend_libs.
:- import_module backend_libs.builtin_ops.
:- import_module backend_libs.c_util.
:- import_module backend_libs.rtti.
:- import_module libs.
:- import_module libs.globals.
:- import_module libs.indent.
:- import_module mdbcomp.
:- import_module mdbcomp.prim_data.
:- import_module mdbcomp.sym_name.
:- import_module ml_backend.ml_util.
:- import_module ml_backend.mlds_to_c_name.
:- import_module ml_backend.mlds_to_c_type.
:- import_module parse_tree.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_foreign.
:- import_module parse_tree.prog_type.
:- import_module bool.
:- import_module char.
:- import_module int.
:- import_module int16.
:- import_module int32.
:- import_module int8.
:- import_module list.
:- import_module maybe.
:- import_module require.
:- import_module string.
:- import_module term.
:- import_module uint.
:- import_module uint16.
:- import_module uint32.
:- import_module uint8.
%---------------------------------------------------------------------------%
mlds_output_lval(Opts, Lval, Stream, !IO) :-
(
Lval = ml_field(MaybePtag, PtrRval, PtrType, FieldId, FieldType),
(
FieldId = ml_field_offset(OffsetRval),
( if
(
FieldType = mlds_generic_type
;
FieldType = mercury_nb_type(MercuryType, _),
MercuryType = type_variable(_, _)
% We could also accept other types that are the same size
% as MR_Box, such as builtin_type(builtin_type_int) and
% builtin_type(builtin_type_string).
)
then
io.write_string(Stream, "(", !IO),
(
MaybePtag = yes(ptag(PtagUInt8)),
io.format(Stream, "MR_hl_field(%u, ", [u8(PtagUInt8)], !IO)
;
MaybePtag = no,
io.write_string(Stream, "MR_hl_mask_field(", !IO),
io.write_string(Stream, "(MR_Word) ", !IO)
),
mlds_output_rval(Opts, PtrRval, Stream, !IO),
io.write_string(Stream, ", ", !IO),
mlds_output_rval(Opts, OffsetRval, Stream, !IO),
io.write_string(Stream, "))", !IO)
else
% The field type for ml_lval_field(_, _, ml_field_offset(_),
% _, _) lvals must be something that maps to MR_Box.
unexpected($pred, "unexpected field type")
)
;
FieldId = ml_field_named(QualFieldVarName, CtorType),
QualFieldVarNameStr =
qual_field_var_name_to_string_for_c(QualFieldVarName),
( if MaybePtag = yes(ptag(0u8)) then
( if PtrType = CtorType then
CastStr = ""
else
CastStr = cast_to_prefix_string_for_c(Opts, CtorType)
),
( if PtrRval = ml_mem_addr(PtrAddrLval) then
io.format(Stream, "(%s", [s(CastStr)], !IO),
mlds_output_lval(Opts, PtrAddrLval, Stream, !IO),
io.format(Stream, ").%s", [s(QualFieldVarNameStr)], !IO)
else
io.format(Stream, "(%s", [s(CastStr)], !IO),
mlds_output_bracketed_rval(Opts, Stream, PtrRval, !IO),
io.format(Stream, ")->%s", [s(QualFieldVarNameStr)], !IO)
)
else
CastStr = cast_to_prefix_string_for_c(Opts, CtorType),
(
MaybePtag = yes(ptag(PtagUInt8)),
io.format(Stream, "(%sMR_body(", [s(CastStr)], !IO),
mlds_output_rval(Opts, PtrRval, Stream, !IO),
io.format(Stream, ", %u))->%s",
[u8(PtagUInt8), s(QualFieldVarNameStr)], !IO)
;
MaybePtag = no,
io.format(Stream, "(%sMR_strip_tag(", [s(CastStr)], !IO),
mlds_output_rval(Opts, PtrRval, Stream, !IO),
io.format(Stream, "))->%s", [s(QualFieldVarNameStr)], !IO)
)
)
)
;
Lval = ml_mem_ref(Rval, _Type),
io.write_string(Stream, "*", !IO),
mlds_output_bracketed_rval(Opts, Stream, Rval, !IO)
;
Lval = ml_target_global_var_ref(GlobalVarRef),
io.write_string(Stream, global_var_ref_to_string(GlobalVarRef), !IO)
;
Lval = ml_global_var(QualGlobalVarName, _VarType),
QualGlobalVarName =
qual_global_var_name(MLDS_ModuleName, GlobalVarName),
QualGlobalVarNameStr = maybe_qual_global_var_name_to_string_for_c(
MLDS_ModuleName, GlobalVarName),
io.write_string(Stream, QualGlobalVarNameStr, !IO)
;
Lval = ml_local_var(LocalVarName, _VarType),
LocalVarNameStr = local_var_name_to_string_for_c(LocalVarName),
io.write_string(Stream, LocalVarNameStr, !IO)
).
mlds_output_rval(Opts, Rval, Stream, !IO) :-
(
Rval = ml_lval(Lval),
mlds_output_lval(Opts, Lval, Stream, !IO)
% XXX Do we need the commented out code below?
% if a field is used as an rval, then we need to use
% the MR_hl_const_field() macro, not the MR_hl_field() macro,
% to avoid warnings about discarding const,
% and similarly for MR_mask_field.
% ( if Lval = ml_lval_field(MaybePtag, Rval, FieldNum, _, _) then
% (
% MaybePtag = yes(Ptag),
% io.write_string(Stream, "MR_hl_const_field(", !IO),
% mlds_output_ptag(Ptag, !IO),
% io.write_string(Stream, ", ", !IO)
% ;
% MaybePtag = no,
% io.write_string(Stream, "MR_hl_const_mask_field(", !IO)
% ),
% mlds_output_rval(Rval, !IO),
% io.write_string(Stream, ", ", !IO),
% mlds_output_rval(FieldNum, !IO),
% io.write_string(Stream, ")", !IO)
% else
% mlds_output_lval(Lval, !IO)
% ).
;
Rval = ml_mkword(ptag(PtagUInt8), BaseRval),
io.format(Stream, "MR_mkword(%u, ", [u8(PtagUInt8)], !IO),
mlds_output_rval(Opts, BaseRval, Stream, !IO),
io.write_string(Stream, ")", !IO)
;
Rval = ml_const(Const),
mlds_output_rval_const(Opts, Stream, Const, !IO)
;
Rval = ml_cast(Type, SubRval),
mlds_output_cast_rval(Opts, Stream, Type, SubRval, !IO)
;
Rval = ml_box(Type, SubRval),
mlds_output_boxed_rval(Opts, Stream, Type, SubRval, !IO)
;
Rval = ml_unbox(Type, SubRval),
mlds_output_unboxed_rval(Opts, Stream, Type, SubRval, !IO)
;
Rval = ml_unop(Unop, SubRval),
mlds_output_unop(Opts, Stream, Unop, SubRval, !IO)
;
Rval = ml_binop(BinOp, RvalA, RvalB),
mlds_output_binop(Opts, Stream, BinOp, RvalA, RvalB, !IO)
;
Rval = ml_mem_addr(Lval),
% XXX Are parentheses needed?
io.write_string(Stream, "&", !IO),
mlds_output_lval(Opts, Lval, Stream, !IO)
;
(
Rval = ml_scalar_common(ScalarCommon)
;
Rval = ml_scalar_common_addr(ScalarCommon),
io.write_string(Stream, "&", !IO)
),
ScalarCommon = mlds_scalar_common(ModuleName, _Type,
ml_scalar_common_type_num(TypeNum), RowNum),
ModuleSymName = mlds_module_name_to_sym_name(ModuleName),
MangledModuleName = sym_name_mangle(ModuleSymName),
io.format(Stream, "%s_scalar_common_%d[%d]",
[s(MangledModuleName), i(TypeNum), i(RowNum)], !IO)
;
Rval = ml_vector_common_row_addr(VectorCommon, RowRval),
VectorCommon = mlds_vector_common(ModuleName, _Type,
ml_vector_common_type_num(TypeNum), StartRowNum, _NumRows),
ModuleSymName = mlds_module_name_to_sym_name(ModuleName),
MangledModuleName = sym_name_mangle(ModuleSymName),
io.format(Stream, "&%s_vector_common_%d[%d + ",
[s(MangledModuleName), i(TypeNum), i(StartRowNum)], !IO),
mlds_output_rval(Opts, RowRval, Stream, !IO),
io.write_string(Stream, "]", !IO)
;
Rval = ml_self(_),
io.write_string(Stream, "this", !IO)
).
mlds_output_bracketed_rval(Opts, Stream, Rval, !IO) :-
( if
% If it is just a variable name, then we do not need parentheses.
( Rval = ml_lval(ml_local_var(_,_))
; Rval = ml_lval(ml_global_var(_,_))
; Rval = ml_const(mlconst_code_addr(_))
)
then
mlds_output_rval(Opts, Rval, Stream, !IO)
else
io.write_char(Stream, '(', !IO),
mlds_output_rval(Opts, Rval, Stream, !IO),
io.write_char(Stream, ')', !IO)
).
:- pred mlds_output_cast_rval(mlds_to_c_opts::in, io.text_output_stream::in,
mlds_type::in, mlds_rval::in, io::di, io::uo) is det.
mlds_output_cast_rval(Opts, Stream, Type, Rval, !IO) :-
CastStr = cast_to_prefix_string_for_c(Opts, Type),
% Cast the *whole* of Rval, not just an initial subrval.
io.format(Stream, "%s(", [s(CastStr)], !IO),
mlds_output_rval(Opts, Rval, Stream, !IO),
io.write_char(Stream, ')', !IO).
%---------------------%
mlds_output_boxed_rval(Opts, Stream, Type, Rval, !IO) :-
( if
Rval = ml_cast(OtherType, InnerRval),
( Type = OtherType
; is_an_address(InnerRval) = yes
)
then
% Avoid unnecessary double-casting -- strip away the inner cast.
% This is necessary for ANSI/ISO C conformance, to avoid casts
% from pointers to integers in static initializers.
mlds_output_boxed_rval(Opts, Stream, Type, InnerRval, !IO)
else
(
Type = mlds_generic_type,
mlds_output_boxed_rval_generic(Opts, Stream, Rval, !IO)
;
Type = mlds_builtin_type_float,
mlds_output_boxed_rval_float(Opts, Stream, Rval, !IO)
;
( Type = mlds_native_bool_type
; Type = mlds_builtin_type_char
% ; Type = mlds_builtin_type_int(int_type_int) % XXX ARG_PACK
),
mlds_output_boxed_rval_smaller_than_word(Opts, Stream, Rval, !IO)
;
( Type = mlds_builtin_type_string
; Type = mlds_array_type(_)
; Type = mlds_mercury_array_type(_)
; Type = mlds_mostly_generic_array_type(_)
; Type = mlds_class_type(_)
; Type = mlds_commit_type
; Type = mlds_cont_type(_)
; Type = mlds_foreign_type(_)
; Type = mlds_func_type(_)
; Type = mlds_generic_env_ptr_type
; Type = mlds_pseudo_type_info_type
; Type = mlds_ptr_type(_)
; Type = mlds_rtti_type(_)
; Type = mlds_tabling_type(_)
; Type = mlds_type_info_type
; Type = mlds_unknown_type
),
mlds_output_boxed_rval_default(Opts, Stream, Rval, !IO)
;
Type = mlds_builtin_type_int(IntType),
(
( IntType = int_type_int
; IntType = int_type_uint
),
mlds_output_boxed_rval_default(Opts, Stream, Rval, !IO)
;
( IntType = int_type_int8
; IntType = int_type_uint8
; IntType = int_type_int16
; IntType = int_type_uint16
; IntType = int_type_int32
; IntType = int_type_uint32
),
mlds_output_boxed_rval_smaller_than_word(Opts, Stream,
Rval, !IO)
;
IntType = int_type_int64,
mlds_output_boxed_rval_int64(Opts, Stream, Rval, !IO)
;
IntType = int_type_uint64,
mlds_output_boxed_rval_uint64(Opts, Stream, Rval, !IO)
)
;
Type = mercury_nb_type(MercuryType, _),
(
MercuryType = builtin_type(_BuiltinType),
unexpected($pred, "mercury_nb_type but builtin_type")
;
MercuryType = type_variable(_, _),
mlds_output_boxed_rval_generic(Opts, Stream, Rval, !IO)
;
( MercuryType = defined_type(_, _, _)
; MercuryType = tuple_type(_, _)
; MercuryType = higher_order_type(_, _, _, _, _)
; MercuryType = apply_n_type(_, _, _)
; MercuryType = kinded_type(_, _)
),
mlds_output_boxed_rval_default(Opts, Stream, Rval, !IO)
)
)
).
:- pred mlds_output_boxed_rval_generic(mlds_to_c_opts::in,
io.text_output_stream::in, mlds_rval::in, io::di, io::uo) is det.
:- pragma inline(pred(mlds_output_boxed_rval_generic/5)).
mlds_output_boxed_rval_generic(Opts, Stream, Rval, !IO) :-
% Rval already has type MR_Box, so no cast is needed.
mlds_output_rval(Opts, Rval, Stream, !IO).
:- pred mlds_output_boxed_rval_float(mlds_to_c_opts::in,
io.text_output_stream::in, mlds_rval::in, io::di, io::uo) is det.
:- pragma inline(pred(mlds_output_boxed_rval_float/5)).
mlds_output_boxed_rval_float(Opts, Stream, Rval, !IO) :-
io.write_string(Stream, "MR_box_float(", !IO),
mlds_output_rval(Opts, Rval, Stream, !IO),
io.write_string(Stream, ")", !IO).
:- pred mlds_output_boxed_rval_int64(mlds_to_c_opts::in,
io.text_output_stream::in, mlds_rval::in, io::di, io::uo) is det.
:- pragma inline(pred(mlds_output_boxed_rval_int64/5)).
mlds_output_boxed_rval_int64(Opts, Stream, Rval, !IO) :-
io.write_string(Stream, "MR_box_int64(", !IO),
mlds_output_rval(Opts, Rval, Stream, !IO),
io.write_string(Stream, ")", !IO).
:- pred mlds_output_boxed_rval_uint64(mlds_to_c_opts::in,
io.text_output_stream::in, mlds_rval::in, io::di, io::uo) is det.
:- pragma inline(pred(mlds_output_boxed_rval_uint64/5)).
mlds_output_boxed_rval_uint64(Opts, Stream, Rval, !IO) :-
io.write_string(Stream, "MR_box_uint64(", !IO),
mlds_output_rval(Opts, Rval, Stream, !IO),
io.write_string(Stream, ")", !IO).
:- pred mlds_output_boxed_rval_smaller_than_word(mlds_to_c_opts::in,
io.text_output_stream::in, mlds_rval::in, io::di, io::uo) is det.
:- pragma inline(pred(mlds_output_boxed_rval_smaller_than_word/5)).
mlds_output_boxed_rval_smaller_than_word(Opts, Stream, Rval, !IO) :-
% We cast first to MR_Word, and then to MR_Box.
% We do this to avoid spurious warnings from gcc about
% "cast from integer to pointer of different size".
io.write_string(Stream, "((MR_Box) (MR_Word) (", !IO),
mlds_output_rval(Opts, Rval, Stream, !IO),
io.write_string(Stream, "))", !IO).
:- pred mlds_output_boxed_rval_default(mlds_to_c_opts::in,
io.text_output_stream::in, mlds_rval::in, io::di, io::uo) is det.
:- pragma inline(pred(mlds_output_boxed_rval_default/5)).
mlds_output_boxed_rval_default(Opts, Stream, Rval, !IO) :-
io.write_string(Stream, "((MR_Box) (", !IO),
mlds_output_rval(Opts, Rval, Stream, !IO),
io.write_string(Stream, "))", !IO).
% Return `yes' if the specified rval is an address (possibly tagged and/or
% cast to a different type).
%
:- func is_an_address(mlds_rval) = bool.
is_an_address(Rval) = IsAddr :-
(
Rval = ml_mkword(_Ptag, SubRval),
IsAddr = is_an_address(SubRval)
;
Rval = ml_cast(_, SubRval),
IsAddr = is_an_address(SubRval)
;
( Rval = ml_mem_addr(_)
; Rval = ml_scalar_common_addr(_)
; Rval = ml_vector_common_row_addr(_, _)
),
IsAddr = yes
;
( Rval = ml_lval(_)
; Rval = ml_box(_, _)
; Rval = ml_unbox(_, _)
; Rval = ml_unop(_, _)
; Rval = ml_binop(_, _, _)
; Rval = ml_self(_)
; Rval = ml_scalar_common(_)
),
IsAddr = no
;
Rval = ml_const(Const),
(
( Const = mlconst_null(_)
; Const = mlconst_code_addr(_)
; Const = mlconst_data_addr_local_var(_)
; Const = mlconst_data_addr_global_var(_, _)
; Const = mlconst_data_addr_rtti(_, _)
; Const = mlconst_data_addr_tabling(_, _)
),
IsAddr = yes
;
( Const = mlconst_false
; Const = mlconst_true
; Const = mlconst_named_const(_, _)
; Const = mlconst_enum(_, _)
; Const = mlconst_char(_)
; Const = mlconst_string(_)
; Const = mlconst_multi_string(_)
; Const = mlconst_int(_)
; Const = mlconst_uint(_)
; Const = mlconst_int8(_)
; Const = mlconst_uint8(_)
; Const = mlconst_int16(_)
; Const = mlconst_uint16(_)
; Const = mlconst_int32(_)
; Const = mlconst_uint32(_)
; Const = mlconst_int64(_)
; Const = mlconst_uint64(_)
; Const = mlconst_float(_)
; Const = mlconst_foreign(_, _, _)
),
IsAddr = no
)
).
%---------------------%
:- pred mlds_output_unboxed_rval(mlds_to_c_opts::in, io.text_output_stream::in,
mlds_type::in, mlds_rval::in, io::di, io::uo) is det.
mlds_output_unboxed_rval(Opts, Stream, Type, Rval, !IO) :-
(
Type = mlds_builtin_type_float,
mlds_output_unboxed_rval_float(Opts, Stream, Rval, !IO)
;
( Type = mlds_native_bool_type
; Type = mlds_builtin_type_char
% ; Type = mlds_builtin_type_int(int_type_int) % XXX ARG_PACK
),
mlds_output_unboxed_rval_smaller_than_word(Opts, Stream,
Type, Rval, !IO)
;
( Type = mlds_builtin_type_string
; Type = mlds_array_type(_)
; Type = mlds_mercury_array_type(_)
; Type = mlds_mostly_generic_array_type(_)
; Type = mlds_class_type(_)
; Type = mlds_commit_type
; Type = mlds_cont_type(_)
; Type = mlds_foreign_type(_)
; Type = mlds_func_type(_)
; Type = mlds_generic_type
; Type = mlds_generic_env_ptr_type
; Type = mlds_pseudo_type_info_type
; Type = mlds_ptr_type(_)
; Type = mlds_rtti_type(_)
; Type = mlds_tabling_type(_)
; Type = mlds_type_info_type
; Type = mlds_unknown_type
),
mlds_output_unboxed_rval_default(Opts, Stream, Type, Rval, !IO)
;
Type = mlds_builtin_type_int(IntType),
(
IntType = int_type_int64,
mlds_output_unboxed_rval_int64(Opts, Stream, Rval, !IO)
;
IntType = int_type_uint64,
mlds_output_unboxed_rval_uint64(Opts, Stream, Rval, !IO)
;
( IntType = int_type_int
; IntType = int_type_uint
),
mlds_output_unboxed_rval_default(Opts, Stream, Type, Rval, !IO)
;
( IntType = int_type_int8
; IntType = int_type_uint8
; IntType = int_type_int16
; IntType = int_type_uint16
; IntType = int_type_int32
; IntType = int_type_uint32
),
% These integer types are all (potentially) smaller
% than MR_Word.
mlds_output_unboxed_rval_smaller_than_word(Opts, Stream,
Type, Rval, !IO)
)
;
Type = mercury_nb_type(MercuryType, _),
(
MercuryType = builtin_type(_BuiltinType),
unexpected($pred, "mercury_nb_type but builtin_type")
;
( MercuryType = type_variable(_, _)
; MercuryType = defined_type(_, _, _)
; MercuryType = tuple_type(_, _)
; MercuryType = higher_order_type(_, _, _, _, _)
; MercuryType = apply_n_type(_, _, _)
; MercuryType = kinded_type(_, _)
),
mlds_output_unboxed_rval_default(Opts, Stream, Type, Rval, !IO)
)
).
:- pred mlds_output_unboxed_rval_float(mlds_to_c_opts::in,
io.text_output_stream::in, mlds_rval::in, io::di, io::uo) is det.
:- pragma inline(pred(mlds_output_unboxed_rval_float/5)).
mlds_output_unboxed_rval_float(Opts, Stream, Rval, !IO) :-
io.write_string(Stream, "MR_unbox_float(", !IO),
mlds_output_rval(Opts, Rval, Stream, !IO),
io.write_string(Stream, ")", !IO).
:- pred mlds_output_unboxed_rval_int64(mlds_to_c_opts::in,
io.text_output_stream::in, mlds_rval::in, io::di, io::uo) is det.
:- pragma inline(pred(mlds_output_unboxed_rval_int64/5)).
mlds_output_unboxed_rval_int64(Opts, Stream, Rval, !IO) :-
io.write_string(Stream, "MR_unbox_int64(", !IO),
mlds_output_rval(Opts, Rval, Stream, !IO),
io.write_string(Stream, ")", !IO).
:- pred mlds_output_unboxed_rval_uint64(mlds_to_c_opts::in,
io.text_output_stream::in, mlds_rval::in, io::di, io::uo) is det.
:- pragma inline(pred(mlds_output_unboxed_rval_uint64/5)).
mlds_output_unboxed_rval_uint64(Opts, Stream, Rval, !IO) :-
io.write_string(Stream, "MR_unbox_uint64(", !IO),
mlds_output_rval(Opts, Rval, Stream, !IO),
io.write_string(Stream, ")", !IO).
:- pred mlds_output_unboxed_rval_smaller_than_word(mlds_to_c_opts::in,
io.text_output_stream::in, mlds_type::in, mlds_rval::in,
io::di, io::uo) is det.
:- pragma inline(pred(mlds_output_unboxed_rval_smaller_than_word/6)).
mlds_output_unboxed_rval_smaller_than_word(Opts, Stream, Type, Rval, !IO) :-
% We cast first to MR_Word, and then to the desired type.
% This is done to avoid spurious warnings from gcc about
% "cast from pointer to integer of different size".
% XXX ARG_PACK We call this predicate both too much and not enough.
% - We call it for builtin types that *may* be smaller than a word
% on some platforms, whether or not it is smaller than a word
% on *this* platform.
% - We do *not* call it values of dummy and enum types, which *are*
% smaller than a word.
CastStr = cast_to_prefix_string_for_c(Opts, Type),
io.format(Stream, "(%s", [s(CastStr)], !IO),
io.write_string(Stream, "(MR_Word) ", !IO),
mlds_output_rval(Opts, Rval, Stream, !IO),
io.write_string(Stream, ")", !IO).
:- pred mlds_output_unboxed_rval_default(mlds_to_c_opts::in,
io.text_output_stream::in, mlds_type::in, mlds_rval::in,
io::di, io::uo) is det.
:- pragma inline(pred(mlds_output_unboxed_rval_default/6)).
mlds_output_unboxed_rval_default(Opts, Stream, Type, Rval, !IO) :-
% XXX This does the same job as mlds_output_cast_rval, except for
% writing out an outer pair of parentheses.
CastStr = cast_to_prefix_string_for_c(Opts, Type),
io.format(Stream, "(%s(", [s(CastStr)], !IO),
mlds_output_rval(Opts, Rval, Stream, !IO),
io.write_string(Stream, "))", !IO).
%---------------------%
:- pred mlds_output_unop(mlds_to_c_opts::in, io.text_output_stream::in,
unary_op::in, mlds_rval::in, io::di, io::uo) is det.
mlds_output_unop(Opts, Stream, UnaryOp, Expr, !IO) :-
c_util.unary_prefix_op(UnaryOp, UnaryOpString),
io.format(Stream, "%s(", [s(UnaryOpString)], !IO),
( if UnaryOp = tag then
% The MR_tag macro requires its argument to be of type `MR_Word'.
% XXX Should we put this cast inside the definition of MR_tag?
io.write_string(Stream, "(MR_Word) ", !IO)
else
true
),
mlds_output_rval(Opts, Expr, Stream, !IO),
io.write_string(Stream, ")", !IO).
:- pred mlds_output_binop(mlds_to_c_opts::in, io.text_output_stream::in,
binary_op::in, mlds_rval::in, mlds_rval::in, io::di, io::uo) is det.
mlds_output_binop(Opts, Stream, Op, X, Y, !IO) :-
(
Op = array_index(_),
mlds_output_bracketed_rval(Opts, Stream, X, !IO),
io.write_string(Stream, "[", !IO),
mlds_output_rval(Opts, Y, Stream, !IO),
io.write_string(Stream, "]", !IO)
;
Op = string_unsafe_index_code_unit,
io.write_string(Stream, "MR_nth_code_unit(", !IO),
mlds_output_bracketed_rval(Opts, Stream, X, !IO),
io.write_string(Stream, ", ", !IO),
( if Y = ml_const(mlconst_int(YN)) then
io.write_int(Stream, YN, !IO)
else
mlds_output_rval(Opts, Y, Stream, !IO)
),
io.write_string(Stream, ")", !IO)
;
( Op = compound_lt
; Op = compound_eq
),
% These operators were intended to be generated only when using
% the now-deleted Erlang backend.
unexpected($pred, "compound_compare_binop")
;
Op = pointer_equal_conservative,
io.write_string(Stream, "(((MR_Word) ", !IO),
mlds_output_rval(Opts, X, Stream, !IO),
io.write_string(Stream, ") == ((MR_Word) ", !IO),
mlds_output_rval(Opts, Y, Stream, !IO),
io.write_string(Stream, "))", !IO)
;
( Op = str_eq, OpStr = "=="
; Op = str_ne, OpStr = "!="
; Op = str_le, OpStr = "<="
; Op = str_ge, OpStr = ">="
; Op = str_lt, OpStr = "<"
; Op = str_gt, OpStr = ">"
),
io.write_string(Stream, "(strcmp(", !IO),
mlds_output_rval(Opts, X, Stream, !IO),
io.write_string(Stream, ", ", !IO),
mlds_output_rval(Opts, Y, Stream, !IO),
io.format(Stream, ") %s 0)", [s(OpStr)], !IO)
;
( Op = float_eq, OpStr = "=="
; Op = float_ne, OpStr = "!="
; Op = float_le, OpStr = "<="
; Op = float_ge, OpStr = ">="
; Op = float_lt, OpStr = "<"
; Op = float_gt, OpStr = ">"
; Op = float_add, OpStr = "+"
; Op = float_sub, OpStr = "-"
; Op = float_mul, OpStr = "*"
; Op = float_div, OpStr = "/"
),
io.write_string(Stream, "(", !IO),
mlds_output_bracketed_rval(Opts, Stream, X, !IO),
io.format(Stream, " %s ", [s(OpStr)], !IO),
mlds_output_bracketed_rval(Opts, Stream, Y, !IO),
io.write_string(Stream, ")", !IO)
;
( Op = unsigned_lt, OpStr = "<"
; Op = unsigned_le, OpStr = "<="
),
io.write_string(Stream, "(((MR_Unsigned) ", !IO),
mlds_output_rval_as_unsigned_op_arg(Opts, Stream, 2147483647, X, !IO),
io.format(Stream, ") %s ((MR_Unsigned) ", [s(OpStr)], !IO),
mlds_output_rval_as_unsigned_op_arg(Opts, Stream, 2147483647, Y, !IO),
io.write_string(Stream, "))", !IO)
;
( Op = int_add(IntType), OpStr = "+"
; Op = int_sub(IntType), OpStr = "-"
; Op = int_mul(IntType), OpStr = "*"
),
(
% Max is the maximum signed integer of the given size
% that can be converted to the target unsigned type
% on all platforms.
(
IntType = int_type_int,
SignedType = "MR_Integer",
UnsignedType = "MR_Unsigned",
Max = 2147483647
;
IntType = int_type_int8,
SignedType = "int8_t",
UnsignedType = "uint8_t",
Max = 127
;
IntType = int_type_int16,
SignedType = "int16_t",
UnsignedType = "uint16_t",
Max = 32767
;
IntType = int_type_int32,
SignedType = "int32_t",
UnsignedType = "uint32_t",
Max = 2147483647
;
IntType = int_type_int64,
SignedType = "int64_t",
UnsignedType = "uint64_t",
Max = 2147483647 % for 32 bit platforms
),
io.format(Stream, "(%s) ((%s) ",
[s(SignedType), s(UnsignedType)], !IO),
mlds_output_rval_as_unsigned_op_arg(Opts, Stream, Max, X, !IO),
io.format(Stream, " %s (%s) ", [s(OpStr), s(UnsignedType)], !IO),
mlds_output_rval_as_unsigned_op_arg(Opts, Stream, Max, Y, !IO),
io.write_string(Stream, ")", !IO)
;
( IntType = int_type_uint
; IntType = int_type_uint8
; IntType = int_type_uint16
; IntType = int_type_uint32
; IntType = int_type_uint64
),
% We could treat X + (-const) specially, but we do not.
% The reason is documented in the equivalent code in
% llds_out_data.m.
io.write_string(Stream, "(", !IO),
mlds_output_rval_as_op_arg(Opts, Stream, X, !IO),
io.format(Stream, " %s ", [s(OpStr)], !IO),
mlds_output_rval_as_op_arg(Opts, Stream, Y, !IO),
io.write_string(Stream, ")", !IO)
)
;
( Op = int_div(_), OpStr = "/"
; Op = int_mod(_), OpStr = "%"
; Op = eq(_), OpStr = "=="
; Op = ne(_), OpStr = "!="
; Op = int_lt(_), OpStr = "<"
; Op = int_gt(_), OpStr = ">"
; Op = int_le(_), OpStr = "<="
; Op = int_ge(_), OpStr = ">="
; Op = bitwise_and(_), OpStr = "&"
; Op = bitwise_or(_), OpStr = "|"
; Op = bitwise_xor(_), OpStr = "^"
; Op = logical_and, OpStr = "&&"
; Op = logical_or, OpStr = "||"
),
% We could treat X + (-const) specially, but we do not.
% The reason is documented in the equivalent code in llds_out_data.m.
io.write_string(Stream, "(", !IO),
mlds_output_rval_as_op_arg(Opts, Stream, X, !IO),
io.format(Stream, " %s ", [s(OpStr)], !IO),
mlds_output_rval_as_op_arg(Opts, Stream, Y, !IO),
io.write_string(Stream, ")", !IO)
;
( Op = unchecked_left_shift(_, ShiftType), OpStr = "<<"
; Op = unchecked_right_shift(_, ShiftType), OpStr = ">>"
),
io.write_string(Stream, "(", !IO),
mlds_output_rval_as_op_arg(Opts, Stream, X, !IO),
io.format(Stream, " %s ", [s(OpStr)], !IO),
% Avoid clutter in the usual case that the shift amount
% is a small constant.
( if Y = ml_const(mlconst_int(YInt)) then
io.write_int(Stream, YInt, !IO)
else if Y = ml_const(mlconst_uint(YUInt)) then
io.write_uint(Stream, YUInt, !IO)
else
(
ShiftType = shift_by_int
;
ShiftType = shift_by_uint,
io.write_string(Stream, "(int) ", !IO)
),
mlds_output_rval_as_op_arg(Opts, Stream, Y, !IO)
),
io.write_string(Stream, ")", !IO)
;
Op = str_cmp,
io.write_string(Stream, "MR_strcmp(", !IO),
mlds_output_rval_as_op_arg(Opts, Stream, X, !IO),
io.write_string(Stream, ", ", !IO),
mlds_output_rval_as_op_arg(Opts, Stream, Y, !IO),
io.write_string(Stream, ")", !IO)
;
Op = offset_str_eq(N),
io.format(Stream, "MR_offset_streq(%d, ", [i(N)], !IO),
mlds_output_rval_as_op_arg(Opts, Stream, X, !IO),
io.write_string(Stream, ", ", !IO),
mlds_output_rval_as_op_arg(Opts, Stream, Y, !IO),
io.write_string(Stream, ")", !IO)
;
Op = body,
io.write_string(Stream, "MR_body(", !IO),
mlds_output_rval_as_op_arg(Opts, Stream, X, !IO),
io.write_string(Stream, ", ", !IO),
mlds_output_rval_as_op_arg(Opts, Stream, Y, !IO),
io.write_string(Stream, ")", !IO)
;
( Op = float_from_dword, OpStr = "MR_float_from_dword"
; Op = int64_from_dword, OpStr = "MR_int64_from_dword"
; Op = uint64_from_dword, OpStr = "MR_uint64_from_dword"
),
( if is_aligned_dword_field(X, Y, PtrRval) then
% gcc produces faster code in this case.
io.format(Stream, "%s_ptr(MR_dword_ptr(", [s(OpStr)], !IO),
mlds_output_rval(Opts, PtrRval, Stream, !IO),
io.write_string(Stream, "))", !IO)
else
io.format(Stream, "%s(", [s(OpStr)], !IO),
mlds_output_rval_as_op_arg(Opts, Stream, X, !IO),
io.write_string(Stream, ", ", !IO),
mlds_output_rval_as_op_arg(Opts, Stream, Y, !IO),
io.write_string(Stream, ")", !IO)
)
).
% mlds_output_rval_as_unsigned_op_arg(Opts, Stream, Max, Rval, !IO):
%
% If Rval is a signed or unsigned integer constant in [0 .. Max],
% the write out its value without casting it; it will be cast
% to the right unsigned type by our caller. Otherwise, write it out
% with whatever intermediate casts our general rules require for it.
% These intermediate casts will usually be redundant in a context
% in which the Rval is immediately cast to a different type.
% The avoidance of these redundant casts when possible is the
% purpose of this predicate.
%
:- pred mlds_output_rval_as_unsigned_op_arg(mlds_to_c_opts::in,
io.text_output_stream::in, int::in, mlds_rval::in, io::di, io::uo) is det.
mlds_output_rval_as_unsigned_op_arg(Opts, Stream, Max, Rval, !IO) :-
( if Rval = ml_const(Const) then
( if
% The argument of an mlconst_int64 may not fit inside an int.
(
Const = mlconst_int(Int),
Int >= 0
;
Const = mlconst_int8(Int8),
Int8 >= 0i8,
Int = int8.cast_to_int(Int8)
;
Const = mlconst_int16(Int16),
Int16 >= 0i16,
Int = int16.cast_to_int(Int16)
;
Const = mlconst_int32(Int32),
Int32 >= 0i32,
Int = int32.cast_to_int(Int32)
),
Int =< Max
then
io.write_int(Stream, Int, !IO)
else if
% The argument of an mlconst_uint64 may not fit in an uint.
% We do the tests separately from the ints because a uint
% may not fit in an int either.
(
Const = mlconst_uint(Uint)
;
Const = mlconst_uint8(Uint8),
Uint = uint8.cast_to_uint(Uint8)
;
Const = mlconst_uint16(Uint16),
Uint = uint16.cast_to_uint(Uint16)
;
Const = mlconst_uint32(Uint32),
Uint = uint32.cast_to_uint(Uint32)
),
Uint =< uint.cast_from_int(Max)
then
io.write_uint(Stream, Uint, !IO)
else
mlds_output_rval_as_op_arg(Opts, Stream, Rval, !IO)
)
else
mlds_output_rval_as_op_arg(Opts, Stream, Rval, !IO)
).
:- pred mlds_output_rval_as_op_arg(mlds_to_c_opts::in,
io.text_output_stream::in, mlds_rval::in, io::di, io::uo) is det.
mlds_output_rval_as_op_arg(Opts, Stream, Rval, !IO) :-
( if
( Rval = ml_unop(_, _)
; Rval = ml_binop(_, _, _)
)
then
io.write_string(Stream, "(", !IO),
mlds_output_rval(Opts, Rval, Stream, !IO),
io.write_string(Stream, ")", !IO)
else
mlds_output_rval(Opts, Rval, Stream, !IO)
).
%---------------------%
:- pred mlds_output_rval_const(mlds_to_c_opts::in, io.text_output_stream::in,
mlds_rval_const::in, io::di, io::uo) is det.
mlds_output_rval_const(_Opts, Stream, Const, !IO) :-
(
Const = mlconst_true,
io.write_string(Stream, "MR_TRUE", !IO)
;
Const = mlconst_false,
io.write_string(Stream, "MR_FALSE", !IO)
;
( Const = mlconst_int(N)
; Const = mlconst_enum(N, _)
),
c_util.output_int_expr(Stream, N, !IO)
;
Const = mlconst_uint(U),
c_util.output_uint_expr(Stream, U, !IO)
;
Const = mlconst_int8(N),
c_util.output_int8_expr(Stream, N, !IO)
;
Const = mlconst_uint8(N),
c_util.output_uint8_expr(Stream, N, !IO)
;
Const = mlconst_int16(N),
c_util.output_int16_expr(Stream, N, !IO)
;
Const = mlconst_uint16(N),
c_util.output_uint16_expr(Stream, N, !IO)
;
Const = mlconst_int32(N),
c_util.output_int32_expr(Stream, N, !IO)
;
Const = mlconst_uint32(N),
c_util.output_uint32_expr(Stream, N, !IO)
;
Const = mlconst_int64(N),
c_util.output_int64_expr(Stream, N, !IO)
;
Const = mlconst_uint64(N),
c_util.output_uint64_expr(Stream, N, !IO)
;
Const = mlconst_char(C),
io.format(Stream, "(MR_Char) %d", [i(C)], !IO)
;
Const = mlconst_foreign(Lang, Value, _Type),
expect(unify(Lang, lang_c), $pred,
"mlconst_foreign for language other than C"),
io.format(Stream, "((int) %s)", [s(Value)], !IO)
;
Const = mlconst_float(FloatVal),
% The cast to (MR_Float) here lets the C compiler do arithmetic in
% `float' rather than `double' if `MR_Float' is `float' not `double'.
io.write_string(Stream, "(MR_Float) ", !IO),
c_util.output_float_literal(Stream, FloatVal, !IO)
;
Const = mlconst_string(String),
% The cast avoids the following gcc warning
% "assignment discards qualifiers from pointer target type".
io.write_string(Stream, "(MR_String) ", !IO),
output_quoted_string_c(Stream, String, !IO)
;
Const = mlconst_multi_string(String),
output_quoted_multi_string_c(Stream, String, !IO)
;
Const = mlconst_named_const(_TargetPrefixes, NamedConst),
% The target prefix for C is implicitly always empty.
io.write_string(Stream, NamedConst, !IO)
;
Const = mlconst_code_addr(CodeAddr),
mlds_output_code_addr(Stream, CodeAddr, !IO)
;
Const = mlconst_data_addr_local_var(LocalVarName),
MangledLocalVarName =
name_mangle(ml_local_var_name_to_string(LocalVarName)),
io.format(Stream, "&%s", [s(MangledLocalVarName)], !IO)
;
(
Const =
mlconst_data_addr_global_var(MLDS_ModuleName, GlobalVarName),
IsArray = not_array
;
Const = mlconst_data_addr_rtti(MLDS_ModuleName, RttiId),
GlobalVarName = gvn_rtti_var(RttiId),
IsArray = rtti_id_has_array_type(RttiId)
;
Const = mlconst_data_addr_tabling(QualProcLabel, TablingId),
QualProcLabel = qual_proc_label(MLDS_ModuleName, ProcLabel),
GlobalVarName = gvn_tabling_var(ProcLabel, TablingId),
IsArray = tabling_id_has_array_type(TablingId)
),
% If it is an array type, then we just use the name;
% otherwise, we must prefix the name with `&'.
QualGlobalVarNameStr = maybe_qual_global_var_name_to_string_for_c(
MLDS_ModuleName, GlobalVarName),
(
IsArray = is_array,
io.format(Stream, "%s", [s(QualGlobalVarNameStr)], !IO)
;
IsArray = not_array,
io.format(Stream, "&%s", [s(QualGlobalVarNameStr)], !IO)
)
;
Const = mlconst_null(MLDS_Type),
( if MLDS_Type = mlds_builtin_type_float then
io.write_string(Stream, "0.0", !IO)
else
io.write_string(Stream, "NULL", !IO)
)
).
:- pred is_aligned_dword_field(mlds_rval::in, mlds_rval::in, mlds_rval::out)
is semidet.
is_aligned_dword_field(RvalX, RvalY, ml_mem_addr(LvalX)) :-
RvalX = ml_lval(LvalX),
RvalY = ml_lval(LvalY),
LvalX = ml_field(Ptag, PtrRval, PtrType, FieldIdX, FieldType),
LvalY = ml_field(Ptag, PtrRval, PtrType, FieldIdY, FieldType),
FieldIdX = ml_field_offset(ml_const(mlconst_int(Offset))),
FieldIdY = ml_field_offset(ml_const(mlconst_int(Offset + 1))),
int.even(Offset).
:- pred mlds_output_code_addr(io.text_output_stream::in, mlds_code_addr::in,
io::di, io::uo) is det.
mlds_output_code_addr(Stream, CodeAddr, !IO) :-
CodeAddr = mlds_code_addr(QualFuncLabel, _Signature),
QualFuncLabel = qual_func_label(ModuleName, FuncLabel),
FuncLabel = mlds_func_label(ProcLabel, MaybeAux),
QualProcLabel = qual_proc_label(ModuleName, ProcLabel),
QualProcLabelStr = qual_proc_label_to_string_for_c(QualProcLabel),
MaybeAuxSuffix = mlds_maybe_aux_func_id_to_suffix(MaybeAux),
io.format(Stream, "%s%s", [s(QualProcLabelStr), s(MaybeAuxSuffix)], !IO).
%---------------------------------------------------------------------------%
mlds_output_initializer(Opts, Stream, _Type, Initializer, !IO) :-
NeedsInit = mlds_needs_initialization(Initializer),
(
NeedsInit = yes,
io.write_string(Stream, " = ", !IO),
mlds_output_initializer_body(Opts, Stream, 0, Initializer, !IO)
;
NeedsInit = no
).
:- func mlds_needs_initialization(mlds_initializer) = bool.
mlds_needs_initialization(no_initializer) = no.
mlds_needs_initialization(init_obj(_)) = yes.
mlds_needs_initialization(init_struct(_Type, [])) = no.
mlds_needs_initialization(init_struct(_Type, [_|_])) = yes.
mlds_needs_initialization(init_array(_)) = yes.
mlds_output_initializer_body(Opts, Stream, Indent, Initializer, !IO) :-
(
Initializer = no_initializer
;
Initializer = init_obj(Rval),
write_indent2(Stream, Indent, !IO),
mlds_output_rval(Opts, Rval, Stream, !IO)
;
( Initializer = init_struct(_Type, Inits)
; Initializer = init_array(Inits)
),
IndentStr = indent2_string(Indent),
(
Inits = [],
(
Initializer = init_struct(_, _),
% Note that standard ANSI/ISO C does not allow empty structs,
% and it is the responsibility of the MLDS code generator
% to not generate any such structs.
unexpected($pred, "field initializers = []")
;
Initializer = init_array(_),
% Standard ANSI/ISO C does not allow empty arrays, but
% the MLDS does. To keep the C compiler happy, we therefore
% convert zero-element MLDS arrays into one-element C arrays.
% (The extra element is a minor waste of space, but it will
% otherwise be ignored.) So if the initializer list here
% is empty, we need to output a single initializer.
% We can initialize the extra element with any value.
% We use "0", since that is a valid initializer for any type.
io.format(Stream, "%s{ 0 }\n", [s(IndentStr)], !IO)
)
;
Inits = [HeadInit | TailInits],
(
TailInits = [],
% We write the single init on a single line, if we can.
(
( HeadInit = no_initializer
; HeadInit = init_obj(_)
),
% We can.
io.format(Stream, "%s{ ", [s(IndentStr)], !IO),
mlds_output_initializer_body(Opts, Stream, 0,
HeadInit, !IO),
io.write_string(Stream, " }", !IO)
;
( HeadInit = init_struct(_, _)
; HeadInit = init_array(_)
),
% We probably can't: printing HeadInit by itself may need
% more than one line.
io.format(Stream, "%s{\n", [s(IndentStr)], !IO),
mlds_output_initializer_body(Opts, Stream, Indent + 1,
HeadInit, !IO),
io.format(Stream, "\n%s}", [s(IndentStr)], !IO)
)
;
TailInits = [_ | _],
% We write the N inits on N+2 lines.
io.format(Stream, "%s{\n", [s(IndentStr)], !IO),
mlds_output_initializer_bodies(Opts, Stream, Indent + 1,
HeadInit, TailInits, !IO),
io.format(Stream, "%s}", [s(IndentStr)], !IO)
)
)
).
:- pred mlds_output_initializer_bodies(mlds_to_c_opts::in,
io.text_output_stream::in, int::in,
mlds_initializer::in, list(mlds_initializer)::in, io::di, io::uo) is det.
mlds_output_initializer_bodies(Opts, Stream, Indent,
HeadInit, TailInits, !IO) :-
mlds_output_initializer_body(Opts, Stream, Indent, HeadInit, !IO),
(
TailInits = [],
io.write_string(Stream, "\n", !IO)
;
TailInits = [HeadTailInit | TailTailInits],
io.write_string(Stream, ",\n", !IO),
mlds_output_initializer_bodies(Opts, Stream, Indent,
HeadTailInit, TailTailInits, !IO)
).
%---------------------------------------------------------------------------%
:- end_module ml_backend.mlds_to_c_data.
%---------------------------------------------------------------------------%
Reference in New Issue View Git Blame Copy Permalink