## lowhalf-types-g.pkg -- derived from ~/src/sml/nj/smlnj-110.60/MLRISC/Tools/ADL/mlrisc-types.sml
#
# lowhalf specific things are abstracted out here in this module.
# Compiled by:
# src/lib/compiler/back/low/tools/arch/make-sourcecode-for-backend-packages.lib### "Virtue is harmony."
###
### -- Pythagoras
stipulate
package err = adl_error; # adl_error is from src/lib/compiler/back/low/tools/line-number-db/adl-error.pkg package spp = simple_prettyprinter; # simple_prettyprinter is from src/lib/prettyprint/simple/simple-prettyprinter.pkg package ard = architecture_description; # architecture_description is from src/lib/compiler/back/low/tools/arch/architecture-description.pkg package rrs = adl_rewrite_raw_syntax_parsetree; # adl_rewrite_raw_syntax_parsetree is from src/lib/compiler/back/low/tools/adl-syntax/adl-rewrite-raw-syntax-parsetree.pkg package mtj = adl_type_junk; # adl_type_junk is from src/lib/compiler/back/low/tools/arch/adl-type-junk.pkg package raw = adl_raw_syntax_form; # adl_raw_syntax_form is from src/lib/compiler/back/low/tools/adl-syntax/adl-raw-syntax-form.pkg package rkj = registerkinds_junk; # registerkinds_junk is from src/lib/compiler/back/low/code/registerkinds-junk.pkg package rsu = adl_raw_syntax_unparser; # adl_raw_syntax_unparser is from src/lib/compiler/back/low/tools/adl-syntax/adl-raw-syntax-unparser.pkg package rsj = adl_raw_syntax_junk; # adl_raw_syntax_junk is from src/lib/compiler/back/low/tools/adl-syntax/adl-raw-syntax-junk.pkgherein
generic package lowhalf_types_g (
# ===============
#
package rtl: Treecode_Rtl; # Treecode_Rtl is from src/lib/compiler/back/low/treecode/treecode-rtl.api )
: (weak) Lowhalf_Types # Lowhalf_Types is from src/lib/compiler/back/low/tools/arch/lowhalf-types.api {
# Export to client packages:
#
package rtl = rtl;
stipulate
package tcf = rtl::tcf;
#
include package rsj;
include package err;
herein
t2s = spp::prettyprint_expression_to_string o rsu::type;
e2s = spp::prettyprint_expression_to_string o rsu::expression;
# Does this type has special meaning in an instruction representation?
#
fun is_special_rep_type t
=
*found
where
found = REF FALSE;
fun is_special t
=
case (mtj::deref t)
#
raw::REGISTER_TYPE _ => TRUE; # Register types are special. (They come from foo: $bar syntax in the .adl file.)
raw::IDTY (raw::IDENT(_, "int")) => TRUE;
raw::IDTY (raw::IDENT([], "operand")) => TRUE;
raw::IDTY (raw::IDENT(_, "registerset")) => TRUE;
#
_ => FALSE;
esac;
fun rewrite_type_node _ t
=
{ if (is_special t) found := TRUE; fi;
t;
};
fns.rewrite_type_parsetree t
where
fns = rrs::make_raw_syntax_parsetree_rewriters [ rrs::REWRITE_TYPE_NODE rewrite_type_node ];
end;
end;
# Return the real representation type of an rtl argument:
#
fun representation_of (rtl_name, arg, loc, type)
=
{ fun err ()
=
{ error_pos (loc,"'" + arg + "' in rtl " + rtl_name + " has an illegal type " + t2s type);
(0, "bits");
};
case (mtj::deref type)
#
raw::IDTY (raw::IDENT([], "operand")) => (0, "operand");
raw::IDTY (raw::IDENT([], "label")) => (0, "label");
raw::IDTY (raw::IDENT([], "region")) => (0, "region");
raw::APPTY (raw::IDENT([], "operand"), [raw::INTVARTY n]) => (n, "operand");
raw::APPTY (raw::IDENT([], "bits"), [raw::INTVARTY n]) => (n, "bits");
#
type => err ();
esac;
};
fun representation_of (rtl_name, arg, loc, type)
=
{ fun err ()
=
{ error_pos (loc, "'" + arg + "' in rtl " + rtl_name + " has an illegal type " + t2s type);
#
(0, "bits");
};
case (mtj::deref type)
#
raw::IDTY (raw::IDENT([], "operand")) => (0, "operand");
raw::IDTY (raw::IDENT(_, "label")) => (0, "label");
raw::IDTY (raw::IDENT([], "region")) => (0, "region");
raw::APPTY (raw::IDENT([], "operand"), [raw::INTVARTY n]) => (n, "operand");
raw::APPTY (raw::IDENT([], "bits"), [raw::INTVARTY n]) => (n, "register");
#
type => err ();
esac;
};
# Given the actual represention of an rtl argument,
# insert coercion if possible:
#
fun insert_rep_coercion (expression, type)
=
case (expression, mtj::deref type)
#
(tcf::ARG(_, k, _), raw::IDTY (raw::IDENT([], "int"))) => k := tcf::REPX "int";
(tcf::ARG(_, k, _), raw::IDTY (raw::IDENT(_, "label"))) => k := tcf::REPX "label";
(tcf::ARG(_, k, _), raw::IDTY (raw::IDENT([], "operand"))) => k := tcf::REPX "operand";
(tcf::ATATAT(_, _, tcf::ARG(_, k, _)), raw::REGISTER_TYPE _) => k := tcf::REPX "register"; # REGISTER_TYPE s come from foo: $bar syntax in the .adl file.
#
_ => ();
esac;
fun of_registerkind (tcf::ATATAT(_, k, _), raw::REGISTER_SET r)
=>
case (rkj::name_of_registerkind k)
#
"REGISTERSET" => TRUE;
k => k == r.name;
esac;
of_registerkind (tcf::ARG _, raw::REGISTER_SET _) => FALSE;
of_registerkind (_, _) => FALSE;
end;
# A database of all special types
#
Howto = HOWTO
{ rep: String, # Name of representation.
is_ssa_value: Bool, # Is it a value in SSA form?
ml_type: raw::Type, # Type in ML.
is_const: Bool, # If so, is it always a constant?
is_multi_valued: ard::Architecture_Description -> Bool # If a value can it take more than one
};
howtos = REF []: Ref( List( Howto ) );
fun find_rep r
=
case (list::find (\\ HOWTO { rep, ... } = rep == r) *howtos)
#
THE (HOWTO howto) => howto;
NULL => fail("bug: representation " + r + " not known");
esac;
# ---------------------------------------------------------------------
#
# Code generation magic
#
# ---------------------------------------------------------------------
#
fun is_const (tcf::REPX rep)
=
(find_rep rep).is_const;
# ---------------------------------------------------------------------
#
# Okay, now specify all the types that we have to handle.
#
# ---------------------------------------------------------------------
fun no _ = FALSE;
fun yes _ = TRUE;
fun bug _ = fail("unimplemented");
my _ =
howtos :=
[ HOWTO { rep => "label",
is_ssa_value => FALSE,
ml_type => raw::IDTY (raw::IDENT(["Label"], "label")),
is_const => TRUE,
is_multi_valued => no
},
HOWTO { rep => "int",
is_ssa_value => TRUE,
ml_type => raw::IDTY (raw::IDENT([], "int")),
is_const => TRUE,
is_multi_valued => no
},
HOWTO { rep => "operand",
is_ssa_value => TRUE,
ml_type => raw::IDTY (raw::IDENT(["I"], "operand")),
is_const => FALSE,
is_multi_valued => yes
},
HOWTO { rep => "registerset",
is_ssa_value => TRUE,
ml_type => raw::IDTY (raw::IDENT(["C"], "registerset")),
is_const => FALSE,
is_multi_valued => yes
}
];
# ---------------------------------------------------------------------
#
# Generate an expression for performing the appropriate conversion
#
# ---------------------------------------------------------------------
#
Conv = IGNORE
| CONV String
| MULTI String
;
package desc_map
=
red_black_map_g (
#
Key = String;
compare = string::compare;
);
fun get_opnd desc
=
{ table = fold_backward
(\\ ((rep, conv), table)
=
desc_map::set (table, rep, conv)
)
desc_map::empty desc;
fun mk_conv_fun (rep, conv)
=
"fun get_" + rep + "(x, L) = "
+
case conv
#
IGNORE => "L";
CONV f => f + " . L";
MULTI f => f + "@L";
esac;
fun mk_conv_fun0 (rep, conv)
=
"fun get_" + rep + "'(x) = "
+
case conv
#
IGNORE => "[]";
CONV f => "[" + f + "]";
MULTI f => f;
esac;
decl = raw::VERBATIM_CODE (map mk_conv_fun desc
@
map mk_conv_fun0 desc
);
fun apply (rep, this, rest)
=
app ("get_" + rep, raw::TUPLE_IN_EXPRESSION [this, rest]);
fun get_it (rep, this, rest)
=
case (desc_map::get (table, rep), rest)
#
(NULL, _) => fail ("get_opnd: " + rep + " is not defined");
(THE IGNORE, _) => rest;
(THE (CONV _), _) => apply (rep, this, rest);
#
(THE (MULTI conv), raw::LIST_IN_EXPRESSION([], NULL)) => app ("get_" + rep + "'", this);
#
(THE (MULTI _), rest) => apply (rep, this, rest);
esac;
fun get (this, tcf::ATATAT(_, k, _), rest)
=>
if (rkj::name_of_registerkind k == "REGISTERSET") get_it("registerset", this, rest);
else get_it("register", this, rest);
fi;
get (this, tcf::ARG(_, REF (tcf::REPX rep), _), rest) => get_it (rep, this, rest);
get (_, e, _) => fail ("lowhalf_types::get: " + rtl::tcj::int_expression_to_string e);
end;
{ decl, get };
};
end; # stipulate
}; # generic package lowhalf_types_g
end; # stipulate