## sourcecode-making-junk.pkg -- derived from ~/src/sml/nj/smlnj-110.60/MLRISC/Tools/ADL/mdl-compile.sml
#
# See overview comments in
# src/lib/compiler/back/low/tools/arch/sourcecode-making-junk.api# Compiled by:
# src/lib/compiler/back/low/tools/arch/make-sourcecode-for-backend-packages.lib### "I visualize a time when we
### will be to robots what
### dogs are to humans, and I'm
### rooting for the machines."
###
### -- Claude Shannon
stipulate
package ard = architecture_description; # architecture_description is from src/lib/compiler/back/low/tools/arch/architecture-description.pkg package cst = adl_raw_syntax_constants; # adl_raw_syntax_constants is from src/lib/compiler/back/low/tools/adl-syntax/adl-raw-syntax-constants.pkg package err = adl_error; # adl_error is from src/lib/compiler/back/low/tools/line-number-db/adl-error.pkg package fil = file__premicrothread; # file__premicrothread is from src/lib/std/src/posix/file--premicrothread.pkg package htb = hashtable; # hashtable is from src/lib/src/hashtable.pkg package spp = simple_prettyprinter; # simple_prettyprinter is from src/lib/prettyprint/simple/simple-prettyprinter.pkg package mst = adl_symboltable; # adl_symboltable is from src/lib/compiler/back/low/tools/arch/adl-symboltable.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 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 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 rsj = adl_raw_syntax_junk; # adl_raw_syntax_junk is from src/lib/compiler/back/low/tools/adl-syntax/adl-raw-syntax-junk.pkg package rsp = adl_raw_syntax_predicates; # adl_raw_syntax_predicates is from src/lib/compiler/back/low/tools/arch/adl-raw-syntax-predicates.pkgherein
# This package is referenced in:
# src/lib/compiler/back/low/tools/arch/make-sourcecode-for-backend-packages.pkg package sourcecode_making_junk
: Sourcecode_Making_Junk # Sourcecode_Making_Junk is from src/lib/compiler/back/low/tools/arch/sourcecode-making-junk.api {
# Code Generation methods
Seal = WEAK_SEAL # foo: (weak) Bar
| STRONG_SEAL # foo: Bar
;
Module = String;
Arguments = List( String );
Api_Name = String;
infix my ++ ;
++ = spp::CONS;
toupper = string::map char::to_upper;
tolower = string::map char::to_lower;
fun make_api_name architecture_description name = string::to_mixed (name + "_" + (ard::architecture_name_of architecture_description) ); # E.g., Registerkinds_Intel32
fun make_package_name architecture_description name = string::to_lower (name + "_" + (ard::architecture_name_of architecture_description) ); # E.g., registerkinds_intel32
fun make_generic_package_name architecture_description name = string::to_lower (name + "_" + (ard::architecture_name_of architecture_description) + "_g"); # E.g., registerkinds_intel32_g
fun make_sig_con "" _ => spp::NOP;
make_sig_con api_name WEAK_SEAL => spp::PUNCTUATION ": (weak) " ++ spp::ALPHABETIC api_name;
make_sig_con api_name STRONG_SEAL => spp::PUNCTUATION ": " ++ spp::ALPHABETIC api_name;
end;
fun make_api architecture_description name body
=
spp::INDENTED_LINE ( spp::ALPHABETIC "api"
++ spp::ALPHABETIC (make_api_name architecture_description name)
++ spp::ALPHABETIC "{"
)
++ spp::INDENTED_BLOCK (rsu::decls body)
++ spp::INDENTED_LINE (spp::ALPHABETIC "};")
;
# For better readability, these functions should all
# take record arguments instead of being curried. XXX SUCKO FIXME.
fun make_generic' architecture_description name_making_fn args seal api_name body
=
spp::INDENT
++ spp::ENTER_DEEPLY_INDENTED_BLOCK
++ spp::ALPHABETIC "generic package"
++ spp::ALPHABETIC (name_making_fn (ard::architecture_name_of architecture_description))
++ spp::MAYBE_BLANK
++ spp::PUNCTUATION "("
++ spp::ENTER_INDENTED_BLOCK
++ spp::NEWLINE ++ spp::INDENT ++ spp::PUNCTUATION "#"
++ spp::NEWLINE ++ spp::INDENT
++ rsu::decl args
++ spp::LEAVE_INDENTED_BLOCK
++ spp::INDENT
++ spp::PUNCTUATION ")"
++ spp::NEWLINE
++ spp::INDENT
++ make_sig_con api_name seal
++ spp::NEWLINE ++ spp::INDENT
++ spp::PUNCTUATION "{"
++ spp::NEWLINE
++ spp::INDENTED_BLOCK (rsu::decls body)
++ spp::INDENT
++ spp::PUNCTUATION "};"
++ spp::NEWLINE
++ spp::LEAVE_INDENTED_BLOCK
;
fun make_generic architecture_description name_making_fn args seal api_name body
=
make_generic' architecture_description name_making_fn (raw::VERBATIM_CODE args) seal api_name body;
fun make_package architecture_description base_package_name api_name body
=
spp::INDENTED_LINE
( spp::ALPHABETIC "package"
++ spp::ALPHABETIC (make_package_name architecture_description base_package_name)
++ make_sig_con api_name STRONG_SEAL
++ spp::ALPHABETIC "{"
)
++ spp::INDENTED_BLOCK (spp::INDENTED_LINE (spp::PUNCTUATION "#"))
++ spp::INDENTED_BLOCK (rsu::decls body)
++ spp::INDENTED_LINE (spp::PUNCTUATION "};")
;
fun make_code body # Nowhere invoked.
=
spp::INDENTED_BLOCK (rsu::decls body);
fun make_sourcecode_filename # Our main call is in src/lib/compiler/back/low/tools/arch/adl-rtl-comp-g.pkg # # We're also called in src/lib/compiler/back/low/tools/arch/make-sourcecode-for-backend-packages-g.pkg #
{ architecture_description: ard::Architecture_Description, # E.g. from "src/lib/compiler/back/low/intel32/one_word_int.architecture-description".
subdir: String, # E.g. "code".
make_filename: String -> String # E.g. maps "intel32" -> "registerkinds-intel32.codemade.pkg".
}
=
filename # E.g. "src/lib/compiler/back/low/intel32/code/registers-intel32.pkg"
where
fun get_name
( subdir, # E.g. "code".
make_filename # E.g. maps "intel32" -> "registerkinds-intel32.codemade.pkg".
)
=
winix__premicrothread::path::cat
(
subdir,
make_filename (tolower (ard::architecture_name_of architecture_description))
);
filename = winix__premicrothread::path::cat
(
winix__premicrothread::path::dir (ard::architecture_description_file_of architecture_description),
get_name (subdir, make_filename)
);
end;
# Emit text into a file:
#
fun write_textfile
architecture_description
created_by_package # E.g. "src/lib/compiler/back/low/tools/arch/make-sourcecode-for-registerkinds-xxx-package.pkg".
subdir # Relative to file containing architecture description.
make_filename
new_body # New file contents except for header text.
=
if (*err::error_count <= 0)
#
filename = make_filename( tolower (ard::architecture_name_of architecture_description) ); # E.g. "registerkinds-intel32.codemade.pkg"
filepath = make_sourcecode_filename { architecture_description, subdir, make_filename }; # E.g. "src/lib/compiler/back/low/intel32/code/registerkinds-intel32.codemade.pkg"
# file = module_name (module + ".pkg"); # For testing
old_text =
{ stream = fil::open_for_read filepath;
#
fil::read_n (stream, 1024*1024)
then
fil::close_input stream;
}
except _ = "";
now = date::strftime # E.g. "2011-04-28:00:36:27"
"%Y-%m-%d:%H:%M:%S"
(date::from_time_local (time::get_current_time_utc ()));
new_header
= "## " + filename + "\n"
+ "#\n"
+ "# This file generated at " + now + " by\n"
+ "#\n"
+ "# " + created_by_package + "\n"
+ "#\n"
+ "# from the architecture description file\n"
+ "#\n"
+ "# " + ard::architecture_description_file_of architecture_description + "\n"
+ "#\n"
+ "# Edits to this file will be LOST on next system rebuild.\n"
+ "\n"
+ "\n"
;
old_body = if (string::length_in_bytes old_text > string::length_in_bytes new_header) string::extract (old_text, string::length_in_bytes new_header, NULL);
else "";
fi;
if (*err::error_count == 0)
#
print (" sourcecode-making-junk.pkg: Generating " + filepath + " ... ");
if (old_body == new_body) # We don't compare headers because the dates will always differ.
#
print "file is unchanged.\n";
else
new_text = new_header + new_body;
dir = winix__premicrothread::path::dir filepath;
winix__premicrothread::file::make_directory dir except _ = ();
stream = fil::open_for_write filepath;
fil::write (stream, new_text);
fil::close_output stream;
print "done.\n";
fi;
fi;
fi;
# Emit code into a file:
#
fun write_sourcecode_file
{
architecture_description,
created_by_package, # E.g. "src/lib/compiler/back/low/tools/arch/make-sourcecode-for-registerkinds-xxx-package.pkg".
subdir, # Relative to file containing architecture description.
make_filename,
code
}
=
{ new_text
=
string::cat
[
spp::prettyprint_expression_to_string (spp::PUSH_MODE "code" ++ spp::CAT code),
"",
string::from_char '\^L',
"\n",
"##########################################################################\n",
"# The following is support for outline-minor-mode in emacs. #\n",
"# ^C @ ^T hides all Text. (Leaves all headings.) #\n",
"# ^C @ ^A shows All of file. #\n",
"# ^C @ ^Q Quickfolds entire file. (Leaves only top-level headings.) #\n",
"# ^C @ ^I shows Immediate children of node. #\n",
"# ^C @ ^S Shows all of a node. #\n",
"# ^C @ ^D hiDes all of a node. #\n",
"# ^HFoutline-mode gives more details. #\n",
"# (Or do ^HI and read emacs:outline mode.) #\n",
"# #\n",
"# Local variables: #\n",
"# mode: outline-minor #\n",
"# outline-regexp: \"[{ \\t]*\\\\(fun \\\\)\" #\n",
"# End: #\n",
"##########################################################################\n"
];
#
write_textfile architecture_description created_by_package subdir make_filename new_text;
};
fun error_handler architecture_description make_name_fn
=
rsj::error_fun_fn (make_name_fn (ard::architecture_name_of architecture_description));
# Emit a function that dispatches
# to subfunctions according to the
# register kind:
#
fun make_query_by_registerkind architecture_description name' # Invoked (only) in src/lib/compiler/back/low/tools/arch/adl-gen-instruction-props.pkg =
{ registersets = ard::registersets_of architecture_description;
client_defined
=
list::filter
#
(\\ raw::REGISTER_SET { name, alias, ... }
=
not (not_null alias) and
not (rsp::is_predefined_registerkind name) and
not (rsp::is_pseudo_registerkind name)
)
#
registersets;
newly_defined
=
case client_defined
#
[] => [ raw::CLAUSE( [ raw::WILDCARD_PATTERN ], NULL, rsj::app ("error", rsj::string_constant_in_expression name')) ];
#
_ => [ raw::CLAUSE([ raw::IDPAT "k" ], NULL,
#
fold_backward
#
(\\ (raw::REGISTER_SET { name, alias, ... }, e)
=
raw::IF_EXPRESSION
(
rsj::app ( "=",
raw::TUPLE_IN_EXPRESSION [ rsj::id "k",
raw::ID_IN_EXPRESSION (raw::IDENT (["C"], name))
]
),
rsj::id (name' + name),
e
)
)
#
(rsj::app ("error", rsj::string_constant_in_expression name')) client_defined)
];
esac;
predefined
=
fold_backward
#
(\\ (raw::REGISTER_SET { name, alias, ... }, c)
=
if (rsp::is_predefined_registerkind name
and not (rsp::is_pseudo_registerkind name))
#
raw::CLAUSE
(
[ raw::CONSPAT (raw::IDENT(["C"], name), NULL)],
NULL,
case alias NULL => rsj::id (name' + name);
THE alias => rsj::app (name', raw::ID_IN_EXPRESSION (raw::IDENT(["C"], alias)));
esac
)
!
c;
else
c;
fi
)
#
newly_defined
registersets;
raw::FUN_DECL [ raw::FUN (name', predefined) ];
};
# Map all real registersets in 'architecture_description' by 'f':
#
fun forall_user_registersets architecture_description f
=
map f
(list::filter
(\\ raw::REGISTER_SET { name, alias, ... }
=
not (rsp::is_pseudo_registerkind name)
and not (not_null alias)
)
(ard::registersets_of architecture_description)
);
}; # package architecture_description
end; # stipulate