mercurylang/mercury
1
0
Fork 0
mirror of https://github.com/Mercury-Language/mercury.git synced 2026-04-16 18:03:36 +00:00
Code Issues Projects Releases Wiki Activity
Files
b357a3dadcdf29c8d8ca184d65f7634a1a94de36
mercury/compiler/mlds_dump.m
Zoltan Somogyi 304daa2057 Delete the mlds_class_kind type. 
compiler/mlds.m:
    Delete the mlds_class_kind type, because

    - after the simplification of mlds_interface_ids, its mlds_interface
      function symbol became unused, and

    - after the deleting of that function symbol, it would have become
      a dummy type anyway.

    Delete mlds_class_kind fields from the mlds_class_defn and mlds_class_id
    types.

compiler/mlds_to_cs_class.m:
    Conform to the changes above.

    Inline two predicates, and simplify the resulting code.

compiler/ml_code_util.m:
compiler/ml_rename_classes.m:
compiler/ml_type_gen.m:
compiler/ml_unify_gen_construct.m:
compiler/ml_unify_gen_util.m:
compiler/mlds_dump.m:
compiler/mlds_to_c_class.m:
compiler/mlds_to_c_type.m:
compiler/mlds_to_cs_type.m:
compiler/mlds_to_java_class.m:
compiler/mlds_to_java_type.m:
compiler/mlds_to_java_wrap.m:
compiler/mlds_to_target_util.m:
    Conform to the changes above.
2023-07-16 17:40:48 +02:00

1483 lines
50 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.
%---------------------------------------------------------------------------%
%
% This module dumps out MLDS code in a form designed to help debug
% MLDS code generation and optimization, by making MLDS code fragments
% as easy to understand as possible. To this end, the output generated
% by this module
%
% - intentionally omits details that are only rarely relevant during
% such debugging, and
%
% - presents the remaining details in a very direct, simple and unambiguous
% format that is not constrained by the syntax of any actual programming
% language.
%
%---------------------------------------------------------------------------%
:- module ml_backend.mlds_dump.
:- interface.
:- import_module ml_backend.mlds.
:- import_module io.
:- pred dump_mlds_stmt(io.text_output_stream::in, int::in, mlds_stmt::in,
io::di, io::uo) is det.
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
:- implementation.
:- import_module backend_libs.
:- import_module backend_libs.builtin_ops.
:- import_module hlds.
:- import_module hlds.hlds_data.
:- import_module hlds.hlds_pred.
:- import_module mdbcomp.
:- import_module mdbcomp.prim_data.
:- import_module mdbcomp.sym_name.
:- import_module parse_tree.
:- import_module parse_tree.prog_data.
:- import_module bool.
:- import_module cord.
:- import_module int.
:- import_module list.
:- import_module maybe.
:- import_module require.
:- import_module string.
:- import_module term.
:- import_module uint8.
%---------------------------------------------------------------------------%
:- type strcord == cord(string).
:- func strcord_to_string(strcord) = string.
strcord_to_string(Cord) = string.append_list(cord.to_list(Cord)).
%---------------------------------------------------------------------------%
dump_mlds_stmt(Stream, Indent, Stmt, !IO) :-
Cord = mlds_stmt_to_strcord(Indent, Stmt),
io.write_string(Stream, strcord_to_string(Cord), !IO).
%---------------------------------------------------------------------------%
:- func mlds_stmts_to_strcord(int, list(mlds_stmt)) = strcord.
mlds_stmts_to_strcord(_Indent, []) = cord.init.
mlds_stmts_to_strcord(Indent, [Stmt | Stmts]) =
mlds_stmt_to_strcord(Indent, Stmt) ++
mlds_stmts_to_strcord(Indent, Stmts).
:- func mlds_stmt_to_strcord(int, mlds_stmt) = strcord.
mlds_stmt_to_strcord(Indent, Stmt) = Cord :-
(
Stmt = ml_stmt_block(LocalVarDefns, FuncDefns, SubStmts, _Context),
(
LocalVarDefns = [],
LocalVarsCord = cord.init
;
LocalVarDefns = [_ | _],
LocalVarsCord =
mlds_local_var_defns_to_strcord(Indent + 1, LocalVarDefns) ++
nl_strcord
),
(
FuncDefns = [],
FuncsCord = cord.init
;
FuncDefns = [_ | _],
FuncsCord =
mlds_function_defns_to_strcord(Indent + 1, FuncDefns) ++
nl_strcord
),
Cord =
indent_strcord(Indent) ++ strcord("block start\n") ++
LocalVarsCord ++
FuncsCord ++
mlds_stmts_to_strcord(Indent + 1, SubStmts) ++
indent_strcord(Indent) ++ strcord("block end\n")
;
Stmt = ml_stmt_while(Kind, Rval, SubStmt, LocalLoopVars, _Context),
(
LocalLoopVars = [],
LocalLoopVarsCord = cord.init
;
LocalLoopVars = [_ | _],
LocalLoopVarsCord =
indent_strcord(Indent) ++ strcord("loop local vars ") ++
strcord(string.join_list(", ",
list.map(ml_local_var_name_to_string, LocalLoopVars))) ++
nl_strcord
),
(
Kind = may_loop_zero_times,
Cord =
indent_strcord(Indent) ++ strcord("while ") ++
mlds_rval_to_strcord(Rval) ++ nl_strcord ++
mlds_stmt_to_strcord(Indent + 1, SubStmt) ++
indent_strcord(Indent) ++ strcord("end while\n") ++
LocalLoopVarsCord
;
Kind = loop_at_least_once,
Cord =
indent_strcord(Indent) ++ strcord("do\n") ++
mlds_stmt_to_strcord(Indent + 1, SubStmt) ++
indent_strcord(Indent) ++ strcord("while ") ++
mlds_rval_to_strcord(Rval) ++ nl_strcord ++
LocalLoopVarsCord
)
;
Stmt = ml_stmt_if_then_else(Cond, Then, MaybeElse, _Context),
(
MaybeElse = yes(Else),
Cord =
indent_strcord(Indent) ++ strcord("if ") ++
mlds_rval_to_strcord(Cond) ++ nl_strcord ++
indent_strcord(Indent) ++ strcord("then\n") ++
mlds_stmt_to_strcord(Indent + 1, Then) ++
indent_strcord(Indent) ++ strcord("else\n") ++
mlds_stmt_to_strcord(Indent + 1, Else) ++
indent_strcord(Indent) ++ strcord("end if\n")
;
MaybeElse = no,
Cord =
indent_strcord(Indent) ++ strcord("if ") ++
mlds_rval_to_strcord(Cond) ++ nl_strcord ++
indent_strcord(Indent) ++ strcord("then\n") ++
mlds_stmt_to_strcord(Indent + 1, Then) ++
indent_strcord(Indent) ++ strcord("end if\n")
)
;
Stmt = ml_stmt_switch(Type, Rval, Range, Cases, Default, _Context),
(
Range = mlds_switch_range_unknown,
RangeCord = cord.init
;
Range = mlds_switch_range(Min, Max),
RangeCord =
strcord(" from ") ++ intcord(Min) ++
strcord(" to ") ++ intcord(Max)
),
Cord =
indent_strcord(Indent) ++ strcord("switch ") ++
strcord("(") ++ mlds_rval_to_strcord(Rval) ++ strcord(")") ++
mlds_type_to_strcord(Type) ++ RangeCord ++ nl_strcord ++
cord_list_to_cord(
list.map(mlds_switch_case_to_strcord(Indent + 1), Cases)) ++
mlds_switch_default_to_strcord(Indent + 1, Default) ++
indent_strcord(Indent) ++ strcord("end switch\n")
;
Stmt = ml_stmt_label(mlds_label(LabelName), _Context),
Cord =
indent_strcord(Indent) ++ strcord("label ") ++
strcord(LabelName) ++ nl_strcord
;
Stmt = ml_stmt_goto(Target, _Context),
Cord =
indent_strcord(Indent) ++ strcord("goto ") ++
mlds_goto_target_to_strcord(Target) ++ nl_strcord
;
Stmt = ml_stmt_computed_goto(Rval, Labels, _Context),
Cord =
indent_strcord(Indent) ++ strcord("computed goto ") ++
strcord("(") ++ mlds_rval_to_strcord(Rval) ++ strcord(")") ++
nl_strcord ++
mlds_computed_goto_labels_to_strcord(Indent, 0, Labels)
;
Stmt = ml_stmt_call(_Sig, FuncRval, ArgRvals, RetLvals, TailCall,
_Context),
(
TailCall = no_return_call,
CallCord = strcord("no_return_call ")
;
TailCall = tail_call,
CallCord = strcord("tail_call ")
;
TailCall = ordinary_call,
CallCord = strcord("call ")
),
(
ArgRvals = [],
ArgsCord = cord.init
;
ArgRvals = [HeadArgRval | TailArgRvals],
ArgsCord = strcord("(") ++
mlds_rvals_to_strcord(HeadArgRval, TailArgRvals) ++
strcord(")")
),
(
RetLvals = [],
RetCord = cord.init
;
RetLvals = [HeadRetLval | TailRetLvals],
RetCord = strcord(" -> (") ++
mlds_lvals_to_strcord(HeadRetLval, TailRetLvals) ++
strcord(")")
),
Cord =
indent_strcord(Indent) ++ CallCord ++
mlds_rval_to_strcord(FuncRval) ++ ArgsCord ++ RetCord
;
Stmt = ml_stmt_return(Rvals, _Context),
(
Rvals = [],
Cord =
indent_strcord(Indent) ++ strcord("return")
;
Rvals = [HeadRval | TailRvals],
Cord =
indent_strcord(Indent) ++ strcord("return ") ++
mlds_rvals_to_strcord(HeadRval, TailRvals)
)
;
Stmt = ml_stmt_try_commit(RefLval, BodyStmt, HandlerStmt, _Context),
Cord =
indent_strcord(Indent) ++ strcord("try_commit ") ++
mlds_lval_to_strcord(RefLval) ++ nl_strcord ++
indent_strcord(Indent) ++ strcord("stmt to try\n") ++
mlds_stmt_to_strcord(Indent + 1, BodyStmt) ++
indent_strcord(Indent) ++ strcord("commit handler stmt\n") ++
mlds_stmt_to_strcord(Indent + 1, HandlerStmt) ++
indent_strcord(Indent) ++ strcord("end_try_commit\n")
;
Stmt = ml_stmt_do_commit(RefRval, _Context),
Cord =
indent_strcord(Indent) ++ strcord("do_commit ") ++
mlds_rval_to_strcord(RefRval)
;
Stmt = ml_stmt_atomic(AtomicStmt, _Context),
Cord = mlds_atomic_stmt_to_strcord(Indent, AtomicStmt)
).
:- func mlds_switch_case_to_strcord(int, mlds_switch_case) = strcord.
mlds_switch_case_to_strcord(Indent, Case) = Cord :-
Case = mlds_switch_case(FirstCond, LaterConds, Stmt),
Cord =
mlds_case_match_cond_to_strcord(Indent, FirstCond) ++
cord_list_to_cord(
list.map(mlds_case_match_cond_to_strcord(Indent), LaterConds)) ++
mlds_stmt_to_strcord(Indent + 1, Stmt).
:- func mlds_case_match_cond_to_strcord(int, mlds_case_match_cond) = strcord.
mlds_case_match_cond_to_strcord(Indent, Cond) = Cord :-
(
Cond = match_value(Rval),
Cord =
indent_strcord(Indent) ++ strcord("match value ") ++
mlds_rval_to_strcord(Rval) ++ nl_strcord
;
Cond = match_range(MinRval, MaxRval),
Cord =
indent_strcord(Indent) ++ strcord("match range ") ++
mlds_rval_to_strcord(MinRval) ++ strcord(" to ") ++
mlds_rval_to_strcord(MaxRval) ++ nl_strcord
).
:- func mlds_switch_default_to_strcord(int, mlds_switch_default) = strcord.
mlds_switch_default_to_strcord(Indent, Default) = Cord :-
(
Default = default_is_unreachable,
Cord = indent_strcord(Indent) ++ strcord("default is unreachable\n")
;
Default = default_do_nothing,
Cord = indent_strcord(Indent) ++ strcord("default is do nothing\n")
;
Default = default_case(Stmt),
Cord =
indent_strcord(Indent) ++ strcord("default statement:\n") ++
mlds_stmt_to_strcord(Indent + 1, Stmt)
).
:- func mlds_goto_target_to_strcord(mlds_goto_target) = strcord.
mlds_goto_target_to_strcord(Target) = Cord :-
(
Target = goto_label(mlds_label(LabelName)),
Cord = strcord(LabelName)
;
Target = goto_break_switch,
Cord = strcord("break_switch")
;
Target = goto_break_loop,
Cord = strcord("break_loop")
;
Target = goto_continue_loop,
Cord = strcord("continue_loop")
).
:- func mlds_computed_goto_labels_to_strcord(int, int, list(mlds_label))
= strcord.
mlds_computed_goto_labels_to_strcord(_Indent, _Index, []) = cord.init.
mlds_computed_goto_labels_to_strcord(Indent, Index,
[mlds_label(LabelName) | Labels]) =
indent_strcord(Indent) ++ intcord(Index) ++ strcord(": ") ++
strcord(LabelName) ++ nl_strcord ++
mlds_computed_goto_labels_to_strcord(Indent, Index + 1, Labels).
:- func mlds_atomic_stmt_to_strcord(int, mlds_atomic_statement) = strcord.
mlds_atomic_stmt_to_strcord(Indent, AtomicStmt) = Cord :-
(
AtomicStmt = comment(Comment0),
string.replace_all(Comment0, "\n", " ", Comment),
Cord = indent_strcord(Indent) ++ strcord(Comment) ++ nl_strcord
;
AtomicStmt = gc_check,
Cord = indent_strcord(Indent) ++ strcord("gc_check\n")
;
AtomicStmt = assign(Lval, Rval),
Cord =
indent_strcord(Indent) ++ mlds_lval_to_strcord(Lval) ++
strcord(" := ") ++ mlds_rval_to_strcord(Rval) ++ nl_strcord
;
AtomicStmt = assign_if_in_heap(Lval, Rval),
Cord =
indent_strcord(Indent) ++ mlds_lval_to_strcord(Lval) ++
strcord(" ?:= ") ++ mlds_rval_to_strcord(Rval) ++ nl_strcord
;
AtomicStmt = delete_object(Rval),
Cord =
indent_strcord(Indent) ++ strcord("delete object ") ++
mlds_rval_to_strcord(Rval) ++ nl_strcord
;
AtomicStmt = new_object(Target, Ptag, ExplicitSecTag, Type,
MaybeSize, _MaybeCtorName, _ArgRvalsTypes, _MayUseAtomic,
_MaybeAllocId),
(
ExplicitSecTag = no,
SecTagCord = strcord("no explicit sectag")
;
ExplicitSecTag = yes,
SecTagCord = strcord("explicit sectag")
),
(
MaybeSize = no,
SizeCord = strcord("no size")
;
MaybeSize = yes(Size),
SizeCord = mlds_rval_to_strcord(Size) ++ strcord(" words")
),
Cord =
indent_strcord(Indent) ++ mlds_lval_to_strcord(Target) ++
strcord(" := new object(ptag ") ++ ptag_to_strcord(Ptag) ++
comma_cord ++ SecTagCord ++ comma_cord ++ SizeCord ++
comma_cord ++ mlds_type_to_strcord(Type) ++ strcord(")") ++
nl_strcord
;
AtomicStmt = mark_hp(Lval),
Cord =
indent_strcord(Indent) ++ strcord("mark_hp ") ++
mlds_lval_to_strcord(Lval) ++ nl_strcord
;
AtomicStmt = restore_hp(Rval),
Cord =
indent_strcord(Indent) ++ strcord("restore_hp ") ++
mlds_rval_to_strcord(Rval) ++ nl_strcord
;
AtomicStmt = trail_op(TrailOp),
(
TrailOp = store_ticket(Lval),
Cord =
indent_strcord(Indent) ++ strcord("store_ticket ") ++
mlds_lval_to_strcord(Lval) ++ nl_strcord
;
TrailOp = reset_ticket(Rval, Reason),
(
Reason = undo,
ReasonCord = strcord("undo ")
;
Reason = commit,
ReasonCord = strcord("commit ")
;
Reason = solve,
ReasonCord = strcord("solve ")
;
Reason = exception,
ReasonCord = strcord("exception ")
;
Reason = gc,
ReasonCord = strcord("gc ")
),
Cord =
indent_strcord(Indent) ++ strcord("reset_ticket for ") ++
ReasonCord ++ mlds_rval_to_strcord(Rval) ++ nl_strcord
;
TrailOp = discard_ticket,
Cord =
indent_strcord(Indent) ++ strcord("discard_ticket") ++
nl_strcord
;
TrailOp = prune_ticket,
Cord =
indent_strcord(Indent) ++ strcord("prune_ticket") ++
nl_strcord
;
TrailOp = mark_ticket_stack(Lval),
Cord =
indent_strcord(Indent) ++ strcord("mark_ticket_stack ") ++
mlds_lval_to_strcord(Lval) ++ nl_strcord
;
TrailOp = prune_tickets_to(Rval),
Cord =
indent_strcord(Indent) ++ strcord("prune_tickets_to ") ++
mlds_rval_to_strcord(Rval) ++ nl_strcord
)
;
AtomicStmt = inline_target_code(_Lang, Components),
Cord =
indent_strcord(Indent) ++ strcord("inline_target_code\n") ++
cord_list_to_cord(
list.map(target_code_component_to_strcord(Indent + 1),
Components)) ++
indent_strcord(Indent) ++ strcord("end inline_target_code\n")
;
AtomicStmt = outline_foreign_proc(_Lang, OutlineArgs, ReturnLvals,
Code),
(
ReturnLvals = [],
ReturnCord =
indent_strcord(Indent + 1) ++ strcord("no return lvals\n")
;
ReturnLvals = [HeadLval | TailLvals],
ReturnCord =
indent_strcord(Indent + 1) ++ strcord("return lvals ") ++
mlds_lvals_to_strcord(HeadLval, TailLvals) ++ nl_strcord
),
Cord =
indent_strcord(Indent) ++ strcord("inline_target_code\n") ++
cord_list_to_cord(
list.map(outline_arg_to_strcord(Indent + 1),
OutlineArgs)) ++
ReturnCord ++
indent_strcord(Indent + 1) ++ strcord("code\n") ++
strcord(Code) ++
indent_strcord(Indent) ++ strcord("end inline_target_code\n")
).
:- func target_code_component_to_strcord(int, target_code_component) = strcord.
target_code_component_to_strcord(Indent, Component) = Cord :-
(
Component = user_target_code(Code, _Context),
Cord =
indent_strcord(Indent) ++ strcord("user_target_code") ++
nl_strcord ++
strcord(Code) ++ nl_strcord
;
Component = raw_target_code(Code),
Cord =
indent_strcord(Indent) ++ strcord("raw_target_code") ++
nl_strcord ++
strcord(Code) ++ nl_strcord
;
Component = target_code_input(Rval),
Cord =
indent_strcord(Indent) ++ strcord("input ") ++
mlds_rval_to_strcord(Rval) ++ nl_strcord
;
Component = target_code_output(Lval),
Cord =
indent_strcord(Indent) ++ strcord("output ") ++
mlds_lval_to_strcord(Lval) ++ nl_strcord
;
Component = target_code_type(Type),
Cord =
indent_strcord(Indent) ++ strcord("type ") ++
mlds_type_to_strcord(Type) ++ nl_strcord
;
Component = target_code_function_name(_QualFuncName),
Cord = cord.init
;
Component = target_code_alloc_id(_AllocId),
Cord = cord.init
).
:- func outline_arg_to_strcord(int, outline_arg) = strcord.
outline_arg_to_strcord(Indent, OutlineArg) = Cord :-
(
OutlineArg = ola_in(Type, Name, Rval),
Cord =
indent_strcord(Indent) ++ strcord("input ") ++
mlds_type_to_strcord(Type) ++ strcord(" ") ++
strcord(Name) ++ strcord(" <= ") ++
mlds_rval_to_strcord(Rval) ++ nl_strcord
;
OutlineArg = ola_out(Type, Name, Lval),
Cord =
indent_strcord(Indent) ++ strcord("output ") ++
mlds_type_to_strcord(Type) ++ strcord(" ") ++
strcord(Name) ++ strcord(" => ") ++
mlds_lval_to_strcord(Lval) ++ nl_strcord
;
OutlineArg = ola_unused,
Cord =
indent_strcord(Indent) ++ strcord("unused\n")
).
%---------------------------------------------------------------------------%
:- func mlds_lvals_to_strcord(mlds_lval, list(mlds_lval)) = strcord.
mlds_lvals_to_strcord(HeadLval, TailLvals) = Cord :-
(
TailLvals = [],
Cord = mlds_lval_to_strcord(HeadLval)
;
TailLvals = [HeadTailLval | TailTailLvals],
Cord = mlds_lval_to_strcord(HeadLval) ++ comma_cord ++
mlds_lvals_to_strcord(HeadTailLval, TailTailLvals)
).
:- func mlds_lval_to_strcord(mlds_lval) = strcord.
mlds_lval_to_strcord(Lval) = Cord :-
(
Lval = ml_local_var(LocalVar, _Type),
Cord = strcord(ml_local_var_name_to_string(LocalVar))
;
Lval = ml_global_var(QualGlobalVar, _Type),
QualGlobalVar = qual_global_var_name(_ModuleName, GlobalVar),
(
GlobalVar = gvn_rtti_var(_RttiId),
Cord = strcord("rtti_id")
;
GlobalVar = gvn_tabling_var(_, _),
Cord = strcord("tabling_var")
;
GlobalVar = gvn_const_var(GlobalConstVar, SeqNum),
(
GlobalConstVar = mgcv_const_var,
GlobalCord = strcord("global const var ")
;
GlobalConstVar = mgcv_float,
GlobalCord = strcord("global float var ")
;
GlobalConstVar = mgcv_int64,
GlobalCord = strcord("global int64 var ")
;
GlobalConstVar = mgcv_uint64,
GlobalCord = strcord("global uint64 var ")
;
GlobalConstVar = mgcv_closure_layout,
GlobalCord = strcord("global closure layout ")
;
GlobalConstVar = mgcv_typevar_vector,
GlobalCord = strcord("global typevar vector ")
;
GlobalConstVar = mgcv_bit_vector,
GlobalCord = strcord("global bit vector ")
),
Cord = GlobalCord ++ intcord(SeqNum)
;
GlobalVar = gvn_dummy_var,
Cord = strcord("dummy_var")
)
;
Lval = ml_target_global_var_ref(GlobalVarRef),
GlobalVarRef = env_var_ref(EnvVar),
Cord = strcord("env_var_ref(") ++ strcord(EnvVar) ++ strcord(")")
;
Lval = ml_mem_ref(AddrRval, _Type),
Cord = strcord("mem_ref(") ++ mlds_rval_to_strcord(AddrRval) ++
strcord(")")
;
Lval = ml_field(MaybePtag, PtrRval, _PtrType, FieldId, _FieldType),
(
MaybePtag = no,
PtagCord = strcord("ptag unknown")
;
MaybePtag = yes(Ptag),
PtagCord = strcord("ptag " ) ++ ptag_to_strcord(Ptag)
),
(
FieldId = ml_field_offset(OffsetRval),
FieldCord = mlds_rval_to_strcord(OffsetRval)
;
FieldId = ml_field_named(QualVarName, _FieldIdType),
QualVarName = qual_field_var_name(_ModuleName, _QualKind,
FieldVarName),
FieldCord = mlds_field_var_name_to_strcord(FieldVarName)
),
Cord =
strcord("field(") ++ PtagCord ++ comma_cord ++
mlds_rval_to_strcord(PtrRval) ++ comma_cord ++
FieldCord ++ strcord(")")
).
%---------------------------------------------------------------------------%
:- func mlds_rvals_to_strcord(mlds_rval, list(mlds_rval)) = strcord.
mlds_rvals_to_strcord(HeadRval, TailRvals) = Cord :-
(
TailRvals = [],
Cord = mlds_rval_to_strcord(HeadRval)
;
TailRvals = [HeadTailRval | TailTailRvals],
Cord = mlds_rval_to_strcord(HeadRval) ++ comma_cord ++
mlds_rvals_to_strcord(HeadTailRval, TailTailRvals)
).
:- func mlds_rval_to_strcord(mlds_rval) = strcord.
mlds_rval_to_strcord(Rval) = Cord :-
(
Rval = ml_lval(Lval),
Cord = mlds_lval_to_strcord(Lval)
;
Rval = ml_mkword(Ptag, SubRval),
Cord = strcord("mkword(") ++ ptag_to_strcord(Ptag) ++ comma_cord ++
mlds_rval_to_strcord(SubRval) ++ strcord(")")
;
Rval = ml_const(RvalConst),
Cord = mlds_rval_const_to_strcord(RvalConst)
;
Rval = ml_box(FromType, SubRval),
Cord = strcord("box(from ") ++ mlds_type_to_strcord(FromType) ++
comma_cord ++ mlds_rval_to_strcord(SubRval) ++ strcord(")")
;
Rval = ml_unbox(ToType, SubRval),
Cord = strcord("unbox(to ") ++ mlds_type_to_strcord(ToType) ++
comma_cord ++ mlds_rval_to_strcord(SubRval) ++ strcord(")")
;
Rval = ml_cast(ToType, SubRval),
Cord = strcord("cast(to ") ++ mlds_type_to_strcord(ToType) ++
comma_cord ++ mlds_rval_to_strcord(SubRval) ++ strcord(")")
;
Rval = ml_unop(UnOp, SubRvalA),
Cord = unop_to_strcord(UnOp) ++ strcord("(") ++
mlds_rval_to_strcord(SubRvalA) ++ strcord(")")
;
Rval = ml_binop(BinOp, SubRvalA, SubRvalB),
Cord = binop_to_strcord(BinOp) ++ strcord("(") ++
mlds_rval_to_strcord(SubRvalA) ++ comma_cord ++
mlds_rval_to_strcord(SubRvalB) ++ strcord(")")
;
Rval = ml_mem_addr(SubLval),
Cord = strcord("addr_of(") ++ mlds_lval_to_strcord(SubLval) ++
strcord(")")
;
Rval = ml_scalar_common(ScalarCommon),
Cord = strcord("scalar_common(") ++
mlds_scalar_common_to_strcord(ScalarCommon) ++ strcord(")")
;
Rval = ml_scalar_common_addr(ScalarCommon),
Cord = strcord("scalar_common_addr(") ++
mlds_scalar_common_to_strcord(ScalarCommon) ++ strcord(")")
;
Rval = ml_vector_common_row_addr(VectorCommon, RowRval),
Cord = strcord("vector_common_row_addr(") ++
mlds_vector_common_to_strcord(VectorCommon) ++ comma_cord ++
mlds_rval_to_strcord(RowRval) ++ strcord(")")
;
Rval = ml_self(_Type),
Cord = strcord("self")
).
:- func ptag_to_strcord(ptag) = strcord.
ptag_to_strcord(Ptag) = Cord :-
Ptag = ptag(PtagUint8),
Cord = intcord(uint8.cast_to_int(PtagUint8)).
:- func mlds_rval_const_to_strcord(mlds_rval_const) = strcord.
mlds_rval_const_to_strcord(Const) = Cord :-
(
Const = mlconst_true,
Cord = strcord("true")
;
Const = mlconst_false,
Cord = strcord("false")
;
Const = mlconst_int(Int),
Cord = strcord(string.int_to_string(Int))
;
Const = mlconst_uint(Uint),
Cord = strcord(string.uint_to_string(Uint))
;
Const = mlconst_int8(Int8),
Cord = strcord(string.int8_to_string(Int8))
;
Const = mlconst_uint8(Uint8),
Cord = strcord(string.uint8_to_string(Uint8))
;
Const = mlconst_int16(Int16),
Cord = strcord(string.int16_to_string(Int16))
;
Const = mlconst_uint16(Uint16),
Cord = strcord(string.uint16_to_string(Uint16))
;
Const = mlconst_int32(Int32),
Cord = strcord(string.int32_to_string(Int32))
;
Const = mlconst_uint32(Uint32),
Cord = strcord(string.uint32_to_string(Uint32))
;
Const = mlconst_int64(Int64),
Cord = strcord(string.int64_to_string(Int64))
;
Const = mlconst_uint64(Uint64),
Cord = strcord(string.uint64_to_string(Uint64))
;
Const = mlconst_enum(N, Type),
Cord = strcord("enum(") ++ mlds_type_to_strcord(Type) ++ comma_cord ++
intcord(N) ++ strcord(")")
;
Const = mlconst_char(Char),
Cord = strcord("char ") ++ intcord(Char)
;
Const = mlconst_float(Float),
Cord = strcord(string.float_to_string(Float))
;
Const = mlconst_string(Str),
Cord = strcord("""") ++ strcord(Str) ++ strcord("""")
;
Const = mlconst_multi_string(_MultiStr),
Cord = strcord("multi_string")
;
Const = mlconst_foreign(_Lang, Str, _Type),
Cord = strcord("foreign ") ++ strcord(Str)
;
Const = mlconst_named_const(_TargetPrefixes, Str),
Cord = strcord("named_const ") ++ strcord(Str)
;
Const = mlconst_code_addr(CodeAddr),
CodeAddr = mlds_code_addr(QualFuncLabel, _Signature),
QualFuncLabel = qual_func_label(_ModuleName, FuncLabel),
FuncLabelCord = mlds_func_label_to_strcord(FuncLabel),
Cord = strcord("&") ++ FuncLabelCord
;
Const = mlconst_data_addr_local_var(LocalVar),
Cord = strcord("&") ++ strcord(ml_local_var_name_to_string(LocalVar))
;
Const = mlconst_data_addr_global_var(_ModuleName, _GlobalVar),
Cord = strcord("&global_var")
;
Const = mlconst_data_addr_rtti(_ModuleName, _RttiId),
Cord = strcord("&rtti")
;
Const = mlconst_data_addr_tabling(_QualProcLabel, _TablingStructId),
Cord = strcord("&tabling")
;
Const = mlconst_null(_Type),
Cord = strcord("null")
).
:- func mlds_scalar_common_to_strcord(mlds_scalar_common) = strcord.
mlds_scalar_common_to_strcord(ScalarCommon) = Cord :-
ScalarCommon = mlds_scalar_common(_ModuleName, _Type, TypeNum, RowNum),
TypeNum = ml_scalar_common_type_num(TypeNumInt),
Cord = strcord("scalar_common(type ") ++ intcord(TypeNumInt) ++
comma_cord ++ strcord("row ") ++ intcord(RowNum) ++ strcord(")").
:- func mlds_vector_common_to_strcord(mlds_vector_common) = strcord.
mlds_vector_common_to_strcord(VectorCommon) = Cord :-
VectorCommon = mlds_vector_common(_ModuleName, _Type, TypeNum,
StartRowNum, NumRows),
TypeNum = ml_vector_common_type_num(TypeNumInt),
Cord = strcord("vector_common(type ") ++ intcord(TypeNumInt) ++
comma_cord ++ strcord("start row ") ++ intcord(StartRowNum) ++
comma_cord ++ strcord("num rows ") ++ intcord(NumRows) ++ strcord(")").
:- func unop_to_strcord(unary_op) = strcord.
unop_to_strcord(UnOp) = Cord :-
(
UnOp = tag,
Cord = strcord("tag")
;
UnOp = strip_tag,
Cord = strcord("strip_tag")
;
UnOp = mkbody,
Cord = strcord("mkbody")
;
UnOp = unmkbody,
Cord = strcord("unmkbody")
;
UnOp = bitwise_complement(IntType),
Cord = strcord("bitwise_complement<") ++
int_type_to_strcord(IntType) ++ strcord(">")
;
UnOp = logical_not,
Cord = strcord("logical_not")
;
UnOp = hash_string,
Cord = strcord("hash_string1")
;
UnOp = hash_string2,
Cord = strcord("hash_string2")
;
UnOp = hash_string3,
Cord = strcord("hash_string3")
;
UnOp = hash_string4,
Cord = strcord("hash_string4")
;
UnOp = hash_string5,
Cord = strcord("hash_string5")
;
UnOp = hash_string6,
Cord = strcord("hash_string6")
;
UnOp = dword_float_get_word0,
Cord = strcord("float_get_word0")
;
UnOp = dword_float_get_word1,
Cord = strcord("float_get_word1")
;
UnOp = dword_int64_get_word0,
Cord = strcord("int64_get_word0")
;
UnOp = dword_int64_get_word1,
Cord = strcord("int64_get_word1")
;
UnOp = dword_uint64_get_word0,
Cord = strcord("uint64_get_word0")
;
UnOp = dword_uint64_get_word1,
Cord = strcord("uint64_get_word1")
).
:- func binop_to_strcord(binary_op) = strcord.
binop_to_strcord(BinOp) = Cord :-
(
( BinOp = int_add(IntType), OpStr = "add"
; BinOp = int_sub(IntType), OpStr = "sub"
; BinOp = int_mul(IntType), OpStr = "mul"
; BinOp = int_div(IntType), OpStr = "div"
; BinOp = int_mod(IntType), OpStr = "mod"
; BinOp = unchecked_left_shift(IntType, shift_by_int),
OpStr = "raw_left_shift"
; BinOp = unchecked_left_shift(IntType, shift_by_uint),
OpStr = "raw_left_ushift"
; BinOp = unchecked_right_shift(IntType, shift_by_int),
OpStr = "raw_right_shift"
; BinOp = unchecked_right_shift(IntType, shift_by_uint),
OpStr = "raw_right_ushift"
; BinOp = bitwise_and(IntType), OpStr = "bitwise_and"
; BinOp = bitwise_or(IntType), OpStr = "bitwise_or"
; BinOp = bitwise_xor(IntType), OpStr = "bitwise_xor"
; BinOp = eq(IntType), OpStr = "eq"
; BinOp = ne(IntType), OpStr = "ne"
; BinOp = int_lt(IntType), OpStr = "lt"
; BinOp = int_gt(IntType), OpStr = "gt"
; BinOp = int_le(IntType), OpStr = "le"
; BinOp = int_ge(IntType), OpStr = "ge"
),
Cord = strcord(OpStr) ++
strcord("<") ++ int_type_to_strcord(IntType) ++ strcord(">")
;
BinOp = unsigned_lt,
Cord = strcord("unsigned_lt")
;
BinOp = unsigned_le,
Cord = strcord("unsigned_le")
;
BinOp = logical_and,
Cord = strcord("logical_and")
;
BinOp = logical_or,
Cord = strcord("logical_or")
;
BinOp = body,
Cord = strcord("body")
;
BinOp = string_unsafe_index_code_unit,
Cord = strcord("string_raw_index_cu")
;
BinOp = array_index(_Type),
Cord = strcord("array_index")
;
BinOp = offset_str_eq(Offset),
Cord = strcord("offset_str_eq") ++
strcord("<") ++ intcord(Offset) ++ strcord(">")
;
BinOp = str_eq,
Cord = strcord("str_eq")
;
BinOp = str_ne,
Cord = strcord("str_ne")
;
BinOp = str_lt,
Cord = strcord("str_lt")
;
BinOp = str_gt,
Cord = strcord("str_gt")
;
BinOp = str_le,
Cord = strcord("str_le")
;
BinOp = str_ge,
Cord = strcord("str_ge")
;
BinOp = str_cmp,
Cord = strcord("str_cmp")
;
BinOp = float_add,
Cord = strcord("float_add")
;
BinOp = float_sub,
Cord = strcord("float_sub")
;
BinOp = float_mul,
Cord = strcord("float_mul")
;
BinOp = float_div,
Cord = strcord("float_div")
;
BinOp = float_eq,
Cord = strcord("float_eq")
;
BinOp = float_ne,
Cord = strcord("float_ne")
;
BinOp = float_lt,
Cord = strcord("float_lt")
;
BinOp = float_gt,
Cord = strcord("float_gt")
;
BinOp = float_le,
Cord = strcord("float_le")
;
BinOp = float_ge,
Cord = strcord("float_ge")
;
BinOp = float_from_dword,
Cord = strcord("float_from_dword")
;
BinOp = int64_from_dword,
Cord = strcord("int64_from_dword")
;
BinOp = uint64_from_dword,
Cord = strcord("uint64_from_dword")
;
BinOp = pointer_equal_conservative,
Cord = strcord("ptr_eq")
;
BinOp = compound_eq,
Cord = strcord("compound_eq")
;
BinOp = compound_lt,
Cord = strcord("compound_lt")
).
:- func int_type_to_strcord(int_type) = strcord.
int_type_to_strcord(IntType) = strcord(Str) :-
( IntType = int_type_int, Str = "int"
; IntType = int_type_uint, Str = "uint"
; IntType = int_type_int8, Str = "int8"
; IntType = int_type_uint8, Str = "uint8"
; IntType = int_type_int16, Str = "int16"
; IntType = int_type_uint16, Str = "uint16"
; IntType = int_type_int32, Str = "int32"
; IntType = int_type_uint32, Str = "uint32"
; IntType = int_type_int64, Str = "int64"
; IntType = int_type_uint64, Str = "uint64"
).
%---------------------------------------------------------------------------%
:- func mlds_types_to_strcord(mlds_type, list(mlds_type)) = strcord.
mlds_types_to_strcord(HeadType, TailTypes) = Cord :-
(
TailTypes = [],
Cord = mlds_type_to_strcord(HeadType)
;
TailTypes = [HeadTailType | TailTailTypes],
Cord = mlds_type_to_strcord(HeadType) ++ comma_cord ++
mlds_types_to_strcord(HeadTailType, TailTailTypes)
).
:- func mercury_types_to_strcord(mer_type, list(mer_type)) = strcord.
mercury_types_to_strcord(HeadType, TailTypes) = Cord :-
(
TailTypes = [],
Cord = mercury_type_to_strcord(HeadType)
;
TailTypes = [HeadTailType | TailTailTypes],
Cord = mercury_type_to_strcord(HeadType) ++ comma_cord ++
mercury_types_to_strcord(HeadTailType, TailTailTypes)
).
%---------------------------------------------------------------------------%
:- func mlds_type_to_strcord(mlds_type) = strcord.
mlds_type_to_strcord(MLDS_Type) = Cord :-
(
MLDS_Type = mercury_nb_type(MerType, _CtorCat),
Cord = mercury_type_to_strcord(MerType)
;
MLDS_Type = mlds_mercury_array_type(MLDS_ElementType),
Cord = strcord("mercury_array(") ++
mlds_type_to_strcord(MLDS_ElementType) ++ strcord(")")
;
MLDS_Type = mlds_array_type(MLDS_ElementType),
Cord = strcord("array(") ++
mlds_type_to_strcord(MLDS_ElementType) ++ strcord(")")
;
MLDS_Type = mlds_mostly_generic_array_type(MLDS_ElementTypes),
(
MLDS_ElementTypes = [],
Cord = strcord("mostly_generic_array()")
;
MLDS_ElementTypes = [HeadType | TailTypes],
Cord = strcord("mostly_generic_array(") ++
mlds_types_to_strcord(HeadType, TailTypes) ++ strcord(")")
)
;
MLDS_Type = mlds_cont_type(MLDS_ReturnTypes),
(
MLDS_ReturnTypes = [],
Cord = strcord("cont_type(return: <>)")
;
MLDS_ReturnTypes = [HeadType | TailTypes],
Cord = strcord("cont_type(return: <") ++
mlds_types_to_strcord(HeadType, TailTypes) ++ strcord(">)")
)
;
MLDS_Type = mlds_commit_type,
Cord = strcord("commit_type")
;
MLDS_Type = mlds_native_bool_type,
Cord = strcord("native bool")
;
MLDS_Type = mlds_builtin_type_int(IntType),
( IntType = int_type_int, Str = "int"
; IntType = int_type_int8, Str = "int8"
; IntType = int_type_int16, Str = "int16"
; IntType = int_type_int32, Str = "int32"
; IntType = int_type_int64, Str = "int64"
; IntType = int_type_uint, Str = "uint"
; IntType = int_type_uint8, Str = "uint8"
; IntType = int_type_uint16, Str = "uint16"
; IntType = int_type_uint32, Str = "uint32"
; IntType = int_type_uint64, Str = "uint64"
),
Cord = strcord(Str)
;
MLDS_Type = mlds_builtin_type_float,
Cord = strcord("float")
;
MLDS_Type = mlds_builtin_type_string,
Cord = strcord("string")
;
MLDS_Type = mlds_builtin_type_char,
Cord = strcord("char")
;
MLDS_Type = mlds_foreign_type(ForeignType),
(
ForeignType = c(c_type(TypeName)),
Cord = strcord("c_type(") ++ strcord(TypeName) ++ strcord(")")
;
ForeignType = java(java_type(TypeName)),
Cord = strcord("java_type(") ++ strcord(TypeName) ++ strcord(")")
;
ForeignType = csharp(csharp_type(TypeName)),
Cord = strcord("csharp_type(") ++ strcord(TypeName) ++ strcord(")")
)
;
MLDS_Type = mlds_class_type(ClassId),
ClassId = mlds_class_id(QualClassName, Arity),
QualClassName = qual_class_name(_ModuleName, _QualKind, ClassName),
Cord = strcord("class(") ++ strcord(ClassName) ++ strcord("/") ++
intcord(Arity) ++ strcord(")")
;
MLDS_Type = mlds_enum_class_type(EnumClassId),
EnumClassId = mlds_enum_class_id(_ModuleName, EnumClassName, Arity),
Cord = strcord("enum(") ++ strcord(EnumClassName) ++ strcord("/") ++
intcord(Arity) ++ strcord(")")
;
MLDS_Type = mlds_env_type(EnvId),
EnvId = mlds_env_id(_ModuleName, EnvsName),
Cord = strcord("env_struct(") ++ strcord(EnvsName) ++ strcord(")")
;
MLDS_Type = mlds_struct_type(StructId),
StructId = mlds_struct_id(_ModuleName, StructName),
Cord = strcord("struct(") ++ strcord(StructName) ++ strcord(")")
;
MLDS_Type = mlds_ptr_type(PointedToType),
Cord = strcord("ptr_to(") ++ mlds_type_to_strcord(PointedToType) ++
strcord(")")
;
MLDS_Type = mlds_func_type(FuncParams),
Cord = strcord("func_type(") ++
mlds_func_params_to_strcord(FuncParams) ++ strcord(")")
;
MLDS_Type = mlds_generic_type,
Cord = strcord("generic")
;
MLDS_Type = mlds_generic_env_ptr_type,
Cord = strcord("generic_env_ptr")
;
MLDS_Type = mlds_type_info_type,
Cord = strcord("type_info")
;
MLDS_Type = mlds_pseudo_type_info_type,
Cord = strcord("pseudo_type_info")
;
MLDS_Type = mlds_rtti_type(_),
Cord = strcord("rtti_type")
;
MLDS_Type = mlds_tabling_type(_),
Cord = strcord("tabling_type")
;
MLDS_Type = mlds_unknown_type,
Cord = strcord("unknown_type")
).
:- func mlds_func_params_to_strcord(mlds_func_params) = strcord.
mlds_func_params_to_strcord(Params) = Cord :-
Params = mlds_func_params(Args, ReturnTypes),
(
Args = [],
ArgsCord = cord.init
;
Args = [HeadArg | TailArgs],
ArgsCord =
strcord("(") ++
mlds_arguments_to_strcord(HeadArg, TailArgs) ++
strcord(")")
),
(
ReturnTypes = [],
ReturnCord = cord.init
;
ReturnTypes = [HeadReturnType | TailReturnTypes],
ReturnCord =
strcord("->(") ++
mlds_types_to_strcord(HeadReturnType, TailReturnTypes) ++
strcord(")")
),
Cord = ArgsCord ++ ReturnCord.
:- func mercury_type_to_strcord(mer_type) = strcord.
mercury_type_to_strcord(MerType) = Cord :-
(
MerType = type_variable(TypeVar, _Kind),
Cord = strcord("type_var_") ++ intcord(var_to_int(TypeVar))
;
MerType = defined_type(TypeCtorSymName, ArgTypes, _Kind),
TypeCtorName = unqualify_name(TypeCtorSymName),
(
ArgTypes = [],
Cord = strcord(TypeCtorName)
;
ArgTypes = [HeadArgType | TailArgTypes],
Cord = strcord(TypeCtorName) ++ strcord("(") ++
mercury_types_to_strcord(HeadArgType, TailArgTypes) ++
strcord(")")
)
;
MerType = builtin_type(BuiltinType),
(
BuiltinType = builtin_type_int(IntType),
Cord = int_type_to_strcord(IntType)
;
BuiltinType = builtin_type_float,
Cord = strcord("float")
;
BuiltinType = builtin_type_string,
Cord = strcord("string")
;
BuiltinType = builtin_type_char,
Cord = strcord("char")
)
;
MerType = tuple_type(ArgTypes, _Kind),
(
ArgTypes = [],
Cord = strcord("{}")
;
ArgTypes = [HeadArgType | TailArgTypes],
Cord = strcord("{") ++
mercury_types_to_strcord(HeadArgType, TailArgTypes) ++
strcord("}")
)
;
MerType = higher_order_type(PorF, ArgTypes, _HoInstInfo, Purity,
_LambdaEvalMethod),
(
Purity = purity_pure,
PurityCord = cord.init
;
Purity = purity_semipure,
PurityCord = strcord("semipure_")
;
Purity = purity_impure,
PurityCord = strcord("impure_")
),
(
PorF = pf_function,
PorFCord = strcord("func")
;
PorF = pf_predicate,
PorFCord = strcord("pred")
),
(
ArgTypes = [],
ArgCord = cord.init
;
ArgTypes = [HeadArgType | TailArgTypes],
ArgCord = strcord("(") ++
mercury_types_to_strcord(HeadArgType, TailArgTypes) ++
strcord(")")
),
Cord = PurityCord ++ PorFCord ++ ArgCord
;
MerType = apply_n_type(TypeVar, ArgTypes, _Kind),
(
ArgTypes = [],
Cord = strcord("apply_tvar_") ++ intcord(var_to_int(TypeVar))
;
ArgTypes = [HeadArgType | TailArgTypes],
Cord = strcord("apply_tvar_") ++ intcord(var_to_int(TypeVar)) ++
strcord("(") ++
mercury_types_to_strcord(HeadArgType, TailArgTypes) ++
strcord(")")
)
;
MerType = kinded_type(SubType, _Kind),
Cord = mercury_type_to_strcord(SubType)
).
%---------------------------------------------------------------------------%
:- func mlds_field_var_name_to_strcord(mlds_field_var_name) = strcord.
mlds_field_var_name_to_strcord(FieldVarName) = Cord :-
(
FieldVarName = fvn_global_data_field(TypeNum, FieldNum),
Str = string.format("global data field <type %d, field %d>",
[i(TypeNum), i(FieldNum)]),
Cord = strcord(Str)
;
FieldVarName = fvn_du_ctor_field_hld(FieldName),
Cord = strcord("du ctor field hld ") ++ strcord(FieldName)
;
FieldVarName = fvn_mr_value,
Cord = strcord("mr_value")
;
FieldVarName = fvn_data_tag,
Cord = strcord("data_tag")
;
FieldVarName = fvn_enum_const(ConstName),
Cord = strcord("enum_const ") ++ strcord(ConstName)
;
FieldVarName = fvn_ptr_num,
Cord = strcord("ptr_num")
;
FieldVarName = fvn_env_field_from_local_var(LocalVar),
Cord = strcord("env field local var ") ++
strcord(ml_local_var_name_to_string(LocalVar))
;
FieldVarName = fvn_base_class(BaseNum),
Cord = strcord("base class ") ++ intcord(BaseNum)
;
FieldVarName = fvn_prev,
Cord = strcord("prev")
;
FieldVarName = fvn_trace,
Cord = strcord("trace")
).
%---------------------------------------------------------------------------%
:- func mlds_local_var_defns_to_strcord(int, list(mlds_local_var_defn))
= strcord.
mlds_local_var_defns_to_strcord(_Indent, []) = cord.init.
mlds_local_var_defns_to_strcord(Indent, [Defn | Defns]) =
mlds_local_var_defn_to_strcord(Indent, Defn) ++
mlds_local_var_defns_to_strcord(Indent, Defns).
:- func mlds_local_var_defn_to_strcord(int, mlds_local_var_defn) = strcord.
mlds_local_var_defn_to_strcord(Indent, LocalVarDefn) = Cord :-
LocalVarDefn = mlds_local_var_defn(VarName, _Context, Type, Init, _Gc),
(
Init = no_initializer,
InitCord = cord.init
;
Init = init_obj(Rval),
InitCord = strcord(" init_obj ") ++ mlds_rval_to_strcord(Rval)
;
Init = init_struct(_Type, _Inits),
InitCord = strcord(" init_struct(...)")
;
Init = init_array(_Inits),
InitCord = strcord(" init_array(...)")
),
Cord = indent_strcord(Indent) ++ strcord("local ") ++
strcord(ml_local_var_name_to_string(VarName)) ++ comma_cord ++
mlds_type_to_strcord(Type) ++ InitCord ++ nl_strcord.
%---------------------------------------------------------------------------%
:- func mlds_function_defns_to_strcord(int, list(mlds_function_defn))
= strcord.
mlds_function_defns_to_strcord(_Indent, []) = cord.init.
mlds_function_defns_to_strcord(Indent, [Defn | Defns]) =
mlds_function_defn_to_strcord(Indent, Defn) ++
mlds_function_defns_to_strcord(Indent, Defns).
:- func mlds_function_defn_to_strcord(int, mlds_function_defn) = strcord.
mlds_function_defn_to_strcord(Indent, FuncDefn) = Cord :-
FuncDefn = mlds_function_defn(FuncName, _Context, _Flags, _OrigProc,
Params, Body, _EnvVars, _TailRec),
(
FuncName = mlds_function_name(PlainFuncName),
PlainFuncName = mlds_plain_func_name(FuncLabel, _PredId),
FuncNameCord = mlds_func_label_to_strcord(FuncLabel)
;
FuncName = mlds_function_export(FuncNameStr),
FuncNameCord = strcord(FuncNameStr)
),
(
Body = body_external,
BodyCord = indent_strcord(Indent + 1) ++ strcord("external")
;
Body = body_defined_here(Stmt),
BodyCord = mlds_stmt_to_strcord(Indent + 1, Stmt)
),
Cord =
indent_strcord(Indent) ++ strcord("func ") ++ FuncNameCord ++
mlds_func_params_to_strcord(Params) ++ nl_strcord ++
indent_strcord(Indent) ++ strcord("begin") ++ nl_strcord ++
BodyCord ++
indent_strcord(Indent) ++ strcord("end") ++ nl_strcord.
:- func mlds_arguments_to_strcord(mlds_argument, list(mlds_argument))
= strcord.
mlds_arguments_to_strcord(HeadArg, TailArgs) = Cord :-
(
TailArgs = [],
Cord = mlds_argument_to_strcord(HeadArg)
;
TailArgs = [HeadTailArg | TailTailArgs],
Cord = mlds_argument_to_strcord(HeadArg) ++ comma_cord ++
mlds_arguments_to_strcord(HeadTailArg, TailTailArgs)
).
:- func mlds_argument_to_strcord(mlds_argument) = strcord.
mlds_argument_to_strcord(Arg) = Cord :-
Arg = mlds_argument(LocalVarName, Type, _Gc),
Cord = mlds_type_to_strcord(Type) ++ strcord(" ") ++
strcord(ml_local_var_name_to_string(LocalVarName)).
:- func mlds_func_label_to_strcord(mlds_func_label) = strcord.
mlds_func_label_to_strcord(FuncLabel) = Cord :-
FuncLabel = mlds_func_label(ProcLabel, MaybeAuxFuncId),
ProcLabel = mlds_proc_label(PredLabel, ProcId),
(
PredLabel = mlds_user_pred_label(PorF, _MaybeModuleName,
PredName, PredFormArity, _CodeModel, _NonDefaultModeFunction),
PredFormArity = pred_form_arity(PredFormArityInt),
(
PorF = pf_function,
PorFCord = strcord("func_")
;
PorF = pf_predicate,
PorFCord = strcord("pred_")
),
PredCord = PorFCord ++ strcord(PredName) ++
strcord("/") ++ intcord(PredFormArityInt)
;
PredLabel = mlds_special_pred_label(PredName, _MaybeModuleName,
TypeName, TypeArity),
PredCord = strcord(PredName) ++ strcord("_for_") ++
strcord(TypeName) ++ strcord("/") ++ intcord(TypeArity)
),
ProcCord = strcord("-") ++ intcord(proc_id_to_int(ProcId)),
(
MaybeAuxFuncId = proc_func,
AuxCord = cord.init
;
MaybeAuxFuncId = proc_aux_func(SeqNum),
AuxCord = strcord("$aux_") ++ intcord(SeqNum)
;
MaybeAuxFuncId = gc_trace_for_proc_func,
AuxCord = strcord("$gc")
;
MaybeAuxFuncId = gc_trace_for_proc_aux_func(SeqNum),
AuxCord = strcord("$gc_aux_") ++ intcord(SeqNum)
),
Cord = PredCord ++ ProcCord ++ AuxCord.
%---------------------------------------------------------------------------%
:- func comma_cord = strcord.
comma_cord = strcord(", ").
:- func strcord(string) = strcord.
strcord(Str) = cord.singleton(Str).
:- func intcord(int) = strcord.
intcord(N) = cord.singleton(string.int_to_string(N)).
:- func indent_strcord(int) = strcord.
indent_strcord(Indent) = Cord :-
( if
( Indent = 0, CordPrime = cord.init
; Indent = 1, CordPrime = cord.singleton(" ")
; Indent = 2, CordPrime = cord.singleton(" ")
; Indent = 3, CordPrime = cord.singleton(" ")
; Indent = 4, CordPrime = cord.singleton(" ")
; Indent = 5, CordPrime = cord.singleton(" ")
)
then
Cord = CordPrime
else if
Indent > 0
then
Half = Indent / 2,
Cord = indent_strcord(Half) ++ indent_strcord(Indent - Half)
else
unexpected($pred, "negative Indent")
).
:- func nl_strcord = strcord.
nl_strcord = cord.singleton("\n").
%---------------------------------------------------------------------------%
:- end_module ml_backend.mlds_dump.
%---------------------------------------------------------------------------%
Reference in New Issue View Git Blame Copy Permalink