## translate-nextcode-to-treecode-g.pkg --- translate nextcode to treecode (and then all the way on down to execode -- raw binary executable machine code).
#
# CONTEXT:
#
# The Mythryl compiler code representations used are, in order:
#
# 1) Raw Syntax is the initial frontend code representation.
# 2) Deep Syntax is the second and final frontend code representation.
# 3) Lambdacode (a polymorphically typed lambda-calculus format) is the first backend code representation, used only transitionally.
# 4) Anormcode (A-Normal format, which preserves expression tree structure) is the second backend code representation, and the first used for optimization.
# 5) Nextcode ("continuation-passing style", a single-assignment basic-block-graph form where call and return are essentially the same) is the third and chief backend tophalf code representation.
# 6) Treecode is the backend tophalf/lowhalf transitional code representation. It is typically slightly specialized for each target architecture, e.g. Intel32 (x86).
# 7) Machcode abstracts the target architecture machine instructions. It gets specialized for each target architecture.
# 8) Execode is absolute executable binary machine instructions for the target architecture.
#
# For general context, see
#
# src/A.COMPILER-PASSES.OVERVIEW
#
# This package implements the transition from the
# machine-independent backend tophalf centered on
#
# src/lib/compiler/back/top/main/backend-tophalf-g.pkg #
# to the machine-dependent backend lowhalf centered on
#
# src/lib/compiler/back/low/main/main/backend-lowhalf-g.pkg#
# The lowhalf started out as MLRISC, a compiler-agnostic backend,
# and consequently knows nothing of such Mythryl-specific details
# as Tagged_Int tagging and heap-record tagging and layout, so much of
# our work in this file consists of translating such constructs
# into the low-level load/store/add/branch/... machinecode idiom.
#
# In more concrete terms, this package implements the translation
# from frontend Nextcode (aka "continuation passing style") down
# to backend "Treecode" code format.
#
# Subsequent translation from Treecode down to machcode format is
# delegated to one of
#
# src/lib/compiler/back/low/pwrpc32/treecode/translate-treecode-to-machcode-pwrpc32-g.pkg# src/lib/compiler/back/low/sparc32/treecode/translate-treecode-to-machcode-sparc32-g.pkg# src/lib/compiler/back/low/intel32/treecode/translate-treecode-to-machcode-intel32-g.pkg#
#
#
# Specific tasks performed in this file include:
#
# o Convert fun bodies from linear-sequence-of-instructions
# form to tree form, by entering each codetemp definition
# into the appropriate one of
# codetemp_to_tcf_int_expression__hashtable
# codetemp_to_tcf_float_expression__hashtable
# and then retrieving those tree fragments as we encounter
# later parts of the expression. (nextcode-form necessarily
# computes expressions from the leafs upward, so we will
# always encounter the leafs of each subexpression before
# the root.
# This treeification lets us later use the Sethi-Ullman
# algorithm to re-linearize the code in such a way as to
# minimize register pressure, basically by, for each binary
# math op, computing the more complex operand first -- see
# src/lib/compiler/back/low/intel32/treecode/translate-treecode-to-machcode-intel32-g.pkg# We also use Sethi-Ullman in:
# src/lib/compiler/back/low/intel32/regor/regor-intel32-g.pkg# The tophalf has a (broken, unused) version in:
# src/lib/compiler/back/top/lambdacode/generalized-sethi-ullman-reordering.pkg#
# o Generate code to log all boxed updates to heap_changelog.
# The heap_changelog is essentially a list of CONS cells
# recording all stores of pointers into the heap; the
# heapcleaner uses it to track all pointers from old
# heap generations into younger ones -- multigeneration
# heapcleaning ("garbage collection") is impossible without
# this information. (See calls to log_boxed_update_to_heap_changelog.)
#
# o Expand abstract slot accesses into concrete sequence of
# ram-read instructions. In more detail:
#
# We try to pack closures into registers, but some won't fit,
# so in general a closure can be a heap record. In fact, we
# share parts of some closures, so a complete closure can be
# a depth-two tree of heap records. A related set of closures
# is then technically a depth-two "lattice", since each leaf
# may be referenced by multiple root records.
#
# Nextcode refers to closure slots abstractly, suppressing
# the lattice structure, but Treecode knows nothing about our
# closure structure, so as part of Nextcode -> Treecode translation
# we must translate each closure-slot reference into a concrete
# series of load and add instructions that do the right memory
# fetches from the right record offsets to return the desired value.
# Closures are read-only so we don't have to handle slot writes.
# (Search for VIA_SLOT.)
#
#
# o Compile Tagged_Int arithmetic operations down into sequences
# of vanilla 32-bit integer operations. (See fun tagged_*...)
#
#
#
# o The Nextcode distinction between signed and unsigned
# operands goes away in Treecode, so the un/signed-agnostic
# Nextcode binary operators get replaced by Treecode binary
# operators which are explicitly signed or unsigned. (See
# to_tcf_unsigned_compare and friends.)
#
#
#
#
# Our compiletime generic invocation is from
#
# src/lib/compiler/back/low/main/main/backend-lowhalf-g.pkg#
# which in particular passes us the
#
# translate_machcode_cccomponent_to_execode # "machcode" == "(abstract) machine code"
# # "cccomponent" == "callgraph connected-component" (we compile them one at a time).
# function which is our runtime entrypoint into the
# back end.
#
#
#
# Runtime invocation of our (sole)
#
# translate_nextcode_to_execode
#
# entrypoint is from
#
# src/lib/compiler/back/top/main/backend-tophalf-g.pkg#
# via the short wrapper at the bottom of
#
# src/lib/compiler/back/low/main/main/backend-lowhalf-g.pkg#
#
# In terms of lines-of-code, this file is utterly dominated by
#
# fun translate_nextcode_to_execode -- 3500 of 4000 line
#
# which in turn is internally dominated by
#
# fun translate_nextcode_cccomponent_to_treecode -- 3200 of 4000 lines.
#
# The core function, and perhaps the best place to start
# reading, is
#
# translate_nextcode_ops_to_treecode
#
# "This version of translate_nextcode_to_treecode_g also
# injects heapcleaner ("garbage-collector") types into
# the backend lowhalf.
# I've also reorganized it a bit and added a few comments
# so that I can understand it."
# -- Allen Leung (?)
# Compiled by:
# src/lib/compiler/core.sublib### "Do not say a little in many words,
### but a great deal in a few."
###
### -- Pythagoras (582-497 BCE)
stipulate
package ds = deep_syntax; # deep_syntax is from src/lib/compiler/front/typer-stuff/deep-syntax/deep-syntax.pkg package err = error_message; # error_message is from src/lib/compiler/front/basics/errormsg/error-message.pkg package ncf = nextcode_form; # nextcode_form is from src/lib/compiler/back/top/nextcode/nextcode-form.pkg package pcs = per_compile_stuff; # per_compile_stuff is from src/lib/compiler/front/typer-stuff/main/per-compile-stuff.pkgherein
api Translate_Nextcode_To_Treecode {
#
translate_nextcode_to_execode
:
{ nextcode_functions: List( ncf::Function ),
err: err::Plaint_Sink,
source_name: String, # Typically filename, something like "<stdin>" if compiling interactively.
per_compile_stuff: pcs::Per_Compile_Stuff( ds::Declaration ),
fun_id__to__max_resource_consumption # Given
: # a
ncf::Codetemp # fun_id
-> # return
{ max_possible_heapwords_allocated_before_next_heaplimit_check: Int, # max possible words of heap memory allocated on any path through function body, and
max_possible_nextcode_ops_run_before_next_heaplimit_check: Int # max possible nextcode instructions executed on any path through function body.
}
}
->
(Void -> Int);
# The result is a thunk computing the machinecode bytevector
# offset for entrypoint corresponding to the first function
# in nextcode_functions.
#
# The client must call 'finish' before forcing it.
};
end;
# Machine_Properties is from src/lib/compiler/back/low/main/main/machine-properties.apistipulate
package chi = per_codetemp_heapcleaner_info; # per_codetemp_heapcleaner_info is from src/lib/compiler/back/low/main/nextcode/per-codetemp-heapcleaner-info.pkg package coc = compiler_controls; # compiler_controls is from src/lib/compiler/toplevel/main/compiler-controls.pkg package ctl = global_controls; # global_controls is from src/lib/compiler/toplevel/main/global-controls.pkg package ds = deep_syntax; # deep_syntax is from src/lib/compiler/front/typer-stuff/deep-syntax/deep-syntax.pkg package fbp = guess_nextcode_branch_probabilities; # guess_nextcode_branch_probabilities is from src/lib/compiler/back/low/main/nextcode/guess-nextcode-branch-probabilities.pkg package ffc = find_nextcode_cccomponents; # find_nextcode_cccomponents is from src/lib/compiler/back/low/main/nextcode/find-nextcode-cccomponents.pkg package iht = int_hashtable; # int_hashtable is from src/lib/src/int-hashtable.pkg package lbl = codelabel; # codelabel is from src/lib/compiler/back/low/code/codelabel.pkg package lem = lowhalf_error_message; # lowhalf_error_message is from src/lib/compiler/back/low/control/lowhalf-error-message.pkg package lhn = lowhalf_notes; # lowhalf_notes is from src/lib/compiler/back/low/code/lowhalf-notes.pkg package ncf = nextcode_form; # nextcode_form is from src/lib/compiler/back/top/nextcode/nextcode-form.pkg package pb = pseudo_op_basis_type; # pseudo_op_basis_type is from src/lib/compiler/back/low/mcg/pseudo-op-basis-type.pkg package pby = probability; # probability is from src/lib/compiler/back/low/library/probability.pkg package pcs = per_compile_stuff; # per_compile_stuff is from src/lib/compiler/front/typer-stuff/main/per-compile-stuff.pkg package pl = paired_lists; # paired_lists is from src/lib/std/src/paired-lists.pkg package ppn = prettyprint_nextcode; # prettyprint_nextcode is from src/lib/compiler/back/top/nextcode/prettyprint-nextcode.pkg package pt = nextcode_ramregions::pt; # nextcode_ramregions is from src/lib/compiler/back/low/main/nextcode/nextcode-ramregions.pkg package rgn = nextcode_ramregions; # nextcode_ramregions is from src/lib/compiler/back/low/main/nextcode/nextcode-ramregions.pkg package rkj = registerkinds_junk; # registerkinds_junk is from src/lib/compiler/back/low/code/registerkinds-junk.pkg package uvf = use_virtual_framepointer_in_cccomponent; # use_virtual_framepointer_in_cccomponent is from src/lib/compiler/back/low/main/main/use-virtual-framepointer-in-cccomponent.pkgherein
# This generic is invoked from:
#
# src/lib/compiler/back/low/main/main/backend-lowhalf-g.pkg #
generic package translate_nextcode_to_treecode_g (
# ================================
# # machine_properties_intel32 is from src/lib/compiler/back/low/main/intel32/machine-properties-intel32.pkg # # machine_properties_pwrpc32 is from src/lib/compiler/back/low/main/pwrpc32/machine-properties-pwrpc32.pkg # # machine_properties_sparc32 is from src/lib/compiler/back/low/main/sparc32/machine-properties-sparc32.pkg package mp: Machine_Properties; # Machine_Properties is from src/lib/compiler/back/low/main/main/machine-properties.api package trx: Treecode_Extension_Mythryl; # Treecode_Extension_Mythryl is from src/lib/compiler/back/low/main/nextcode/treecode-extension-mythryl.api # platform_register_info_intel32 is from src/lib/compiler/back/low/main/intel32/backend-lowhalf-intel32-g.pkg # platform_register_info_pwrpc32 is from src/lib/compiler/back/low/main/pwrpc32/backend-lowhalf-pwrpc32.pkg # platform_register_info_sparc32 is from src/lib/compiler/back/low/main/sparc32/backend-lowhalf-sparc32.pkg package pri: Platform_Register_Info # Platform_Register_Info is from src/lib/compiler/back/low/main/nextcode/platform-register-info.api where # "pri" == "nextcode_registers".
tcf::rgn == nextcode_ramregions # "rgn" == "region"
also tcf::lac == late_constant # late_constant is from src/lib/compiler/back/low/main/nextcode/late-constant.pkg also tcf::trx == trx; # "trx" == "treecode_extension".
# "tcf" == "treecode_form".
package cpo: Client_Pseudo_Ops_Mythryl; # Client_Pseudo_Ops_Mythryl is from src/lib/compiler/back/low/main/nextcode/client-pseudo-ops-mythryl.api # "cpo" == "client_pseudo_op".
package pop: Pseudo_Ops # Pseudo_Ops is from src/lib/compiler/back/low/mcg/pseudo-op.api where # "pop" == "pseudo_ops".
tcf == pri::tcf # "tcf" == "treecode_form".
also cpo == cpo; # "cpo" == "client_pseudo_ops".
# translate_treecode_to_machcode_intel32_g is from src/lib/compiler/back/low/intel32/treecode/translate-treecode-to-machcode-intel32-g.pkg package t2m: Translate_Treecode_To_Machcode # Translate_Treecode_To_Machcode is from src/lib/compiler/back/low/treecode/translate-treecode-to-machcode.api where # "t2m" == "translate_treecode_to_machcode".
tcs::tcf == pri::tcf # "tcf" == "treecode_form".
also tcs::cst::pop == pop; # "pop" == "pseudo_op".
package mkg # make_machcode_codebuffer_g is from src/lib/compiler/back/low/mcg/make-machcode-codebuffer-g.pkg : Make_Machcode_Codebuffer # Make_Machcode_Codebuffer is from src/lib/compiler/back/low/mcg/make-machcode-codebuffer.api where
cst == t2m::tcs::cst # "cst" == "codestream".
also mcf == t2m::mcf # "mcf" == "machcode_form" (abstract machine code).
also mcg == t2m::mcg; # "mcg" == "machcode_controlflow_graph".
# put_treecode_heapcleaner_calls_g is from src/lib/compiler/back/low/main/nextcode/emit-treecode-heapcleaner-calls-g.pkg package ihc: Emit_Treecode_Heapcleaner_Calls # Emit_Treecode_Heapcleaner_Calls is from src/lib/compiler/back/low/main/nextcode/emit-treecode-heapcleaner-calls.api where # "ihc" == "insert_treecode_heapcleaner_calls".
tcs == t2m::tcs # "tcs" == "treecode_stream".
also mcg == mkg::mcg; # "mcg" == "machcode_controlflow_graph".
package rgk: Registerkinds; # Registerkinds is from src/lib/compiler/back/low/code/registerkinds.api package cal: Ccalls # Ccalls is from src/lib/compiler/back/low/ccalls/ccalls.api where # "cal" == "ccalls".
tcf == pri::tcf; # "tcf" == "treecode_form".
translate_machcode_cccomponent_to_execode
:
pcs::Per_Compile_Stuff( ds::Declaration )
->
mkg::mcg::Machcode_Controlflow_Graph
->
Void;
)
: (weak) Translate_Nextcode_To_Treecode # Defined above.
{
stipulate
package tag = mp::heap_tags; # Mythryl heapchunk tagwords.
package tcf = pri::tcf; # "tcf" == "treecode_form".
package tcs = t2m::tcs; # "tcs" == "treecode_stream".
package cfa # "cfs" == "convert fun arguments"
=
convert_nextcode_fun_args_to_treecode_g ( # convert_nextcode_fun_args_to_treecode_g is from src/lib/compiler/back/low/main/nextcode/convert-nextcode-fun-args-to-treecode-g.pkg #
package pri = pri; # "pri" == "platform register info".
package mp = mp; # "mp" == "machine_properties".
);
# Decompose a package ("compilation unit")
# callgraph into connected components:
#
package nfs # "nfs" == "nextcode_function_stack".
=
nextcode_function_stack_g ( tcf ); # nextcode_function_stack_g is from src/lib/compiler/back/low/main/nextcode/nextcode-function-stack-g.pkg package ma # Memory aliasing
=
memory_aliasing_g ( # memory_aliasing_g is from src/lib/compiler/back/low/main/nextcode/memory-aliasing-g.pkg #
package rgk = rgk; # "rgk" == "registerkinds".
);
package fcc # C-Calls handling
=
nextcode_c_calls_g ( # nextcode_c_calls_g is from src/lib/compiler/back/low/main/nextcode/nextcode-ccalls-g.pkg #
package mp = mp; # "mp" == "machine_properties".
package pri = pri; # "pri" == "nextcode_registers".
package t2m = t2m; # "t2m" == "translate_treecode_to_machcode".
package rgk = rgk; # "rgk" == "registerkinds".
package cal = cal; # "cal" == "ccalls".
);
herein
#
fun error msg
=
lem::error("translate_nextcode_to_treecode_g", msg);
# Debugging:
#
fun print_nextcode_fun nextcode_fn
=
{ ctl::print::say "*********************************************** \n";
ppn::print_nextcode_function nextcode_fn;
ctl::print::say "*********************************************** \n";
ctl::print::flush();
};
print = ctl::print::say;
####################################################################
# Heapcleaner ("garbage collection") safety.
# This stuff matters only if
# lowhalf_track_heapcleaner_type_info
# is TRUE, which it currently never is:
package hr
= # How to annotate heapcleaner (garbage collector) information.
codetemps_with_heapcleaner_info_g ( # codetemps_with_heapcleaner_info_g is from src/lib/compiler/back/low/heapcleaner-safety/codetemps-with-heapcleaner-info-g.pkg #
package rgk = rgk; # "rgk" == "registerkinds".
package chi = chi; # "chi" == "per_codetemp_heapcleaner_info".
);
no_opt = [lhn::no_optimization.x_to_note ()];
#
fun same_reg_as x y
=
rkj::same_id (x, y);
ptr_type = lhn::mark_reg.x_to_note (\\ r = hr::set_heapcleaner_info_on_codetemp_info (r, chi::ptr_type)); # Boxed chunks
i32_type = lhn::mark_reg.x_to_note (\\ r = hr::set_heapcleaner_info_on_codetemp_info (r, chi::i32_type)); # untagged integers
i31_type = lhn::mark_reg.x_to_note (\\ r = hr::set_heapcleaner_info_on_codetemp_info (r, chi::i31_type)); # tagged integers
f64_type = lhn::mark_reg.x_to_note (\\ r = hr::set_heapcleaner_info_on_codetemp_info (r, chi::f64_type)); # untagged floats
#
fun ncftype_to_note ncf::typ::INT => i31_type;
ncftype_to_note ncf::typ::INT1 => i32_type;
ncftype_to_note ncf::typ::FLOAT64 => f64_type;
ncftype_to_note _ => ptr_type;
end;
# Convert kind+bitsize to heapcleaner type.
# Kind is INT/UNT/FLOAT:
#
fun kind_and_size_to_heapcleaner_type (ncf::p::INT 31) => chi::i31_type; # 64-bit issue: '31' is bits-per-tagged-int.
kind_and_size_to_heapcleaner_type (ncf::p::UNT 31) => chi::i31_type; # 64-bit issue: '31' is bits-per-tagged-unt.
kind_and_size_to_heapcleaner_type (ncf::p::INT 32) => chi::i32_type; # 64-bit issue: '31' is bits-per-tagged-int.
kind_and_size_to_heapcleaner_type (ncf::p::UNT 32) => chi::i32_type; # 64-bit issue: '31' is bits-per-tagged-unt.
#
kind_and_size_to_heapcleaner_type (_ ) => error "kind_and_size_to_heapcleaner_type";
end;
#
fun ncftype_to_heapcleaner_type (ncf::typ::FLOAT64) => chi::f64_type;
ncftype_to_heapcleaner_type (ncf::typ::INT ) => chi::i31_type;
ncftype_to_heapcleaner_type (ncf::typ::INT1 ) => chi::i32_type;
ncftype_to_heapcleaner_type _ => chi::ptr_type;
end;
# Make a heapcleaner livein/liveout annotation.
# This is a list of (register_id, heapcleaner_type) pairs:
#
fun make_heapcleaner_liveinliveout_note
(
an,
args, # Formal args (i.e., parameters).
ncftypes # Types of formal args -- this list will always be same length as 'args'.
)
=
an (collect (args, ncftypes, []))
where
fun collect ( tcf::INT_EXPRESSION ( tcf::CODETEMP_INFO(_, r)) ! args, ncftype ! ncftypes, results) => collect (args, ncftypes, (r, ncftype_to_heapcleaner_type ncftype) ! results);
collect (tcf::FLOAT_EXPRESSION (tcf::CODETEMP_INFO_FLOAT(_, r)) ! args, ncftype ! ncftypes, results) => collect (args, ncftypes, (r, ncftype_to_heapcleaner_type ncftype) ! results);
collect (_ ! args, _ ! ncftypes, results)
=>
collect (args, ncftypes, results);
collect ([], [], results)
=>
results;
collect _ => error "make_heapcleaner_liveinliveout_note";
end;
end;
# These are the type widths of Mythryl.
# They are hardwired for now.
#
ptr_bitsize = 32; # Size of Mythryl's pointer XXX SUCKO FIXME 64-BIT ISSUE
int_bitsize = 32; # Size of Mythryl's integer XXX SUCKO FIXME 64-BIT ISSUE
flt_bitsize = 64; # Size of Mythryl's real number
zero = tcf::LITERAL 0;
one = tcf::LITERAL 1;
two = tcf::LITERAL 2;
tagged_zero = one;
offp0 = ncf::SLOT 0;
#
fun int i = tcf::LITERAL (tcf::mi::from_int (int_bitsize, i)); # "li" == "int-literal".
fun unt u = tcf::LITERAL (tcf::mi::from_unt1 (int_bitsize, u)); # "lu" == "unt-literal".
const_base_pointer_reg_offset
=
int mp::const_base_pointer_reg_offset;
# The heap allocation pointer -- we allot
# heap memory just by advancing this pointer.
# It must be in a true hardware register: # i.e., not in an Intel32 ramreg -- a stack slot used as a workaround for the register shortage on that architecture.
#
heap_allocation_pointer_register
=
case pri::heap_allocation_pointer
#
tcf::CODETEMP_INFO (_, heap_allocation_pointer_register) => heap_allocation_pointer_register;
_ => error "heap_allocation_pointer_register";
esac;
global_registers # Global registers allocated statically by hand.
=
map (\\ r = tcf::INT_EXPRESSION (tcf::CODETEMP_INFO (int_bitsize, r))) pri::global_int_registers # On intel32 this is ESP and EDI.
@
map (\\ f = tcf::FLOAT_EXPRESSION (tcf::CODETEMP_INFO_FLOAT (flt_bitsize, f))) pri::global_float_registers; # On intel32 there are no globally allocated float registers -- they are all available to the register allocator.
global_registers # On sparc32 and pwrpc32 we also globally dedicate a condition code register to heaplimit checks.
=
case pri::heap_is_exhausted__test
#
THE cc => tcf::FLAG_EXPRESSION cc ! global_registers; # "cc" is "condition code" -- zero/parity/overflow/... flag stuff.
NULL => global_registers;
esac;
do_extra_lowhalf_optimizations # This flag controls whether extra lowhalf optimizations should be performed. Defaults to FALSE.
= # XXX BUGGO FIXME icky thread-hostile global mutable state.
ctl::lowhalf::make_bool #
( "do_extra_lowhalf_optimizations",
"whether to do lowhalf optimizations"
);
track_types_for_heapcleaner # XXX BUGGO FIXME icky thread-hostile global mutable state.
=
ctl::lowhalf::make_bool # Defaults to FALSE.
( "track_types_for_heapcleaner",
"whether to track heapcleaner type info"
); # If this flag is TRUE then annotate the
# codetemps with heapcleaner type info;
# otherwise use the default behavior.
#
# This flag is always FALSE; I think
# this is another unfinished project.
# The relevant files appear to be:
#
# src/lib/compiler/back/low/heapcleaner-safety/per-codetemp-heapcleaner-info-template.api # src/lib/compiler/back/low/main/nextcode/per-codetemp-heapcleaner-info.api # src/lib/compiler/back/low/main/nextcode/per-codetemp-heapcleaner-info.pkg # src/lib/compiler/back/low/heapcleaner-safety/codetemps-with-heapcleaner-info.api # src/lib/compiler/back/low/heapcleaner-safety/codetemps-with-heapcleaner-info-g.pkg lowhalf_optimize_before_making_heapcleaner_code # XXX BUGGO FIXME icky thread-hostile global mutable state.
=
ctl::lowhalf::make_bool # Defaults to FALSE.
( "lowhalf_optimize_before_making_heapcleaner_code",
"whether to optimize before generating heapcleaner code"
); # If this flag is on then we do optimizations before generating heapcleaner code.
# If this flag is on then track_types_for_heapcleaner must also be turned on!
# Otherwise use the default behavior.
split_entry_block # XXX BUGGO FIXME icky thread-hostile global mutable state.
=
ctl::lowhalf::make_bool # Defaults to FALSE.
( "split_entry_block",
"whether to split entry block"
); # If this flag is on then split the entry block.
# This should be on for SSA optimizations.
empty_block = lhn::empty_block.x_to_note (); # Dummy annotation used to get an empty block.
tagword_to_int = large_unt::to_int; # Converts heap-record tagword to int.
# The main code generation function.
#
# This represents the major entrypoint into
# the machine-dependent backend lower half
# from the machine-independent upper half.
#
# We are called from translate_anormcode_to_execode in
#
# src/lib/compiler/back/top/main/backend-tophalf-g.pkg fun translate_nextcode_to_execode
{
nextcode_functions: List( ncf::Function ), # All the functions for a complete package ("compilation unit").
fun_id__to__max_resource_consumption # Given
: # a
ncf::Codetemp # fun_id
-> # return
{ max_possible_heapwords_allocated_before_next_heaplimit_check: Int, # max possible words of heap memory allocated before next heaplimit check, and
max_possible_nextcode_ops_run_before_next_heaplimit_check: Int # max possible nextcode instructions executed before next heaplimit check.
},
err,
source_name, # Typically sourcefile name, something like "<stdin>" if compiling interactively.
per_compile_stuff
}
=
{ apply note_entrypoint_label_and_type nextcode_functions;
#
cccomponents = ffc::find_nextcode_cccomponents nextcode_functions; # Break the 'nextcode_functions' callgraph up into connected components.
apply translate_nextcode_cccomponent_to_treecode cccomponents; # This is where all the work is...
finish_compilation_unit source_name;
# Here we construct and return to caller a thunk which computes the
# entrypoint offset into the machinecode bytevector. (This is the
# address which at linktime will be called with a table of all loaded
# packages; the package will note all needed resources and return
# its own list of exported functions and other values.)
#
# The idea is that in principle this address could be anywhere in the
# compiled code, and the address might not be fixed until the sizes of
# span-depdendent instructions (i.e., pc-relative jumps) has been decided,
# so our caller should finish code generation before calling this thunk.
#
# In practice the entrypoint is always zero, and this whole charade
# could and maybe should be dispensed with.
get_entrypoint_offset_of_first_function nextcode_functions; # A (Void -> Int) thunk returning entrypoint offset into machinecode bytevector.
} # (In practice this is currently always zero.)
where
max_possible_heapwords_allocated_before_next_heaplimit_check
=
.max_possible_heapwords_allocated_before_next_heaplimit_check o fun_id__to__max_resource_consumption;
split_entry_block = *split_entry_block;
# These functions generate new codetemps and
# mark expressions with their heapcleaner types.
#
# When the heapcleaner-safety feature is turned on,
# we'll use the versions of make_int_codetemp_info that automatically
# update the heapcleaner-map.
#
# Otherwise, we'll just use the normal version.
track_types_for_heapcleaner = *track_types_for_heapcleaner;
my ( make_int_codetemp_info,
make_int_codetemp_info_with_ncftype,
make_int_codetemp_info_with_kind_and_size,
make_float_codetemp_info
)
=
if (not track_types_for_heapcleaner) # Currently track_types_for_heapcleaner is ALWAYS FALSE.
#
( rgk::make_int_codetemp_info, # We're not tracking heapcleaner types for the backend lowhalf, so no extra work to do here.
rgk::make_int_codetemp_info,
rgk::make_int_codetemp_info,
rgk::make_float_codetemp_info
);
else
# We're tracking heapcleaner types for the backend lowhalf,
# so redefine our make-codetemp fns to track heapcleaner info:
#
make_int_codetemp_info = hr::make_codetemp_info_of_kind rkj::INT_REGISTER; # Currying is important here for efficiency -- make_codetemp_info_of_kind is slow,
make_float_codetemp_info = hr::make_codetemp_info_of_kind rkj::FLOAT_REGISTER; # but make_int_codetemp_info is fast.
#
fun make_int_codetemp_info_with_ncftype ncftype
=
make_int_codetemp_info (ncftype_to_heapcleaner_type ncftype);
#
fun make_int_codetemp_info_with_kind_and_size kind_and_size
=
make_int_codetemp_info (kind_and_size_to_heapcleaner_type kind_and_size);
( make_int_codetemp_info,
make_int_codetemp_info_with_ncftype,
make_int_codetemp_info_with_kind_and_size,
make_float_codetemp_info
);
fi;
# Maybe wrap heapcleaner type around ptr/i32/flt:
#
fun hc_ptr e = if track_types_for_heapcleaner tcf::RNOTE (e, ptr_type); else e; fi;
fun hc_i32 e = if track_types_for_heapcleaner tcf::RNOTE (e, i32_type); else e; fi;
fun hc_flt e = if track_types_for_heapcleaner tcf::FNOTE (e, f64_type); else e; fi;
#
fun maybe_note_type_for_heapcleaner (e, ncftype)
=
track_types_for_heapcleaner ?? tcf::RNOTE (e, ncftype_to_note ncftype)
:: e;
#
fun mark_nothing e
=
e;
# Private ("all-callers-known") functions have
# parameters passed in fresh temporaries.
#
# We (may) also annotate the heapcleaner types of these temporaries:
#
fun translate_function_formal_args_from_nextcode_to_treecode_form (ncftype ! rest)
=>
case ncftype
#
ncf::typ::FLOAT64 => tcf::FLOAT_EXPRESSION (tcf::CODETEMP_INFO_FLOAT (flt_bitsize, make_float_codetemp_info chi::f64_type));
#
ncf::typ::INT => tcf::INT_EXPRESSION (tcf::CODETEMP_INFO (int_bitsize, make_int_codetemp_info chi::i31_type));
ncf::typ::INT1 => tcf::INT_EXPRESSION (tcf::CODETEMP_INFO (int_bitsize, make_int_codetemp_info chi::i32_type));
_ => tcf::INT_EXPRESSION (tcf::CODETEMP_INFO (ptr_bitsize, make_int_codetemp_info chi::ptr_type));
esac
!
translate_function_formal_args_from_nextcode_to_treecode_form rest;
translate_function_formal_args_from_nextcode_to_treecode_form []
=>
[];
end;
# fun_id__to__codelabel__hashtable maps function ids
# (ncf::lvars -- in practice, ints) to the codelabels
# for those functions.
#
# If the flag split_entry_block is on we also
# distinguish between public and privatel labels,
# making sure that no branches go directly to the
# public labels.
exception LABEL_BIND;
exception TYPE_TABLE;
stipulate
my fun_id__to__codelabel__hashtable: iht::Hashtable ( lbl::Codelabel )
= iht::make_hashtable { size_hint => 32, not_found_exception => LABEL_BIND };
herein
get_codelabel_for_fun_id = iht::get fun_id__to__codelabel__hashtable;
set_codelabel_for_fun_id = iht::set fun_id__to__codelabel__hashtable;
end;
#
stipulate
ncflvar_to_ncftype = iht::make_hashtable { size_hint => 32, not_found_exception => TYPE_TABLE } # ncflvar_to_ncftype is a mapping of ncf::lvars to nextcode types
: iht::Hashtable ( ncf::Type );
herein
set_ncftype_for_codetemp = iht::set ncflvar_to_ncftype;
get_ncftype_for_codetemp = iht::get ncflvar_to_ncftype; # This maps nextcode value expressions to nextcode types.
end;
#
fun note_entrypoint_label_and_type (callers_info, fun_id, _, _, _) # define the labels and ncftype for all nextcode functions.
=
{ set_codelabel_for_fun_id (fun_id, lbl::make_anonymous_codelabel()); # Private label.
#
if split_entry_block # Public label.
#
case callers_info
#
(ncf::FATE_FN | ncf::PUBLIC_FN)
=>
set_codelabel_for_fun_id
(
-fun_id - 1, # This -fun_id - 1 crap could be simplified to just -f if we just guaranteed that all valid labels are nonzero. XXX SUCKO FIXME.
lbl::make_codelabel_generator (int::to_string fun_id) ()
);
_ => ();
esac;
fi;
case callers_info
#
ncf::FATE_FN => set_ncftype_for_codetemp (fun_id, ncf::typ::FATE);
_ => set_ncftype_for_codetemp (fun_id, ncf::bogus_pointer_type);
esac;
}; # fun note_entrypoint_label_and_type
#
fun_id__to__branch_probability
=
fbp::guess_nextcode_branch_probabilities nextcode_functions # Compute probabilities, stash them in a hashtable, return lookup function.
:
ncf::Codetemp -> Null_Or(pby::Probability);
#
fun branch_with_probability (branch, THE probability) => tcf::NOTE (branch, lhn::branch_probability.x_to_note probability);
branch_with_probability (branch, NULL ) => branch;
end;
# A nextcode register may be implemented as a physical
# register or a memory location. This function moves
# a value v into a register or a memory location. # "rreg" == "reg_or_ramreg".
#
fun set_rreg (tcf::CODETEMP_INFO (type, r), v) => tcf::LOAD_INT_REGISTER (type, r, v);
set_rreg (tcf::LOAD (type, ea, mem), v) => tcf::STORE_INT (type, ea, v, mem);
set_rreg _ => error "set_rreg";
end;
# Translate one nextcode cccomponent to # "cccomponent" == "callgraph connected-component".
# treecode (and thence immediately to machcode):
#
fun translate_nextcode_cccomponent_to_treecode
#
(cccomponent: List( ncf::Function ))
#
: Void # Void because results are side-effected :-( onto dataseg_list and textseg_list in
# #
# # src/lib/compiler/back/low/jmp/squash-jumps-and-write-code-to-code-segment-buffer-intel32-g.pkg # # src/lib/compiler/back/low/jmp/squash-jumps-and-write-code-to-code-segment-buffer-pwrpc32-g.pkg = # src/lib/compiler/back/low/jmp/squash-jumps-and-write-code-to-code-segment-buffer-sparc32-g.pkg { if *ctl::debugging
#
apply
ppn::print_nextcode_function
cccomponent; # cccomponent is just a List( ncf::Function ).
fi;
(t2m::make_treecode_to_machcode_codebuffer (mkg::make_machcode_codebuffer ())) # make_machcode_codebuffer is from src/lib/compiler/back/low/mcg/make-machcode-codebuffer-g.pkg ->
buf;
# The above constructs the wrapped codebuffer which
# translates treecode to machine code and then holds
# the resulting machcode until asked to regurgitate it.
#
# We're going to do lots of
#
# buf.put_op( treecode_expression )
#
# calls to construct our machine-code controlflow
# graph (while simultaneously translating from treecode
# to machcode) and then one
#
# result = buf.get_completed_cccomponent ...
#
# call to retrieve the resulting controlflow graph.
#
# The treecode_expression is translated to abstract machinecode by one of
#
# src/lib/compiler/back/low/intel32/treecode/translate-treecode-to-machcode-intel32-g.pkg # src/lib/compiler/back/low/pwrpc32/treecode/translate-treecode-to-machcode-pwrpc32-g.pkg # src/lib/compiler/back/low/sparc32/treecode/translate-treecode-to-machcode-sparc32-g.pkg #
# which in turn use put_* commands which drive
#
# src/lib/compiler/back/low/mcg/make-machcode-codebuffer-g.pkg #
# to construct an actual machine code controlflow graph, i.e. an instance of one of
#
# machcode_controlflow_graph_intel32 from src/lib/compiler/back/low/main/intel32/backend-lowhalf-intel32-g.pkg # machcode_controlflow_graph_pwrpc32 from src/lib/compiler/back/low/main/pwrpc32/backend-lowhalf-pwrpc32.pkg # machcode_controlflow_graph_sparc32 from src/lib/compiler/back/low/main/sparc32/backend-lowhalf-sparc32.pkg #
# all of which are generated by
#
# src/lib/compiler/back/low/mcg/machcode-controlflow-graph-g.pkg # per src/lib/compiler/back/low/mcg/machcode-controlflow-graph.api # If ncf::RAW_C_CALL is present we need
# to use the virtual frame pointer:
#
stipulate
#
fun has_raw_c_call ((_, _, _, _, cexp) ! rest) # There HAS to be a better way of tracking this information than
=> # doing a complete code pass here to get one bit of information. XXX SUCKO FIXME.
ncf::has_raw_c_call cexp
or
has_raw_c_call rest;
has_raw_c_call [] => FALSE;
end;
herein
use_virtual_framepointer
=
not mp::framepointer_never_virtual
and
has_raw_c_call cccomponent;
end;
uvf::use_virtual_framepointer # This gets read (only) one place -- fun stack_basepointer ()
:= # in src/lib/compiler/back/low/main/intel32/backend-lowhalf-intel32-g.pkg use_virtual_framepointer;
heap_is_exhausted__test
=
# This is the
#
# heap_allocation_pointer > heap_allocation_limit
#
# comparison test used -- when this is TRUE, it is time to
# run the heapcleaner ("garbage collector").
#
# We have a per-platform choice of signed vs unsigned comparisons.
#
# This usually doesn't matter, but some
# architectures work better one way or
# the other, so we are given a choice here.
#
tcf::CMP (
#
ptr_bitsize,
pri::use_signed_heaplimit_check
?? tcf::GT
:: tcf::GTU,
pri::heap_allocation_pointer,
pri::heap_allocation_limit use_virtual_framepointer
);
#############################################################
# Per-cccomponent tables
exception INT_REGISTER_MAP;
exception FLOAT_REGISTER_MAP;
exception GEN_TABLE;
stipulate
my fun_id__to__callers_info__hashtable: iht::Hashtable( nfs::Callers_Info )
=
iht::make_hashtable { size_hint => length cccomponent, not_found_exception => GEN_TABLE };
#
# Used to retrieve the arg passing convention
# once a function has been compiled.
herein
set__callers_info__for__fun_id = iht::set fun_id__to__callers_info__hashtable;
get__callers_info__for__fun_id = iht::get fun_id__to__callers_info__hashtable;
end;
# { fp, gp } RegTable -- mapping of lvars to registers
codetemp_to_tcf_float_expression__hashtable
#
= iht::make_hashtable { size_hint => 2, not_found_exception => FLOAT_REGISTER_MAP }
: iht::Hashtable( tcf::Float_Expression );
codetemp_to_tcf_int_expression__hashtable
#
= iht::make_hashtable { size_hint => 32, not_found_exception => INT_REGISTER_MAP }
: iht::Hashtable( tcf::Int_Expression );
set_int_def_for_codetemp = iht::set codetemp_to_tcf_int_expression__hashtable;
#
fun set_int_def_for_codetemp' (codetemp, r)
=
set_int_def_for_codetemp (codetemp, tcf::CODETEMP_INFO (int_bitsize, r));
# PRODUCTION VERSION:
# set_float_def_for_codetemp
# =
# iht::set codetemp_to_tcf_float_expression__hashtable;
# TEMPORARY DEBUG VERSION:
fun set_float_def_for_codetemp (arg as (x, t))
=
{
if *log::debugging
printf "set_float_def_for_codetemp (%d, ...)\n" x;
fi;
iht::set codetemp_to_tcf_float_expression__hashtable arg;
};
# The following function looks up
# the Treecode expression associated
# with a floating point value expression:
#
# get_tcf_float_expression_for_codetemp
# =
# iht::get codetemp_to_tcf_float_expression__hashtable;
fun get_tcf_float_expression_for_codetemp x
=
{
if *log::debugging
printf "get_tcp_float_expression_for_codetemp %d\n" x;
fi;
iht::get codetemp_to_tcf_float_expression__hashtable x;
};
#
fun def_for_float_codetemp (ncf::CODETEMP v) => get_tcf_float_expression_for_codetemp v;
def_for_float_codetemp _ => error "def_for_float_codetemp";
end;
# To do Sethi-Ullman register-use minimization -- see
#
# src/lib/compiler/back/low/intel32/treecode/translate-treecode-to-machcode-intel32-g.pkg #
# -- we now need to convert our linear
# code blocks into expression trees.
# To do this, we first classify each subexpression
# according to the number of times its value is used:
#
Codetemp_Use_Frequency
#
= NO_USES # Codetemp is never used -- it can be discarded if pure.
| ONE_USE # Codetemp is used exactly once -- we will inline the expression at its use point.
| MULTIPLE_USES # Codetemp is used two or more times -- we will to leave it in place.
| ONE_USE_AND_INLINED # Codetemp is ONE_USE and has been (or will be) inlined at its use point.
;
# The following function is used to translate nextcode into
# larger trees. Definitions marked ONE_USE can be forward
# propagated to their (only) use. This can drastically
# reduce register pressure.
stipulate
exception CODETEMP_USE_FREQUENCY_HASHTABLE;
herein
my codetemp_use_frequency_hashtable: iht::Hashtable( Codetemp_Use_Frequency )
= iht::make_hashtable { size_hint => 32, not_found_exception => CODETEMP_USE_FREQUENCY_HASHTABLE };
end;
#
fun get_codetemp_use_frequency i
=
the_else (iht::find codetemp_use_frequency_hashtable i, NO_USES);
set_codetemp_use_frequency
=
iht::set codetemp_use_frequency_hashtable;
#
fun set_codetemp_use_frequency_to__one_use_and_inlined r
=
set_codetemp_use_frequency (r, ONE_USE_AND_INLINED);
# Reset the register and expression-usage hashtables:
#
fun clear_hashtables ()
=
{ iht::clear codetemp_to_tcf_int_expression__hashtable;
iht::clear codetemp_to_tcf_float_expression__hashtable;
iht::clear codetemp_use_frequency_hashtable;
};
# Memory disambiguation uses
# the new register counters,
# so those must be reset here.
rgk::reset_codetemp_id_allocation_counters ();
mem_disambig
=
ma::analyze_memory_aliasing_of_nextcode_functions cccomponent;
# Points-to analysis projection.
#
fun projection (x as REF (pt::TOP _), _)
=>
x;
projection (x, i)
=>
pt::ith_projection (x, i);
end;
stipulate
must_disambiguate_memory # Normally FALSE.
=
*coc::disambiguate_memory;
herein
#
fun get_ramregion e
=
if must_disambiguate_memory
#
case e
ncf::CODETEMP v => mem_disambig v;
_ => rgn::readonly;
esac;
else
rgn::memory;
fi;
#
fun get_ramregion_projection (e, i)
=
if must_disambiguate_memory
#
case e
ncf::CODETEMP v => projection (mem_disambig v, i);
_ => rgn::readonly;
esac;
else
rgn::memory;
fi;
end;
#
fun get_dataptr_ramregion v
=
get_ramregion_projection (v, 0);
# fun get_rw_vector_ramregion (x as REF (pt::TOP _)) => x;
# get_rw_vector_ramregion x => pt::weak_subscript x;
# end;
#
# For safety, let's assume it's
# the global memory right now:
#
fun get_rw_vector_ramregion _
=
rgn::memory;
# This keeps track of the accumulated advances of the
# heap_allocation_pointer since the start of the nextcode fn.
# This is important for generating the correct address offset
# for newly allocated records.
#
advanced_heap_ptr = REF 0;
# Return the nextcode type for
# a nextcode value expression:
#
fun ncftype_of (ncf::CODETEMP v) => get_ncftype_for_codetemp v;
ncftype_of (ncf::LABEL v) => get_ncftype_for_codetemp v;
#
ncftype_of (ncf::INT _) => ncf::typ::INT;
ncftype_of (ncf::INT1 _) => ncf::typ::INT1;
ncftype_of (ncf::TRUEVOID ) => ncf::typ::FLOAT64; # What?? -- 2011-08-16 CrT ncf::TRUEVOID comes only from a line in src/lib/compiler/back/top/closures/make-nextcode-closures-g.pkg #
ncftype_of _ => ncf::bogus_pointer_type;
end;
# 'base_pointer' contains the start address
# of the entire compilation unit.
#
# Here we generate the address of a label that
# is embedded in the same compilation unit.
# The generated address is relative to 'base_pointer'.
#
# For heapcleaner safety, we consider
# this to be a chunk reference.
#
fun make_code_for_label_address (codelabel, k)
=
hc_ptr e
where
e = tcf::ADD ( # base_pointer + (codelabel + (k - mp::const_base_pointer_reg_offset))
pri::address_width,
pri::base_pointer use_virtual_framepointer,
tcf::LABEL_EXPRESSION (
tcf::ADD (
pri::address_width,
tcf::LABEL codelabel,
tcf::LITERAL (
multiword_int::from_int
(k - mp::const_base_pointer_reg_offset)
) ) ) );
end;
# The following function looks up the Treecode expression
# associated with a general purpose value expression.
#
get_int_def_for_codetemp
=
iht::get codetemp_to_tcf_int_expression__hashtable;
#
fun resolve_heap_ptr_offset (tcf::LATE_CONSTANT absolute_heap_ptr_offset)
=>
# Here we resolve address computations of the form
#
# tcf::LATE_CONSTANT k
#
# where offset is a reference to the kth byte allocated
# since the beginning of the nextcode fn.
#
{ tmp_r = make_int_codetemp_info chi::ptr_type;
#
offset = absolute_heap_ptr_offset - *advanced_heap_ptr;
buf.put_op # tmp_r := heap_allocation_pointer + offset;
(tcf::LOAD_INT_REGISTER
(
ptr_bitsize,
tmp_r,
tcf::ADD
(
pri::address_width,
pri::heap_allocation_pointer,
int offset
) ) );
tcf::CODETEMP_INFO (ptr_bitsize, tmp_r);
};
resolve_heap_ptr_offset e
=>
e;
end;
#
fun resolve_heap_ptr_offset' (tcf::LATE_CONSTANT absolute_heap_ptr_offset)
=>
# As above, but here we generate the address but do not store it into
# a register (codetemp); this allows use in more complex subexpressions:
#
{ offset = absolute_heap_ptr_offset - *advanced_heap_ptr;
#
hc_ptr (tcf::ADD (pri::address_width, pri::heap_allocation_pointer, int offset)); # heap_allocation_pointer + offset
};
resolve_heap_ptr_offset' other
=>
other;
end;
#
fun def_for_int_codetemp (ncf::CODETEMP v) => resolve_heap_ptr_offset (get_int_def_for_codetemp v);
def_for_int_codetemp (ncf::INT i) => int (i+i+1); # Convert to tagged int format by leftshifting and setting low bit.
def_for_int_codetemp (ncf::INT1 u) => unt u; # XXX SUCKO FIXME: should have an explicit fn for converting to tagged int.
def_for_int_codetemp (ncf::LABEL v)
=>
make_code_for_label_address (get_codelabel_for_fun_id (split_entry_block ?? -v - 1 :: v), 0);
def_for_int_codetemp _ => error "def_for_int_codetemp";
end;
#
fun def_for_int_codetemp' (ncf::CODETEMP v) => resolve_heap_ptr_offset' (get_int_def_for_codetemp v); # The only line that differs from above fun.
def_for_int_codetemp' (ncf::INT i) => int (i+i+1); # Convert to tagged int format by leftshifting and setting low bit.
def_for_int_codetemp' (ncf::INT1 u) => unt u; # XXX SUCKO FIXME: should have an explicit fn for converting to tagged int.
def_for_int_codetemp' (ncf::LABEL v)
=>
make_code_for_label_address (get_codelabel_for_fun_id (split_entry_block ?? -v - 1 :: v), 0);
def_for_int_codetemp' _ => error "def_for_int_codetemp'";
end;
# On entry to a function the args are in
# standardized registers. The function-body
# code immediately copies the args to fresh
# codetemps. This frees the argument values
# to move elsewhere and is critical in avoiding
# artificial codetemp interferences:
#
fun copy_args_to_arg_codetemps (rl, vl, tl) # == (args, codetemps, types) -- we're copying 'args' to 'codetemps'.
=
{ (e_copy (vl, rl, [], [], [], [])) # == (codetemps, args, destregs, srcregs, codetemps', args')
->
(vl', rl');
e_fcopy (e_other (vl', rl', [], []));
pl::apply set_ncftype_for_codetemp (vl, tl);
}
where
fun e_copy([], [], [], [], xs', rl')
=>
(xs', rl'); # Done.
e_copy (x ! xs, tcf::INT_EXPRESSION (tcf::CODETEMP_INFO(_, r)) ! rl, rds, rss, xs', rl') # "rds" = "dst registers"; "rss" == "src registers".
=>
{ t = make_int_codetemp_info chi::ptr_type;
#
set_int_def_for_codetemp' (x, t);
#
e_copy (xs, rl, t ! rds, r ! rss, xs', rl');
};
e_copy (x ! xs, r ! rl, rds, rss, xs', rl')
=>
e_copy (xs, rl, rds, rss, x ! xs', r ! rl');
e_copy([], [], rds, rss, xs', rl')
=>
{ buf.put_op (tcf::MOVE_INT_REGISTERS (int_bitsize, rds, rss));
(xs', rl');
};
e_copy (([], _ ! _, _, _, _, _) | (_ ! _, [], _, _, _, _))
=>
error "e_copy";
end;
#
fun e_other([], [], xs, rl)
=>
(xs, rl);
e_other (x ! xs, (tcf::INT_EXPRESSION r) ! rl, xs', rl')
=>
{ t = make_int_codetemp_info chi::ptr_type;
#
set_int_def_for_codetemp' (x, t);
buf.put_op (tcf::LOAD_INT_REGISTER (int_bitsize, t, r));
e_other (xs, rl, xs', rl');
};
e_other (x ! xs, (tcf::FLOAT_EXPRESSION (tcf::CODETEMP_INFO_FLOAT(_, f))) ! rl, xs', rl')
=>
e_other (xs, rl, x ! xs', f ! rl');
e_other (_, tcf::FLOAT_EXPRESSION _ ! _, _, _)
=>
error "e_other: FPR but not FREG";
e_other (_, tcf::FLAG_EXPRESSION _ ! _, _, _)
=>
error "e_other: FLAG_EXPRESSION";
e_other (([], _ ! _, _, _) | (_ ! _, [], _, _))
=>
error "e_other";
end;
#
fun e_fcopy ([], [])
=>
();
e_fcopy (xs, rl)
=>
{ fs = map (\\ _ = make_float_codetemp_info chi::f64_type)
xs;
pl::apply
(\\ (x, f) = set_float_def_for_codetemp (x, tcf::CODETEMP_INFO_FLOAT (flt_bitsize, f)))
(xs, fs);
buf.put_op (tcf::MOVE_FLOAT_REGISTERS (flt_bitsize, fs, rl));
};
end;
end;
#############################################################################
# Nomenclature: "hap_offset" == "heap_allocation_pointer_offset".
#
# Motivation:
# On x86 heap_allocation_pointer permanently owns the EDI register -- see
#
# src/lib/compiler/back/low/main/intel32/backend-lowhalf-intel32-g.pkg #
# (Other platforms are similar.)
#
# Conceptually we allot heapspace by sequences like
#
# *heap_allocation_pointer_offset++ = record_tagword;
# *heap_allocation_pointer_offset++ = field_1;
# *heap_allocation_pointer_offset++ = field_2;
# ...
# *heap_allocation_pointer_offset++ = field_n;
#
# In practice that is too slow -- the pointer-increments take ALU resources,
# and also introduce data dependencies which inhibit multiple instruction
# issue (on-the-fly parallelism) on modern microprocessors, so it is better to do
#
# heap_allocation_pointer_offset[0] = record_tagword;
# heap_allocation_pointer_offset[1] = field_1;
# heap_allocation_pointer_offset[2] = field_2;
# ...
# heap_allocation_pointer_offset[n] = field_n;
# heap_allocation_pointer_offset += n+1;
#
# If the different fields are being generated by a complex of functions,
# the latter approach requires that we keep track of how much heapspace
# has been allocated since the last update to the heap_allocation_pointer.
# That is the function of the 'hap_offet' values used in this package.
#############################################################################
#
fun update_heap_allocation_pointer hap_offset # "hap_offset" == "heap_allocation_pointer offset".
=
# We've allocated a number of words of heap memory;
# now it is time to wrap up the allocation burst and
# bring heap_allocation_pointer up to date by doing
#
# heap_allocation_pointer += hap_offset;
#
# We keep heap_allocation_pointer aligned on odd 32-bit
# boundary so that after allocating a 32-bit tagword we
# will be correctly aligned for 64-bit data.
#
# (We have accounted for the extra space this eats up
# in pkg pick_nextcode_fns_for_heaplimit_checks.) # pick_nextcode_fns_for_heaplimit_checks is from src/lib/compiler/back/low/main/nextcode/pick-nextcode-fns-for-heaplimit-checks.pkg #
if (hap_offset != 0)
#
if (unt::bitwise_and (unt::from_int hap_offset, 0u4) != 0u0) advance_by (hap_offset+4); # 64-bit issue: '4' is 'wordbytes' -- and this alignment is not needed on 64-bit implementations anyhow.
else advance_by (hap_offset );
fi;
fi
where
fun advance_by hap_offset
=
{ advanced_heap_ptr := *advanced_heap_ptr + hap_offset;
#
buf.put_op (tcf::LOAD_INT_REGISTER # heap_allocation_pointer_register += hap_offset;
(
ptr_bitsize,
heap_allocation_pointer_register,
tcf::ADD
( pri::address_width,
pri::heap_allocation_pointer,
int hap_offset
) ) );
};
end;
#
fun maybe_test_heap_allocation_limit hap_offset # "hap_offset" == "heap_allocation_pointer offset".
=
{ update_heap_allocation_pointer hap_offset;
# This next is a nop on Intel32; on Pwrpc32 and Sparc32
# it loads a register with bits from a status register
# loaded by a previous (delay-slot) comparison
#
# heaplimit_allocation_pointer > heaplimit_allocation_limit
# # heap_is_exhausted__test def in src/lib/compiler/back/low/main/sparc32/backend-lowhalf-sparc32.pkg case pri::heap_is_exhausted__test # heap_is_exhausted__test def in src/lib/compiler/back/low/main/pwrpc32/backend-lowhalf-pwrpc32.pkg #
THE cc => assign_cc (cc, heap_is_exhausted__test); # "cc" == "condition-code" -- the ZERO/OVERFLOW/... status-register bits.
#
NULL => (); # The Intel32 case.
esac
where
fun assign_cc (tcf::CC (_, cc), v)
=>
buf.put_op (tcf::LOAD_INT_REGISTER_FROM_FLAGS_REGISTER (cc, v));
assign_cc _ => error "maybe_test_heap_allocation_limit::assign_cc";
end;
end;
};
# r+n;
#
fun ea (r, 0) => r;
ea (r, n) => tcf::ADD (pri::address_width, r, int n);
end;
# r + 4*n;
#
fun index_ea (r, 0) => r;
index_ea (r, n) => tcf::ADD (pri::address_width, r, int (n*4)); # 64-bit issue -- '4' is presumably 'wordbytes' here.
end;
# Function to heap-allot an integer record
#
# x <- [tagword, field_values... ]
#
# at heap_allocation_pointer + hap_offset:
#
fun allot_record (hc_wrapfn, mem, tagword, field_values, hap_offset)
=
{ buf.put_op (tcf::STORE_INT (int_bitsize, ea (pri::heap_allocation_pointer, hap_offset), tagword, projection (mem, -1))); # Store tagword at start of new record.
#
store_fields (field_values, hap_offset+4, 0); # 64-bit issue: '4' is 'wordbytes'.
#
hap_offset + 4; # 64-bit issue: '4' is 'wordbytes'.
}
where
fun get_field_address (v, record, ncf::SLOT 0 ) => record;
get_field_address (v, record, ncf::SLOT index) => tcf::ADD (pri::address_width, record, int (4*index)); # 64-bit issue: '4' is 'wordbytes'.
get_field_address (v, record, path ) => get_path (get_ramregion v, record, path);
end
also
fun get_path (mem, record, ncf::SLOT index)
=>
index_ea (record, index);
get_path (mem, record, ncf::VIA_SLOT (index, ncf::SLOT 0))
=>
hc_wrapfn (tcf::LOAD (int_bitsize, index_ea (record, index), projection (mem, index)));
get_path (mem, record, ncf::VIA_SLOT (index, path))
=>
{ mem = projection (mem, index);
#
get_path (mem, hc_ptr (tcf::LOAD (int_bitsize, index_ea (record, index), mem)), path);
};
end;
#
fun store_fields ([], hap_offset, element)
=>
hap_offset;
store_fields ((record, path) ! field_values, hap_offset, element)
=>
{ buf.put_op # heap_allocation_pointer[ hap_offset ] = v.p (?);
(tcf::STORE_INT
(
int_bitsize,
tcf::ADD (pri::address_width, pri::heap_allocation_pointer, int hap_offset), # Where to store: heap_allocation_pointer + hap_offset;
get_field_address (record, def_for_int_codetemp' record, path), # What to store. 'path' can be a simple slot number, or a true path.
projection (mem, element)
)
);
#
store_fields (field_values, hap_offset+4, element+1); # 64-bit issue: '4' is 'wordbytes'.
};
end;
end;
# Same as above, except for floating point instead of int record:
#
# x <- [tagword, field_values... ]
#
fun allot_frecord (mem, tagword, field_values, hap_offset)
=
{ buf.put_op (tcf::STORE_INT (int_bitsize, ea (pri::heap_allocation_pointer, hap_offset), tagword, projection (mem, -1)));
#
fstore_fields (field_values, hap_offset+4, 0); # 64-bit issue: '4' is 'wordbytes'.
#
hap_offset+4; # 64-bit issue: '4' is 'wordbytes'.
}
where
fun fea (r, 0) => r;
fea (r, n) => tcf::ADD (pri::address_width, r, int (n*8));
end;
#
fun fget_field (v, ncf::SLOT 0) => def_for_float_codetemp v;
fget_field (v, ncf::SLOT _) => error "allot_frecord::fget_field";
fget_field (v, p ) => fget_path (get_ramregion v, def_for_int_codetemp' v, p);
end
also
fun fget_path (mem, e, ncf::SLOT _)
=>
error "allot_frecord::fget_path";
fget_path (mem, e, ncf::VIA_SLOT (n, ncf::SLOT 0))
=>
hc_flt (tcf::FLOAD (flt_bitsize, fea (e, n), projection (mem, n)));
fget_path (mem, e, ncf::VIA_SLOT (n, p))
=>
{ mem = projection (mem, n);
fget_path (mem, hc_ptr (tcf::LOAD (int_bitsize, index_ea (e, n), mem)), p);
};
end;
#
fun fstore_fields ([], hap_offset, element)
=>
hap_offset;
fstore_fields((v, p) ! field_values, hap_offset, element)
=>
{ buf.put_op
(tcf::STORE_FLOAT
(
flt_bitsize,
tcf::ADD (pri::address_width, pri::heap_allocation_pointer, int hap_offset),
fget_field (v, p),
projection (mem, element)
) );
fstore_fields (field_values, hap_offset+8, element+1);
};
end;
end;
# Allocate a header pair for vector or rw_vector:
#
# heap_allocation_pointer[ hap_offset ] = hdr_tagword;
# heap_allocation_pointer[ hap_offset + 4 ] = data_ptr;
# heap_allocation_pointer[ hap_offset + 8 ] = length_in_slots;
#
fun allocate_vector_header (hdr_tagword, mem, data_ptr, length_in_slots, hap_offset)
=
{ buf.put_op (tcf::STORE_INT (int_bitsize, ea (pri::heap_allocation_pointer, hap_offset), int hdr_tagword, projection (mem,-1)));
buf.put_op (tcf::STORE_INT (int_bitsize, ea (pri::heap_allocation_pointer, hap_offset+4), # 64-bit issue: '4' is 'wordbytes'.
tcf::CODETEMP_INFO (int_bitsize, data_ptr), projection (mem, 0)));
buf.put_op (tcf::STORE_INT
(
int_bitsize,
ea (pri::heap_allocation_pointer, hap_offset+8), # 64-bit issue: '8' is '2*wordbytes'.
int (length_in_slots+length_in_slots+1), # len+len+1: == ((len<<1)|1) -- Unt1 to Tagged_Unt tagged-int form.
projection (mem, 1)
) );
hap_offset+4; # '+4' not '+12' because our caller wants a pointer to post-tagword part of record, not to next-word-to-allot. # 64-bit issue: '4' is 'wordbytes'.
};
#####################################################################
# Tagged_Int-arithmetic implementation.
#
# We store Tagged_Int values in-pointer, marked
# by having the low bit set to 1.
#
# (We keep all heap values word-aligned, so all valid
# heap pointers will always have the low two bits zero.
# Consequently the heapcleaner can always distinguish
# Tagged_Int values from valid pointers when processing a
# heapchunk, allowing it to ignore Tagged_Int values rather
# than treat them as valid pointers and maybe segfault.)
#
# The low-bit tagging of Tagged_Int values
# means that to naively do (say)
#
# k = i + j;
#
# on Tagged_Int values we must actually do
#
# k = (((i >> 1) + (j >> 1)) << 1) + 1;
#
# In practice, in specific situations, we can
# often find equivalent expressions with fewer
# shifts. For example, the above is arithmetically
# equal to:
#
# k = (i - 1) + j;
#
#####################################################################
#
fun add_tagged_int_tag value = tcf::ADD (int_bitsize, value, one); # Set the lowbit tag on a value which is already left-shifted one bit.
fun or_tagged_int_tag value = tcf::BITWISE_OR (int_bitsize, value, one); # Same as above, except it is a safe no-op if the lowbit is already set.
fun strip_tagged_int_tag value = tcf::SUB (int_bitsize, value, one); # Subtract one to clear the lowbit tag on a 31-bit tagged int.
#
fun tag (FALSE, value) => tag_unsigned value;
tag (TRUE, value) => tag_signed value;
end
also
fun tag_unsigned e # Tag unsigned value 'e' as an tagged_int.
=
{ fun double r
=
tcf::ADD (int_bitsize, r, r);
case e
#
tcf::CODETEMP_INFO _
=>
add_tagged_int_tag (double e); # e = (e << 1) + 1;
_ => { tmp = make_int_codetemp_info chi::ptr_type; # XXX ???
tcf::LET ( tcf::LOAD_INT_REGISTER (int_bitsize, tmp, e), # tmp = (e << 1) + 1;
#
add_tagged_int_tag (double (tcf::CODETEMP_INFO (int_bitsize, tmp)))
);
};
esac;
}
also
fun tag_signed e # Same as above, but with int OVERFLOW CHECKING.
=
{ fun double r
=
if *coc::trap_int_overflow tcf::ADD_OR_TRAP (int_bitsize, r, r);
else tcf::ADD (int_bitsize, r, r);
fi;
case e
#
tcf::CODETEMP_INFO _
=>
add_tagged_int_tag (double e); # e = (e << 1) + 1; WITH OVERFLOW TRAPPING.
_ => { tmp = make_int_codetemp_info chi::ptr_type; # XXX ???
tcf::LET ( tcf::LOAD_INT_REGISTER (int_bitsize, tmp, e), # tmp = (e << 1) + 1; WITH OVERFLOW CHECKING
#
add_tagged_int_tag (double (tcf::CODETEMP_INFO (int_bitsize, tmp)))
);
};
esac;
};
#
fun untag { signed => TRUE, value } => untag_signed value;
untag { signed => FALSE, value } => untag_unsigned value;
end
also
fun untag_unsigned (ncf::INT i) => int i; # ncf::INT val is untagged, doesn't need the rightshift.
untag_unsigned v => tcf::RIGHT_SHIFT_U (int_bitsize, def_for_int_codetemp v, one); # v >> 1; # Without sign extension.
end
also
fun untag_signed (ncf::INT i) => int i; # ncf::INT val is untagged, doesn't need the rightshift.
untag_signed v => tcf::RIGHT_SHIFT (int_bitsize, def_for_int_codetemp v, one); # v >> 1; # With sign extension.
end;
#########################################
# Tagged_Int-arithmetic ops.
#
fun tagged_intadd (add_op, ncf::INT k, w ) => add_op (int_bitsize, int (k+k), def_for_int_codetemp w); # w + (k+k) ncf::INT is untagged, the 'k+k' leftshifts it to match tagged values.
tagged_intadd (add_op, w, v as ncf::INT _) => tagged_intadd (add_op, v, w); # Swap args and handle via previous line.
tagged_intadd (add_op, v, w ) => add_op ( int_bitsize, # v + (w - 1)
def_for_int_codetemp v, # By clearing low bit of v but not w we ensure that v+w will have low-bit tagged_int tag set.
strip_tagged_int_tag (def_for_int_codetemp w)
);
end;
#
fun tagged_intsub (sub_op, ncf::INT k, w) => sub_op (int_bitsize, int (k+k+2), def_for_int_codetemp w); # ncf::INT is untagged, 'k+k' leftshifts it to match tagged values.
# # The '+2' leaves low bit set after subtracting a lowbit-tagged int.
tagged_intsub (sub_op, v, ncf::INT k) => sub_op (int_bitsize, def_for_int_codetemp v, int (k+k)); # ncf::INT is untagged, 'k+k' leftshifts it to match tagged values.
# # Subtracting this from a lowbit-tagged int will leave the lowbit set, hence a valid tagged value.
tagged_intsub (sub_op, v, w ) => add_tagged_int_tag (sub_op ( int_bitsize, # Subtract two lowbit-tagged values, then add 1 to set the low bit again.
def_for_int_codetemp v,
def_for_int_codetemp w
) );
end;
#
fun tagged_intxor (ncf::INT k, w ) => tcf::BITWISE_XOR (int_bitsize, int (k+k), def_for_int_codetemp w); # ncf::INT is untagged, 'k+k' leftshifts it to match tagged values; XOR then leaves lowbit tag set.
tagged_intxor (w, v as ncf::INT _) => tagged_intxor (v, w); # Reduce to above case, then apply above line.
tagged_intxor (v, w ) => add_tagged_int_tag (tcf::BITWISE_XOR ( int_bitsize, # XOR two lowbit-tagged values: the XOR clears the lowbit tag, so we then add one to set it again.
def_for_int_codetemp v,
def_for_int_codetemp w
) );
end;
#
fun tagged_intmul (signed, mul_op, v, w)
=
{ fun f (ncf::INT k, ncf::INT j) => (int (k+k), int j); # ncf::INT is untagged; We need ((k*j)<<1)|1 == ((2*k)*j)|1 == ((k+k)*j)|1; the |1 is done below.
f (ncf::INT k, w) => (untag { signed, value => w }, int (k+k)); # The 'untag' rightshifts, reducing to above case.
f (v, w as ncf::INT _) => f (w, v); # Swap args, reducing to above case.
f (v, w) => ( strip_tagged_int_tag (def_for_int_codetemp v), # Rightshift one arg and strip lowbit tag from other arg, reducing in essence to first case.
untag { signed, value => w }
);
end;
(f (v, w)) -> (v, w);
add_tagged_int_tag (mul_op (int_bitsize, v, w)); # Do the multiply, then set the low bit to make a valid tagged_int tagged integers.
};
#
fun tagged_intdiv (signed, drm, v, w)
=
{ my (v, w)
=
case (v, w)
#
(ncf::INT k, ncf::INT j) => (int k, int j); # ncf::INT is untagged.
(ncf::INT k, w) => (int k, untag { signed, value => w }); # ncf::INT is untagged.
#
(v, ncf::INT k) => (untag { signed, value => v }, int k); # ncf::INT is untagged.
(v, w) => (untag { signed, value => v }, untag { signed, value => w });
esac;
# The only way a 31-bit div can overflow
# is when the result gets retagged so
# we can use tcf::DIVS instead of tcf::DIVS_OR_TRAP:
#
tag ( signed,
signed ?? tcf::DIVS (drm, int_bitsize, v, w)
:: tcf::DIVU ( int_bitsize, v, w)
);
};
#
fun tagged_intrem (signed, drm, v, w)
=
{ my (v, w)
=
case (v, w)
#
(ncf::INT k, ncf::INT j) => (int k, int j); # ncf::INT is untagged.
(ncf::INT k, w) => (int k, untag { signed, value => w }); # ncf::INT is untagged.
#
(v, ncf::INT k) => (untag { signed, value => v }, int k); # ncf::INT is untagged.
(v, w) => (untag { signed, value => v }, untag { signed, value => w });
esac;
# Will not overflow, so
# we tag like unsigned:
#
tag ( FALSE,
signed ?? tcf::REMS (drm, int_bitsize, v, w)
:: tcf::REMU (int_bitsize, v, w)
);
};
#
fun tagged_intlshift (ncf::INT k, w) # ncf::INT is untagged.
=>
add_tagged_int_tag (tcf::LEFT_SHIFT (int_bitsize, int (k+k), untag_unsigned w));
tagged_intlshift (v, ncf::INT k) # ncf::INT is untagged.
=>
add_tagged_int_tag (tcf::LEFT_SHIFT (int_bitsize, strip_tagged_int_tag (def_for_int_codetemp v), int k));
tagged_intlshift (v, w)
=>
add_tagged_int_tag (tcf::LEFT_SHIFT (int_bitsize, strip_tagged_int_tag (def_for_int_codetemp v), untag_unsigned w));
end;
#
fun tagged_intrshift (rshift_op, v, ncf::INT k) # ncf::INT is untagged.
=>
or_tagged_int_tag (rshift_op (int_bitsize, def_for_int_codetemp v, int k));
tagged_intrshift (rshift_op, v, w)
=>
or_tagged_int_tag (rshift_op (int_bitsize, def_for_int_codetemp v, untag_unsigned w));
end;
###########################################################################
# Heapchunk tags and related support.
# For tagword definitions see src/c/h/heap-tags.h
###########################################################################
#
fun get_heapchunk_tagword v # return v[-1];
=
tcf::LOAD ( int_bitsize,
tcf::SUB (ptr_bitsize, def_for_int_codetemp v, int 4), # 64-bit issue: '4' is 'wordbytes'.
get_ramregion_projection (v, -1)
);
# Compare to GET_LENGTH_IN_WORDS_FROM_TAGWORD from src/c/h/heap-tags.h
# Here we are also fetching the tagword:
#
fun get_heapchunk_length_as_tagged_int v # Length-in-words, I think.
=
or_tagged_int_tag
(tcf::RIGHT_SHIFT_U
(
int_bitsize,
get_heapchunk_tagword v,
int (tag::tag_width - 1) # "-1": This leaves a garbage bit at the bottom; the above or_tagged_int_tag then produces a valid Tagged_Int value.
) );
#
fun set_up_args_for_fn_call (formal_args, actual_args)
=
# Here we generate code to execute immediately before
# jumping to the entrypoint for a function.
#
# We're given the formal argument list -- what the callee expects to get --
# and also the actual argument list -- what the caller actually has.
#
# Our task here is to construct copies from the
# codetemps currently holding them to the registers
# the caller wants them in. (Later on the register
# allocator will attempt to eliminate as many as possible
# of these copies by appropriate assignement of codetemps
# to registers, but that is not our concern here.)
#
# Note that
#
# formal_args intersect actual_args
#
# is always empty because our formal args are
# immediately copied to fresh codetemps:
#
gather
( formal_args,
actual_args,
[], [], # dst regs, src regs: In these two we accumulate args for a tcf::MOVE_INT_REGISTERS parallel register-copy.
[], # In this one we accumulate args for a tcf::MOVE_FLOAT_REGISTERS parallel register-copy.
[], # In this one we construct a "tree-ified" ... (something).
[] # In this one we accumulate loads from ram (as opposed to the preceding reg-to-reg copies).
)
where
#
fun is_inlined (ncf::CODETEMP r) => get_codetemp_use_frequency r == ONE_USE_AND_INLINED;
is_inlined _ => FALSE;
end;
#
fun gather ([], [], cp_rd, cp_rs, float_copies, treeified, loads)
=>
{ apply buf.put_op treeified;
case (cp_rd, cp_rs)
#
([],[]) => ();
_ => buf.put_op (tcf::MOVE_INT_REGISTERS (int_bitsize, cp_rd, cp_rs));
esac;
case float_copies
#
[] => ();
_ => buf.put_op (tcf::MOVE_FLOAT_REGISTERS (flt_bitsize, map #1 float_copies, map #2 float_copies));
esac;
apply buf.put_op loads;
};
gather ( tcf::INT_EXPRESSION (tcf::CODETEMP_INFO (type, rd)) ! formal_args,
actual_arg ! actual_args,
cp_rd, cp_rs,
float_copies,
treeified,
loads
)
=>
case (def_for_int_codetemp actual_arg)
#
tcf::CODETEMP_INFO (_, rs)
=>
gather (formal_args, actual_args, rd ! cp_rd, rs ! cp_rs, float_copies, treeified, loads);
e => if (is_inlined actual_arg)
#
gather (formal_args, actual_args, cp_rd, cp_rs, float_copies, tcf::LOAD_INT_REGISTER (type, rd, e) ! treeified, loads);
else gather (formal_args, actual_args, cp_rd, cp_rs, float_copies, treeified, tcf::LOAD_INT_REGISTER (type, rd, e) ! loads);
fi;
esac;
gather ( tcf::INT_EXPRESSION (tcf::LOAD (type, ea, r)) ! formal_args,
actual_arg ! actual_args,
cp_rd, cp_rs,
float_copies,
treeified,
loads
)
=>
# Always store them early!
#
gather ( formal_args, actual_args,
cp_rd, cp_rs,
float_copies,
tcf::STORE_INT (type, ea, def_for_int_codetemp actual_arg, r) ! treeified,
loads
);
gather ( tcf::FLOAT_EXPRESSION (tcf::CODETEMP_INFO_FLOAT (type, fd)) ! formal_args,
actual_arg ! actual_args,
cp_rd, cp_rs,
float_copies,
treeified,
loads
)
=>
case (def_for_float_codetemp actual_arg)
#
tcf::CODETEMP_INFO_FLOAT (_, fs)
=>
gather (formal_args, actual_args, cp_rd, cp_rs, (fd, fs) ! float_copies, treeified, loads);
e =>
if (is_inlined actual_arg)
gather (formal_args, actual_args, cp_rd, cp_rs, float_copies, tcf::LOAD_FLOAT_REGISTER (type, fd, e) ! treeified, loads);
else
gather (formal_args, actual_args, cp_rd, cp_rs, float_copies, treeified, tcf::LOAD_FLOAT_REGISTER (type, fd, e) ! loads);
fi;
esac;
gather _
=>
error "set_up_args_for_fn_call/gather";
end;
end;
#############################################################################
# Scale-and-add -- return a + i*k for k = 1,4,8.
# These are (were?) important because the Intel32
# effective address logic is hardwired to compute them,
# and independently because we use them a lot to load
# byte, word and float values from heap records.
#
fun add_ix1 (a, ncf::INT 0) => a; # ncf::INT is untagged.
add_ix1 (a, ncf::INT k) => tcf::ADD (int_bitsize, a, int k); # ncf::INT is untagged.
add_ix1 (a, i ) => tcf::ADD (int_bitsize, a, untag_signed i);
end;
#
fun add_ix4 (a, ncf::INT 0) => a; # ncf::INT is untagged.
add_ix4 (a, ncf::INT i) => tcf::ADD (int_bitsize, a, int (i*4)); # ncf::INT is untagged.
add_ix4 (a, i ) => tcf::ADD (int_bitsize, a, tcf::LEFT_SHIFT (int_bitsize, untag_signed i, two));
end;
#
fun add_ix8 (a, ncf::INT 0) => a; # ncf::INT is untagged.
add_ix8 (a, ncf::INT i) => tcf::ADD (int_bitsize, a, int (i*8)); # ncf::INT is untagged.
add_ix8 (a, i ) => tcf::ADD (int_bitsize, a, tcf::LEFT_SHIFT (int_bitsize, strip_tagged_int_tag (def_for_int_codetemp i), int 2));
end;
###################################################################
# Zero-extend and sign-extend:
#
fun zero_extend_32 (size, value)
=
tcf::ZERO_EXTEND (32, size, value);
# tcf::RIGHT_SHIFT_U (32, tcf::LEFT_SHIFT (32, value, int (32 - size)), int (32 - size))
#
fun sign_extend_32 (size, value)
=
tcf::SIGN_EXTEND (32, size, value);
# tcf::RIGHT_SHIFT (32, tcf::LEFT_SHIFT (32, value, int (32 - size)), int (32 - size))
#
fun log_boxed_update_to_heap_changelog (updated_address, hap_offset)
=
# Add to the heap changelog the address
# where a boxed update has occurred.
#
# The heap changelog is basically a
# a list of CONS cells, to which we
# are prepending a new cell.
#
# We generate code equivalent to:
#
# heap_allocation_pointer[0] = updated_address;
# heap_allocation_pointer[4] = heap_changelog_pointer;
#
# heap_changelog_pointer = heap_allocation_pointer;
#
{ buf.put_op (tcf::STORE_INT (ptr_bitsize, tcf::ADD (pri::address_width, pri::heap_allocation_pointer, int hap_offset),
updated_address, rgn::heap_changelog)); #
buf.put_op (tcf::STORE_INT (ptr_bitsize, tcf::ADD (pri::address_width, pri::heap_allocation_pointer, int (hap_offset+4)), # 64-bit issue -- '4' is 'wordbytes'.
pri::heap_changelog_pointer use_virtual_framepointer, rgn::heap_changelog));
buf.put_op (set_rreg (pri::heap_changelog_pointer use_virtual_framepointer, tcf::ADD (pri::address_width, pri::heap_allocation_pointer, int hap_offset)));
};
#########################################################
# Nextcode-to-Treecode COMPARE OP translation.
#
# Nextcode compare operators are un/signed agnostic;
# in Nextcode un/signed type information is carried
# by the operands. In Treecode operands carry no
# unsigned information; instead binary operators are
# explicitly divided into signed and unsigned flavors.
# Here we implement the translation:
#########################################################
#
fun to_tcf_unsigned_compare op
=
case op
ncf::p::GT => tcf::GTU; ncf::p::GE => tcf::GEU;
ncf::p::LT => tcf::LTU; ncf::p::LE => tcf::LEU;
ncf::p::EQL => tcf::EQ; ncf::p::NEQ => tcf::NE;
esac;
#
fun to_tcf_signed_compare op
=
case op
ncf::p::GT => tcf::GT; ncf::p::GE => tcf::GE;
ncf::p::LT => tcf::LT; ncf::p::LE => tcf::LE;
ncf::p::NEQ => tcf::NE; ncf::p::EQL => tcf::EQ;
esac;
#
fun float64cmp (op, v, w)
=
tcf::FCMP (64, fcond, def_for_float_codetemp v, def_for_float_codetemp w)
where
fcond = case op
ncf::p::f::EQ => tcf::FEQ; # XXX BUGGO FIXME We should make these name sets identical (do we need both?)
ncf::p::f::ULG => tcf::FNEU; # (I presume this is just a relic of when SML/NJ and MLRISC were separate codebases.)
ncf::p::f::UN => tcf::FUO;
ncf::p::f::LEG => tcf::FGLE;
ncf::p::f::GT => tcf::FGT;
ncf::p::f::GE => tcf::FGE;
ncf::p::f::UGT => tcf::FGTU;
ncf::p::f::UGE => tcf::FGEU;
ncf::p::f::LT => tcf::FLT;
ncf::p::f::LE => tcf::FLE;
ncf::p::f::ULT => tcf::FLTU;
ncf::p::f::ULE => tcf::FLEU;
ncf::p::f::LG => tcf::FNE;
ncf::p::f::UE => tcf::FEQU;
esac ;
end;
#
fun go_to_label label
=
tcf::GOTO (tcf::LABEL label, []);
# Trapping int overflows is expensive,
# so we do it only if requested:
#
add_or_trap = *coc::trap_int_overflow ?? tcf::ADD_OR_TRAP :: tcf::ADD;
sub_or_trap = *coc::trap_int_overflow ?? tcf::SUB_OR_TRAP :: tcf::SUB;
#
muls_or_trap = *coc::trap_int_overflow ?? tcf::MULS_OR_TRAP :: tcf::MULS;
divs_or_trap = *coc::trap_int_overflow ?? tcf::DIVS_OR_TRAP :: tcf::DIVS;
##############################################################
# Here begins the recursive function set.
##############################################################
#
fun translate_nextcode_function_to_treecode (fun_label, fun_kind, fun_id, arg_codetemps, args, arg_types, fun_body)
=
{ generate_function_prolog (fun_label, fun_kind, fun_id, arg_codetemps, args, arg_types, fun_body);
#
advanced_heap_ptr := 0;
#
translate_nextcode_ops_to_treecode (fun_body, 0);
} # fun translate_nextcode_function_to_treecode
also
fun generate_function_prolog (fun_label, fun_kind, fun_id, arg_codetemps, args, arg_types, fun_body)
=
# Here we generate the function prolog,
# which in particular copies arguments from
# their fixed arg-passing registers into fresh
# local codetemps. Our tasks here include:
#
# 1. Record types for each codetemp definition.
# This is used to determine the arg-passing
# convention for public functions.
#
# 2. Count the number of uses of each codetemp,
# on a scale of "zero, one, many".
# This is used in the forward propagation logic.
#
# 3. Set need_base_pointer TRUE iff the base_pointer is needed.
# It is needed iff
# a. There is a reference to ncf::LABEL
# b. It uses ncf::JUMPTABLE -- the jumptable requires base_pointer.
#
# 4. Generate the heapcleaner tests for PUBLIC and PRIVATE functions.
#
# 5. If we're doing any floating point allocation (i.e.,
# any heap allocation which needs to be 64-bit aligned)
# we must align heap_allocation_pointer.
#
{
####################################################################
# Survey pass.
#
# We start by doing a pass over the code to:
#
# 1. See if any doubleword allocations are done. # E.g. 64-bit float allocations on 32-bit machine.
# If so, we set needs_doubleword_alignment := TRUE to remind
# us to later make sure heap_allocation_pointer is correctly
# aligned for doubleword allocations. # 64-bit issue: Not(?) needed in 64-bit code.
#
# 2. See if base_pointer is needed.
# If so, we set need_base_pointer := TRUE.
#
# 3. Compute for each codetemp whether it is 'use'd zero, one or many times.
####################################################################
needs_doubleword_alignment = REF FALSE; # Begin by assuming no doubleword allocations.
need_base_pointer = REF FALSE; # Begin by assuming no need for base_pointer.
stipulate
fun count_use codetemp # Here is where we count "zero, one, many."
=
case (get_codetemp_use_frequency codetemp)
#
NO_USES => set_codetemp_use_frequency (codetemp, ONE_USE);
ONE_USE => set_codetemp_use_frequency (codetemp, MULTIPLE_USES);
MULTIPLE_USES => ();
#
_ => error "count_use";
esac;
#
fun check_value (ncf::CODETEMP codetemp) => count_use codetemp;
check_value (ncf::LABEL _) => need_base_pointer := TRUE;
check_value _ => ();
end;
#
fun check_values [] => ();
check_values (ncf::CODETEMP v ! rest) => { count_use v; check_values rest; };
check_values (ncf::LABEL _ ! rest) => { need_base_pointer := TRUE; check_values rest; };
check_values (_ ! rest) => { check_values rest; };
end;
#
fun check_record_values []
=>
();
check_record_values ((ncf::CODETEMP v, _) ! rest)
=>
{ count_use v;
#
check_record_values rest;
};
check_record_values ((ncf::LABEL v, _) ! rest)
=>
{ need_base_pointer := TRUE;
#
check_record_values rest;
};
check_record_values (_ ! rest)
=>
check_record_values rest;
end;
herein
#
fun note_doubleword_allocations_and_base_pointer_uses_and_uses_per_codetemp fun_body
=
loop fun_body
where
# This one is very simple: We mostly just loop
# over all ops in the function body updating
#
# needs_doubleword_alignment
# need_base_pointer
# codetemp_use_frequency
#
# in the obvious manner. The one weirdness is
# that we abuse the codetemp use frequency counts
# to keep float-reads from moving past float-writes:
#
fun loop (ncf::DEFINE_RECORD r)
=>
{ case r.kind
#
ncf::rk::FLOAT64_FATE_FN => needs_doubleword_alignment := TRUE;
ncf::rk::FLOAT64_BLOCK => needs_doubleword_alignment := TRUE;
#
_ => ();
esac;
check_record_values r.fields;
set_ncftype_for_codetemp (r.to_temp, ncf::bogus_pointer_type);
loop r.next;
};
loop (ncf::GET_FIELD_I { record, to_temp, type, next, ... })
=>
{ check_value record;
#
set_ncftype_for_codetemp (to_temp, type);
loop next;
};
loop (ncf::GET_ADDRESS_OF_FIELD_I { record, to_temp, next, ... })
=>
{ check_value record;
#
set_ncftype_for_codetemp (to_temp, ncf::bogus_pointer_type);
loop next;
};
loop (ncf::JUMPTABLE { i, nexts, ... })
=>
{ need_base_pointer := TRUE;
#
check_value i;
apply loop nexts;
};
loop (ncf::STORE_TO_RAM { args, next, ... })
=>
{ check_values args;
#
loop next;
};
loop (ncf::FETCH_FROM_RAM { op, args, to_temp, type, next })
=>
{ check_values args;
# A float-read cannot move past a float-write. # Why is this a float problem but not an int problem? -- 2011-08-19 CrT
# For now read operations cannot be treeified.
# This is hacked by making it (falsely) used
# more than once. # XXX SUCKO FIXME There is a suggestion we need barriers in such cases...?
case op
#
( ncf::p::GET_VECSLOT_NUMERIC_CONTENTS { kind_and_size => ncf::p::FLOAT _ }
| ncf::p::GET_FROM_NONHEAP_RAM { kind_and_size => ncf::p::FLOAT _ }
)
=>
set_codetemp_use_frequency (to_temp, MULTIPLE_USES);
_ => ();
esac;
set_ncftype_for_codetemp (to_temp, type);
loop next;
};
loop (ncf::ARITH { args, to_temp, type, next, ... })
=>
{ check_values args;
#
set_ncftype_for_codetemp (to_temp, type);
loop next;
};
loop (ncf::RAW_C_CALL { args, to_ttemps, next, ... })
=>
{ check_values args;
#
apply set_ncftype_for_codetemp to_ttemps;
loop next;
};
loop (ncf::PURE { op, args, to_temp, type, next })
=>
{ case op ncf::p::WRAP_FLOAT64 => needs_doubleword_alignment := TRUE;
_ => ();
esac;
check_values args;
set_ncftype_for_codetemp (to_temp, type);
loop next;
};
loop (ncf::IF_THEN_ELSE r)
=>
{ check_values r.args;
#
loop r.then_next;
loop r.else_next;
};
loop (ncf::TAIL_CALL r)
=>
{ check_value r.fn;
check_values r.args;
};
loop _ => error "translate_nextcode_function_to_treecode";
end; # fun loop
end; # where
end; # fun note_doubleword_allocations_and_base_pointer_uses_and_uses_per_codetemp
if *coc::printit
#
print_nextcode_fun (fun_kind, fun_id, arg_codetemps, arg_types, fun_body); # Print debugging information.
fi;
# Copy args to fresh codetemps:
#
case fun_kind
#
ncf::PRIVATE_FN
=>
{ buf.put_private_label fun_label;
#
note_doubleword_allocations_and_base_pointer_uses_and_uses_per_codetemp
#
fun_body;
copy_args_to_arg_codetemps (args, arg_codetemps, arg_types);
};
ncf::PRIVATE_FN_WHICH_NEEDS_HEAPLIMIT_CHECK
=>
{ buf.put_private_label fun_label;
# heapcleaner test
put_heaplimit_check
=
if (*do_extra_lowhalf_optimizations
and *lowhalf_optimize_before_making_heapcleaner_code) ihc::put_heaplimit_check_and_push_heapcleaner_call_spec_for_optimized_private_fn;
else ihc::put_heaplimit_check_and_push_heapcleaner_call_spec_for_unoptimized_private_fn;
fi;
put_heaplimit_check
#
buf
#
{ max_possible_heapbytes_allocated_before_next_heaplimit_check => 4 * (max_possible_heapwords_allocated_before_next_heaplimit_check fun_id), # 64-bit issue: '4' is 'wordbytes'.
#
live_registers => args,
live_register_types => arg_types,
#
return => go_to_label fun_label
};
note_doubleword_allocations_and_base_pointer_uses_and_uses_per_codetemp
#
fun_body;
copy_args_to_arg_codetemps (args, arg_codetemps, arg_types);
};
_ =>
# Public function:
#
{ regformals = args;
#
my (linkreg, regformals_tail)
=
case args
#
(tcf::INT_EXPRESSION linkreg ! regformals_tail)
=>
(linkreg, regformals_tail);
_ => error "no linkreg for public function";
esac;
entry_label
=
split_entry_block
?? get_codelabel_for_fun_id (-fun_id - 1)
:: fun_label;
if (not split_entry_block)
#
buf.put_public_label fun_label;
else
buf.put_public_label entry_label;
buf.put_bblock_note empty_block;
buf.put_private_label fun_label;
fi;
clear_hashtables ();
note_doubleword_allocations_and_base_pointer_uses_and_uses_per_codetemp
fun_body;
if *need_base_pointer
#
baseval # baseval = linkreg + (const_base_pointer_reg_offset - entry_label)
=
tcf::ADD
( pri::address_width,
linkreg,
tcf::LABEL_EXPRESSION
( tcf::SUB
( pri::address_width,
const_base_pointer_reg_offset,
tcf::LABEL entry_label
)
)
);
buf.put_op (set_rreg (pri::base_pointer use_virtual_framepointer, baseval)); # base_pointer = linkreg + (const_base_pointer_reg_offset - entry_label)
fi;
ihc::put_heaplimit_check_and_push_heapcleaner_call_spec_for_public_fn
#
buf
#
{ max_possible_heapbytes_allocated_before_next_heaplimit_check => 4 * (max_possible_heapwords_allocated_before_next_heaplimit_check fun_id), # 64-bit issue -- '4' is wordbytes
#
live_registers => regformals,
live_register_types => arg_types,
#
return => tcf::GOTO (linkreg,[])
};
copy_args_to_arg_codetemps
(
regformals_tail,
tail arg_codetemps,
tail arg_types
);
};
esac;
# If needed, align heap_allocation_pointer
# correctly for doubleword allocation. # On 32-bit machines we need doubleword alignment for 64-bit values, mainly 64-bit floats.
#
# ("Correctly" means such that we'll be 64-bit
# aligned after allocating a 32-bit tagword.)
#
if *needs_doubleword_alignment
#
buf.put_op
(tcf::LOAD_INT_REGISTER # heap_allocation_pointer |= 4;
(
ptr_bitsize,
heap_allocation_pointer_register,
tcf::BITWISE_OR
(
ptr_bitsize,
pri::heap_allocation_pointer,
int 4 # 64-bit issue -- 4 is "bytes_per_word".
) ) ); # 64-bit issue -- this alignment is not needed (or correct) for 64-bit code.
fi;
} # fun translate_nextcode_function_to_treecode
also
fun define_and_load' (to_temp, to_temp_info, value, next, hap_offset) # Define to_temp as to_tempinfo, then generate code for to_tempinfo := value; next
=
{ set_int_def_for_codetemp' (to_temp, to_temp_info);
#
buf.put_op (tcf::LOAD_INT_REGISTER (int_bitsize, to_temp_info, value));
#
translate_nextcode_ops_to_treecode (next, hap_offset);
}
# "hc_info" == heapcleaner_info -- see Heapcleaner_Info in src/lib/compiler/back/low/main/nextcode/per-codetemp-heapcleaner-info.api also fun define_and_load (to_temp, hc_info, value, next, hap_offset) = define_and_load' (to_temp, make_int_codetemp_info hc_info, value, next, hap_offset)
also fun define_and_load_with_ncftype (to_temp, ncftype, value, next, hap_offset) = define_and_load' (to_temp, make_int_codetemp_info_with_ncftype ncftype, value, next, hap_offset)
also fun define_and_load_with_kind_and_size (to_temp, kind_and_size, value, next, hap_offset) = define_and_load' (to_temp, make_int_codetemp_info_with_kind_and_size kind_and_size, value, next, hap_offset)
also fun define_and_load_tagged_int (to_temp, value, next, hap_offset) = define_and_load (to_temp, chi::i31_type, value, next, hap_offset)
also fun define_and_load_int1 (to_temp, value, next, hap_offset) = define_and_load (to_temp, chi::i32_type, value, next, hap_offset)
also fun define_and_load_boxed (to_temp, value, next, hap_offset) = define_and_load (to_temp, chi::ptr_type, value, next, hap_offset)
also
fun def_and_load_or_inline (to_temp, value, ncftype, next, hap_offset)
=
case (get_codetemp_use_frequency to_temp)
#
MULTIPLE_USES => define_and_load_with_ncftype (to_temp, ncftype, value, next, hap_offset); # Define to_temp as new to_temp_info and generate code for (to_temp_info := value; next
ONE_USE => { set_codetemp_use_frequency_to__one_use_and_inlined to_temp; # This flag is checked two places by is_inlined() in gather().
# # Note that we generate no tcf::LOAD_INT_REGISTER op in this case -- or any code at all;
# # We are deferring that to point-of-use to reduce register pressure.
#
set_int_def_for_codetemp (to_temp, maybe_note_type_for_heapcleaner (value, ncftype)); # Define to_temp as simply 'value'. Here and treeify_allot() are the only places where
# # a codetemp can acquire a non-CODETEMP_INFO definition.
translate_nextcode_ops_to_treecode (next, hap_offset);
};
NO_USES => translate_nextcode_ops_to_treecode (next, hap_offset);
_ => error "def_and_load_or_inline";
esac
# Generate code for
#
# to_temp := heap_allocation_pointer + offset; next
#
# where offset is the address offset of a newly allocated record.
# If codetemp is only used once, we try to propagate that to its use.
#
also
fun define_and_allot (to_temp, offset, next, hap_offset)
=
define_and_load_boxed
(
to_temp,
tcf::ADD (pri::address_width, pri::heap_allocation_pointer, int offset),
next,
hap_offset
)
# Generate code for
# to_temp := heap_allocation_pointer + offset;
# next
# Forward propagate until it is used.
#
also
fun treeify_allot (to_temp, offset, next, hap_offset)
=
case (get_codetemp_use_frequency to_temp)
#
MULTIPLE_USES => define_and_allot (to_temp, offset, next, hap_offset);
ONE_USE
=>
# We don't mark this as treeified
# because it has low register pressure:
#
{ absolute_alloc_offset = offset + *advanced_heap_ptr;
#
set_int_def_for_codetemp (to_temp, tcf::LATE_CONSTANT absolute_alloc_offset); # Define codetemp as LATE_CONSTANT. Here and def_and_load_or_inline are the only places where
# a codetemp can acquire a non-CODETEMP_INFO definition.
translate_nextcode_ops_to_treecode (next, hap_offset);
};
NO_USES => translate_nextcode_ops_to_treecode (next, hap_offset);
_ => error "treeify_allot";
esac
also
fun define_and_load_float64 (to_temp, value, next, hap_offset)
=
{ f = make_float_codetemp_info chi::f64_type;
#
set_float_def_for_codetemp (to_temp, tcf::CODETEMP_INFO_FLOAT (flt_bitsize, f));
buf.put_op (tcf::LOAD_FLOAT_REGISTER (flt_bitsize, f, value));
translate_nextcode_ops_to_treecode (next, hap_offset);
}
also
fun def_and_load_or_inline_float64 (to_temp, value, next, hap_offset) # to_temp <- e where e contains a floating-point value
=
case (get_codetemp_use_frequency to_temp)
#
NO_USES => translate_nextcode_ops_to_treecode (next, hap_offset);
ONE_USE => { set_codetemp_use_frequency_to__one_use_and_inlined to_temp;
#
set_float_def_for_codetemp (to_temp, value);
translate_nextcode_ops_to_treecode (next, hap_offset);
};
MULTIPLE_USES => define_and_load_float64 (to_temp, value, next, hap_offset);
_ => error "def_and_load_or_inline_float64";
esac
also
fun nop (to_temp, arg, value, hap_offset)
=
define_and_load_tagged_int (to_temp, def_for_int_codetemp arg, value, hap_offset)
also
fun copy (hc_info, to_temp, arg, next, hap_offset)
=
{ dst = make_int_codetemp_info hc_info;
#
set_int_def_for_codetemp' (to_temp, dst);
case (def_for_int_codetemp arg)
#
tcf::CODETEMP_INFO (_, src)
=>
buf.put_op (tcf::MOVE_INT_REGISTERS (int_bitsize, [dst], [src]));
e => buf.put_op (tcf::LOAD_INT_REGISTER (int_bitsize, dst, e));
esac;
translate_nextcode_ops_to_treecode (next, hap_offset);
}
also
fun copy_m (31, to_temp, arg, next, hap_offset) => copy (chi::i31_type, to_temp, arg, next, hap_offset);
copy_m ( _, to_temp, arg, next, hap_offset) => copy (chi::i32_type, to_temp, arg, next, hap_offset);
end
# also # Commented out because it is never used. -- 2011-08-20 CrT
# fun same_val (ncf::CODETEMP x, ncf::CODETEMP y) => x == y;
# same_val (ncf::LABEL x, ncf::LABEL y) => x == y;
# same_val (ncf::INT x, ncf::INT y) => x == y; # ncf::INT is untagged.
# #
# same_val _ => FALSE;
# end
also
fun branch (fun_id, compare, [ arg1, arg2 ], yes, no, hap_offset) # normal branches
=>
{ true_label = lbl::make_anonymous_codelabel ();
#
# "Is single assignment great or what!"
#
buf.put_op
(branch_with_probability
(
tcf::IF_GOTO (tcf::CMP (32, compare, def_for_int_codetemp arg1, def_for_int_codetemp arg2), true_label),
#
fun_id__to__branch_probability fun_id
)
);
do_next (no, hap_offset);
put_private_label (true_label, yes, hap_offset);
};
branch _ => error "branch";
end
also
fun branch_if_boxed (fun_id, arg, yes, no, hap_offset) # Branch if x is boxed (x & 1 == 0)
=
{ label = lbl::make_anonymous_codelabel ();
#
compare = tcf::CMP (32, tcf::NE, tcf::BITWISE_AND (int_bitsize, def_for_int_codetemp arg, one), zero);
buf.put_op (branch_with_probability (tcf::IF_GOTO (compare, label), fun_id__to__branch_probability fun_id));
do_next (yes, hap_offset);
put_private_label (label, no, hap_offset);
}
also
fun branch_streq (len, string1, string2, yes, no, hap_offset)
=
# Branch if string1,string2 are identical strings of length 'len'.
# Note that 'len' is fixed at compile-time.
# For speed, we compare a word at a time instead of a byte at a time.
#
# We implement the string comparison as
#
# if (string1[0] == string2[0]) goto false_label; # NB: string1[] and string2[] are arrays of words, not bytes.
# if (string1[1] == string2[1]) goto false_label;
# if (string1[2] == string2[2]) goto false_label;
# ...
# yes-stuff;
# false_label:
#
{ len' = ((len+3) / 4) * 4; # Round up to integral number of words. # 64-bit issue: both '4's are wordbytes, '3' is wordbytes-1
#
false_label = lbl::make_anonymous_codelabel ();
r1 = make_int_codetemp_info chi::i32_type;
r2 = make_int_codetemp_info chi::i32_type;
buf.put_op (tcf::LOAD_INT_REGISTER (int_bitsize, r1, tcf::LOAD (int_bitsize, def_for_int_codetemp string1, rgn::readonly)));
buf.put_op (tcf::LOAD_INT_REGISTER (int_bitsize, r2, tcf::LOAD (int_bitsize, def_for_int_codetemp string2, rgn::readonly)));
#
unroll 0
where
#
fun compare_word i
=
tcf::CMP
( 32, # 64-bit issue: '32' is wordbits.
tcf::NE,
tcf::LOAD (int_bitsize, tcf::ADD (int_bitsize, tcf::CODETEMP_INFO (int_bitsize, r1), i), rgn::readonly),
tcf::LOAD (int_bitsize, tcf::ADD (int_bitsize, tcf::CODETEMP_INFO (int_bitsize, r2), i), rgn::readonly)
);
#
fun unroll i
=
if (i != len')
#
buf.put_op (tcf::IF_GOTO (compare_word (int i), false_label));
#
unroll (i+4); # 64-bit issue: '4' is wordbytes.
fi;
end;
do_next (yes, hap_offset);
put_private_label (false_label, no, hap_offset);
}
also
fun conditional_move (op, args, codetemp, ncftype, next, hap_offset) # Conditional move.
=
# A conditional move lets us compute an expression like
#
# foo = mumble ?? bar :: zot;
#
# without any jumps or branches, via a sequence like
#
# load reg0, zot
# compare mumble
# conditional_move reg0, bat
#
# Using a branch-free alternative like conditional_move
# is a big win on modern deeply-pipelined CPU architectures
# because a mispredicted branch can cost us many cycles
# while the pipeline dumps and reloads.
#
{ fun signed (op, arg1, arg2) = tcf::CMP (32, to_tcf_signed_compare op, def_for_int_codetemp arg1, def_for_int_codetemp arg2); # 64-bit issue: The '32's all through here must be something like wordbits...?
fun unsigned (op, arg1, arg2) = tcf::CMP (32, to_tcf_unsigned_compare op, def_for_int_codetemp arg1, def_for_int_codetemp arg2);
#
fun equal (arg1, arg2) = tcf::CMP (32, tcf::EQ, def_for_int_codetemp arg1, def_for_int_codetemp arg2);
fun notequal (arg1, arg2) = tcf::CMP (32, tcf::NE, def_for_int_codetemp arg1, def_for_int_codetemp arg2);
#
fun boxed arg = tcf::CMP (32, tcf::EQ, tcf::BITWISE_AND (int_bitsize, def_for_int_codetemp arg, one), zero);
fun unboxed arg = tcf::CMP (32, tcf::NE, tcf::BITWISE_AND (int_bitsize, def_for_int_codetemp arg, one), zero);
my (compare, a, b)
=
case (op, args)
#
(ncf::p::COMPARE { op, kind_and_size=>ncf::p::INT 31 },[v, w, a, b]) => ( signed (op, v, w), a, b);
(ncf::p::COMPARE { op, kind_and_size=>ncf::p::UNT 31 },[v, w, a, b]) => (unsigned (op, v, w), a, b);
(ncf::p::COMPARE { op, kind_and_size=>ncf::p::INT 32 },[v, w, a, b]) => ( signed (op, v, w), a, b);
(ncf::p::COMPARE { op, kind_and_size=>ncf::p::UNT 32 },[v, w, a, b]) => (unsigned (op, v, w), a, b);
(ncf::p::POINTER_EQL, [v, w, a, b]) => ( equal (v, w), a, b);
(ncf::p::POINTER_NEQ, [v, w, a, b]) => (notequal (v, w), a, b);
(ncf::p::IS_BOXED, [v, a, b]) => ( boxed v, a, b);
(ncf::p::IS_UNBOXED, [v, a, b]) => (unboxed v, a, b);
(ncf::p::COMPARE_FLOATS { op, size=>64 }, [v, w, a, b]) => (float64cmp (op, v, w), a, b);
_ => error "conditional_move";
esac;
case ncftype
#
ncf::typ::FLOAT64 => define_and_load_float64 (codetemp, tcf::FCONDITIONAL_LOAD (64, compare, def_for_float_codetemp a, def_for_float_codetemp b), next, hap_offset);
_ => define_and_load_with_ncftype (codetemp, ncftype, tcf::CONDITIONAL_LOAD (32, compare, def_for_int_codetemp a, def_for_int_codetemp b), next, hap_offset);
esac;
}
also
fun arith (hc_info, op, arg1, arg2, to_temp, next, hap_offset)
=
define_and_load (to_temp, hc_info, op (int_bitsize, def_for_int_codetemp arg1, def_for_int_codetemp arg2), next, hap_offset)
also
fun arith32 (op, arg1, arg2, codetemp, next, hap_offset)
=
arith (chi::i32_type, op, arg1, arg2, codetemp, next, hap_offset)
also
fun logical (hc_info, op, arg1, arg2, to_temp, next, hap_offset)
=
define_and_load (to_temp, hc_info, op (int_bitsize, def_for_int_codetemp arg1, untag_unsigned arg2), next, hap_offset)
also
fun logical31 (op, arg1, arg2, codetemp, next, hap_offset)
=
logical (chi::i31_type, op, arg1, arg2, codetemp, next, hap_offset)
also
fun logical32 (op, arg1, arg2, codetemp, next, hap_offset)
=
logical (chi::i32_type, op, arg1, arg2, codetemp, next, hap_offset)
also
fun do_next (next, hap_offset)
=
{ save = *advanced_heap_ptr;
#
translate_nextcode_ops_to_treecode (next, hap_offset);
advanced_heap_ptr := save;
}
also
fun put_private_label (label, next, hap_offset)
=
{ buf.put_private_label label;
#
translate_nextcode_ops_to_treecode (next, hap_offset);
}
also
fun put_private_label_and_do_next (label, next, hap_offset)
=
{ buf.put_private_label label;
#
do_next (next, hap_offset);
}
also
fun make_record (field_values, to_temp, next, hap_offset) # Allocate a normal record
=
{ len = length field_values;
#
tagword = tagword_to_int (tag::make_tagword (len, tag::pairs_and_records_btag));
treeify_allot
(
to_temp,
allot_record (hc_ptr, mem_disambig to_temp, int tagword, field_values, hap_offset),
next,
hap_offset + 4 + len*4 # 64-bit issue: '4' is 'wordbytes'.
);
}
also
fun make_i32block (field_values, w, next, hap_offset) # Allocate a record with I32 components
=
{ len = length field_values;
#
tagword = tagword_to_int (tag::make_tagword (len, tag::four_byte_aligned_nonpointer_data_btag));
treeify_allot (
w,
allot_record (hc_i32, mem_disambig w, int tagword, field_values, hap_offset),
next,
hap_offset + 4 + len*4 # 64-bit issue: '4' is 'wordbytes'.
);
}
also
fun make_fblock (field_values, w, next, hap_offset) # Allocate a floating point record
=
{ len = list::length field_values;
#
tagword = tagword_to_int (tag::make_tagword (len+len, tag::eight_byte_aligned_nonpointer_data_btag));
# At initialization the allocation pointer is aligned on
# an odd-word boundary (so that allocating a 4-byte tagword
# will leave us correctly aligned for 8-byte data), and the
# heap offset set to zero.
#
# If an odd number of words have been allocated then the
# heap pointer is misaligned for this record creation.
#
hap_offset
=
unt::bitwise_and (unt::from_int hap_offset, 0u4) != 0u0 # 64-bit issue: this isn't needed or correct in 64-bit code.
?? hap_offset + 4 # 64-bit issue: '4' is presumably 'wordbytes'.
:: hap_offset;
# The components are floating point
#
treeify_allot (
w,
allot_frecord (mem_disambig w, int tagword, field_values, hap_offset),
next,
hap_offset + 4 + len*8 # 64-bit issue: '4' is 'wordbytes'.
);
}
also
fun make_vector (slot_values, w, next, hap_offset) # Allocate a vector
=
{ length_in_slots = length slot_values;
#
hdr_tagword = tagword_to_int tag::typeagnostic_ro_vector_tagword;
data_tagword = tagword_to_int (tag::make_tagword (length_in_slots, tag::ro_vector_data_btag));
data_ptr = make_int_codetemp_info chi::ptr_type;
mem = mem_disambig w;
hap_offset' = hap_offset + 4 + length_in_slots*4; # 64-bit issue: '4' is 'wordbytes'.
# The components are boxed.
# Allocate the data:
allot_record (hc_ptr, mem, int data_tagword, slot_values, hap_offset);
buf.put_op (tcf::LOAD_INT_REGISTER (ptr_bitsize, data_ptr, ea (pri::heap_allocation_pointer, hap_offset+4))); # 64-bit issue: '4' is 'wordbytes'.
# Now allot the header pair:
#
treeify_allot (
w,
allocate_vector_header (hdr_tagword, mem, data_ptr, length_in_slots, hap_offset + 4 + length_in_slots*4), # 64-bit issue: '4' is 'wordbytes'.
next,
hap_offset'+12 # 64-bit issue: '12' is '3*wordbytes'.
);
}
also
fun fselect (index, vector, to_temp, next, hap_offset) # Fetch contents of a slot in a float vector/block.
=
# Floating point select: Fetch vector[ index ];
#
def_and_load_or_inline_float64 (
to_temp,
tcf::FLOAD (flt_bitsize, add_ix8 (def_for_int_codetemp vector, ncf::INT index), rgn::float), # ncf::INT is untagged.
next,
hap_offset
)
also
fun select (index, vector, to_temp, ncftype, next, hap_offset) # Fetch contents of a slot in an int vector/block.
=
# Non-floating point select: Fetch vector[ index ];
#
def_and_load_or_inline (
to_temp,
tcf::LOAD (int_bitsize, add_ix4 (def_for_int_codetemp vector, ncf::INT index), get_ramregion_projection (vector, index)), # ncf::INT is untagged. # 64-bit issue: Need add_ix4 -> add_ix8
ncftype,
next,
hap_offset
)
also
fun funny_select (index, k, to_temp, ncftype, next, hap_offset)
=
# "Funny select; I don't know what this does."
#
# o 'index' is never used.
#
# o This fn is called only when for selects with
# ncf::GET_FIELD_I.record == ncf::INT k -- that is,
# when the field's "record" is in fact an int.
# Raising the question of when/if we would do that.
#
# o This fn is never called during compilation of the complete codebase. -- 2011-08-20 CrT
#
{ unboxed_floats = mp::unboxed_floats; # This appears to be always TRUE currently. -- 2011-08-20 CrT
#
#
fun is_float ncftype
=
if (not unboxed_floats)
#
FALSE;
else
case ncftype ncf::typ::FLOAT64 => TRUE;
_ => FALSE;
esac;
fi;
#
fun falloc_sp (to_temp, next, hap_offset)
=
{ set_float_def_for_codetemp (to_temp, tcf::CODETEMP_INFO_FLOAT (flt_bitsize, make_float_codetemp_info chi::f64_type));
#
translate_nextcode_ops_to_treecode (next, hap_offset);
};
# WARNING: the following generated code should never be executed!
# It is semantic nonsense! XXX BUGGO FIXME
#
if (is_float ncftype) falloc_sp (to_temp, next, hap_offset);
else define_and_load_int1 (to_temp, int k, next, hap_offset); # BOGUS
fi;
}
also
fun call_public_fn (fun_id, actual_args, hap_offset)
=
{ ncftypes_for_args = map ncftype_of actual_args; # "actual_args" is where the argument values currently are.
#
formal_args # "formal_args" is where callee expects to find the argument values.
=
cfa::convert_nextcode_public_fun_args_to_treecode
{
use_virtual_framepointer,
ncftype_for_fun => get_ncftype_for_codetemp fun_id,
ncftypes_for_args
};
dest = case formal_args # 'link' ...?
#
(tcf::INT_EXPRESSION dest ! _)
=>
dest;
_ => error "call_public_fn: dest";
esac;
set_up_args_for_fn_call (formal_args, actual_args); # Copy argument values from where they are to where caller expects to find them.
if track_types_for_heapcleaner
#
buf.put_bblock_note
(
make_heapcleaner_liveinliveout_note
(
hr::heapcleaner_liveout.x_to_note,
formal_args,
ncftypes_for_args
)
);
fi;
maybe_test_heap_allocation_limit hap_offset; # This is a no-op on Intel; on risc it introduces some pipelining by doing the compare early.
buf.put_op (tcf::GOTO (dest, [])); # [] is the might-branch-to labels list.
buf.put_fn_liveout_info (formal_args @ global_registers); # Remember which registers are 'live' at the GOTO (== end of bblock).
}
also
fun call_private_fn (fun_id, actual_args, hap_offset)
=
case (get__callers_info__for__fun_id fun_id)
#
nfs::PRIVATE_FN (REF (nfs::FN_PARAMETERS_IN_TREECODE_FORM formal_args))
=>
{ update_heap_allocation_pointer hap_offset;
#
set_up_args_for_fn_call (formal_args, actual_args);
buf.put_op (go_to_label (get_codelabel_for_fun_id fun_id));
};
nfs::PRIVATE_FN (r as REF (nfs::FN_IN_NEXTCODE_FORM (fun_id, fun_formal_args, ncftypes_for_args, fun_body)))
=>
{ formal_args_in_treecode_form
=
translate_function_formal_args_from_nextcode_to_treecode_form
#
ncftypes_for_args;
fun_label = get_codelabel_for_fun_id fun_id;
r := nfs::FN_PARAMETERS_IN_TREECODE_FORM formal_args_in_treecode_form;
update_heap_allocation_pointer hap_offset;
set_up_args_for_fn_call (formal_args_in_treecode_form, actual_args);
translate_nextcode_function_to_treecode
(
fun_label,
ncf::PRIVATE_FN,
fun_id,
fun_formal_args,
formal_args_in_treecode_form,
ncftypes_for_args,
fun_body
);
};
nfs::PRIVATE_FN_WHICH_NEEDS_HEAPLIMIT_CHECK (fn_info as REF (nfs::FN_IN_NEXTCODE_FORM (fun_id, fun_formal_args, ncftypes_for_args, fun_body)))
=>
{ formal_args_in_treecode_form
=
mp::fixed_arg_passing # fixed_arg_passing is apparently currently always FALSE. -- 2011-08-20 CrT
##
?? cfa::convert_fixed_nextcode_fun_args_to_treecode { ncftypes_for_args, use_virtual_framepointer }
:: translate_function_formal_args_from_nextcode_to_treecode_form ncftypes_for_args;
fun_label = get_codelabel_for_fun_id fun_id;
fn_info := nfs::FN_PARAMETERS_IN_TREECODE_FORM formal_args_in_treecode_form;
set_up_args_for_fn_call (formal_args_in_treecode_form, actual_args);
maybe_test_heap_allocation_limit hap_offset;
translate_nextcode_function_to_treecode
(
fun_label,
ncf::PRIVATE_FN_WHICH_NEEDS_HEAPLIMIT_CHECK,
fun_id,
fun_formal_args,
formal_args_in_treecode_form,
ncftypes_for_args,
fun_body
);
};
nfs::PRIVATE_FN_WHICH_NEEDS_HEAPLIMIT_CHECK (REF (nfs::FN_PARAMETERS_IN_TREECODE_FORM formal_args_in_treecode_form))
=>
{ set_up_args_for_fn_call (formal_args_in_treecode_form, actual_args);
#
maybe_test_heap_allocation_limit hap_offset;
#
buf.put_op (go_to_label (get_codelabel_for_fun_id fun_id));
};
nfs::PUBLIC_FN { parameter_types, ... }
=>
{ formal_args_in_treecode_form
=
cfa::convert_nextcode_public_fun_args_to_treecode
{
ncftype_for_fun => get_ncftype_for_codetemp fun_id,
ncftypes_for_args => parameter_types,
use_virtual_framepointer
};
set_up_args_for_fn_call (formal_args_in_treecode_form, actual_args);
maybe_test_heap_allocation_limit hap_offset;
buf.put_op (go_to_label (get_codelabel_for_fun_id fun_id));
};
esac
also
fun rawload ((ncf::p::INT 32 | ncf::p::UNT 32), i, codetemp, next, hap_offset) # 64-bit issue: '32' is 'wordbits'.
=>
define_and_load_int1 (codetemp, tcf::LOAD (32, i, rgn::memory), next, hap_offset); # 64-bit issue: '32' is 'wordbits'.
rawload (ncf::p::INT (size as (8 | 16)), i, codetemp, next, hap_offset)
=>
define_and_load_int1 (codetemp, sign_extend_32 (size, tcf::LOAD (size, i, rgn::memory)), next, hap_offset);
rawload (ncf::p::UNT (size as (8 | 16)), i, codetemp, next, hap_offset)
=>
define_and_load_int1 (codetemp, zero_extend_32 (size, tcf::LOAD (size, i, rgn::memory)), next, hap_offset);
rawload ((ncf::p::UNT size | ncf::p::INT size), _, _, _, _)
=>
error ("rawload: unsupported size: " + int::to_string size);
rawload (ncf::p::FLOAT 64, i, codetemp, next, hap_offset)
=>
def_and_load_or_inline_float64 (codetemp, tcf::FLOAD (64, i, rgn::memory), next, hap_offset);
rawload (ncf::p::FLOAT 32, i, codetemp, next, hap_offset)
=>
def_and_load_or_inline_float64 (codetemp, tcf::FLOAT_TO_FLOAT (64, 32, tcf::FLOAD (32, i, rgn::memory)), next, hap_offset);
rawload (ncf::p::FLOAT size, _, _, _, _)
=>
error ("rawload: unsupported float size: " + int::to_string size);
end
also
fun rawstore ( ( ncf::p::UNT (size as (8 | 16 | 32))
| ncf::p::INT (size as (8 | 16 | 32))
),
i,
codetemp
)
=>
# Both address and value are 32-bit values;
# only 'size' bits of the value are being stored:
#
buf.put_op (tcf::STORE_INT (size, i, def_for_int_codetemp codetemp, rgn::memory));
rawstore ((ncf::p::UNT size | ncf::p::INT size), _, _)
=>
error ("rawstore: unsupported int size: " + int::to_string size);
rawstore (ncf::p::FLOAT (size as (32 | 64)), i, codetemp)
=>
buf.put_op (tcf::STORE_FLOAT (size, i, def_for_float_codetemp codetemp, rgn::memory));
rawstore (ncf::p::FLOAT size, _, _)
=>
error ("rawstore: unsupported float size: " + int::to_string size);
end
# Generate code
# ncf::DEFINE_RECORD
also
fun translate_nextcode_ops_to_treecode (ncf::DEFINE_RECORD { kind => ncf::rk::FLOAT64_FATE_FN, fields, to_temp, next }, hap_offset) => make_fblock (fields, to_temp, next, hap_offset);
translate_nextcode_ops_to_treecode (ncf::DEFINE_RECORD { kind => ncf::rk::FLOAT64_BLOCK, fields, to_temp, next }, hap_offset) => make_fblock (fields, to_temp, next, hap_offset);
translate_nextcode_ops_to_treecode (ncf::DEFINE_RECORD { kind => ncf::rk::VECTOR, fields, to_temp, next }, hap_offset) => make_vector (fields, to_temp, next, hap_offset);
translate_nextcode_ops_to_treecode (ncf::DEFINE_RECORD { kind => ncf::rk::INT1_BLOCK, fields, to_temp, next }, hap_offset) => make_i32block (fields, to_temp, next, hap_offset);
translate_nextcode_ops_to_treecode (ncf::DEFINE_RECORD { kind => _, fields, to_temp, next }, hap_offset) => make_record (fields, to_temp, next, hap_offset);
###############################
# ncf::GET_FIELD_I: # NB: ncf::INT is untagged.
translate_nextcode_ops_to_treecode (ncf::GET_FIELD_I { i, record => ncf::INT k, to_temp, type, next }, hap_offset) => funny_select (i, k, to_temp, type, next, hap_offset);
translate_nextcode_ops_to_treecode (ncf::GET_FIELD_I { i, record, to_temp, type => ncf::typ::FLOAT64, next }, hap_offset) => fselect (i, record, to_temp, next, hap_offset);
translate_nextcode_ops_to_treecode (ncf::GET_FIELD_I { i, record, to_temp, type, next }, hap_offset) => select (i, record, to_temp, type, next, hap_offset);
###############################
# ncf::GET_ADDRESS_OF_FIELD_I:
translate_nextcode_ops_to_treecode (ncf::GET_ADDRESS_OF_FIELD_I { i, record, to_temp, next }, hap_offset)
=>
define_and_load_boxed (to_temp, add_ix4 (def_for_int_codetemp record, ncf::INT i), next, hap_offset); # ncf::INT is untagged. # 64-bit issue: Need add_ix4 -> add_ix8 on 64-bit architectures.
###############################
# ncf::TAIL_CALL:
translate_nextcode_ops_to_treecode (ncf::TAIL_CALL { fn => ncf::INT k, args }, hap_offset) => update_heap_allocation_pointer hap_offset; # ncf::INT is untagged.
translate_nextcode_ops_to_treecode (ncf::TAIL_CALL { fn => ncf::CODETEMP f, args }, hap_offset) => call_public_fn (f, args, hap_offset);
translate_nextcode_ops_to_treecode (ncf::TAIL_CALL { fn => ncf::LABEL f, args }, hap_offset) => call_private_fn (f, args, hap_offset);
###############################
# ncf::JUMPTABLE:
translate_nextcode_ops_to_treecode (ncf::JUMPTABLE { i => ncf::INT _, ... }, hap_offset)
=>
error "JUMPTABLE"; # Jumptables keying on a constant should have been optimized out in src/lib/compiler/back/top/improve-nextcode/clean-nextcode-g.pkg translate_nextcode_ops_to_treecode (ncf::JUMPTABLE { i, nexts, ... }, hap_offset)
=>
{ label = lbl::make_anonymous_codelabel ();
labels = map (\\ _ = lbl::make_anonymous_codelabel()) nexts;
tmp_r = make_int_codetemp_info chi::i32_type;
tmp = tcf::CODETEMP_INFO (int_bitsize, tmp_r);
buf.put_op (tcf::LOAD_INT_REGISTER (int_bitsize, tmp_r, make_code_for_label_address (label, 0)));
buf.put_op
(tcf::GOTO
(tcf::ADD
( pri::address_width,
tmp,
tcf::LOAD (ptr_bitsize, add_ix4 (tmp, i), rgn::readonly) # 64-bit issue: Need add_ix4 -> add_ix8 on 64-bit architectures.
),
labels
) );
buf.put_pseudo_op pb::DATA_READ_ONLY;
buf.put_pseudo_op (pb::EXT (cpo::JUMPTABLE { base=>label, targets=>labels } ));
buf.put_pseudo_op pb::TEXT;
pl::apply
(\\ (label, next) = put_private_label_and_do_next (label, next, hap_offset))
(labels, nexts);
};
###############################
# ncf::PURE:
translate_nextcode_ops_to_treecode
(
ncf::PURE { op => ncf::p::CONVERT_FLOAT { from=>ncf::p::INT 31, to=>ncf::p::FLOAT 64 }, # 64-bit issue...
args => [ arg ],
to_temp,
next,
...
},
hap_offset
)
=> def_and_load_or_inline_float64 (to_temp, tcf::INT_TO_FLOAT (flt_bitsize, int_bitsize, untag_signed arg), next, hap_offset);
translate_nextcode_ops_to_treecode
( ncf::PURE { op => ncf::p::CONVERT_FLOAT { from=>ncf::p::INT 32, to=>ncf::p::FLOAT 64 }, # 64-bit issue...
args => [ arg ],
to_temp,
next,
...
},
hap_offset
)
=>
def_and_load_or_inline_float64 (to_temp, tcf::INT_TO_FLOAT (flt_bitsize, int_bitsize, def_for_int_codetemp arg), next, hap_offset);
translate_nextcode_ops_to_treecode
( ncf::PURE { op => ncf::p::PURE_ARITH { op, kind_and_size => ncf::p::FLOAT 64 },
args => [ arg ],
to_temp,
next,
...
},
hap_offset
)
=>
{ r = def_for_float_codetemp arg;
#
case op
#
ncf::p::NEGATE => def_and_load_or_inline_float64 (to_temp, tcf::FNEG (flt_bitsize, r), next, hap_offset);
ncf::p::ABS => def_and_load_or_inline_float64 (to_temp, tcf::FABS (flt_bitsize, r), next, hap_offset);
ncf::p::FSQRT => def_and_load_or_inline_float64 (to_temp, tcf::FSQRT (flt_bitsize, r), next, hap_offset);
#
ncf::p::FSIN => define_and_load_float64 (to_temp, tcf::FEXT (flt_bitsize, trx::FSINE r), next, hap_offset);
ncf::p::FCOS => define_and_load_float64 (to_temp, tcf::FEXT (flt_bitsize, trx::FCOSINE r), next, hap_offset);
ncf::p::FTAN => define_and_load_float64 (to_temp, tcf::FEXT (flt_bitsize, trx::FTANGENT r), next, hap_offset);
#
_ => error "unexpected baseop in pure unary float64";
esac;
};
translate_nextcode_ops_to_treecode
(
ncf::PURE { op => ncf::p::PURE_ARITH { op, kind_and_size=>ncf::p::FLOAT 64 },
args => [ arg1, arg2 ],
to_temp,
next,
...
},
hap_offset
)
=>
{ arg1 = def_for_float_codetemp arg1;
arg2 = def_for_float_codetemp arg2;
value = case op
#
ncf::p::ADD => tcf::FADD (flt_bitsize, arg1, arg2);
ncf::p::MULTIPLY => tcf::FMUL (flt_bitsize, arg1, arg2);
ncf::p::SUBTRACT => tcf::FSUB (flt_bitsize, arg1, arg2);
ncf::p::DIVIDE => tcf::FDIV (flt_bitsize, arg1, arg2);
#
_ => error "unexpected baseop in pure binary float64";
esac;
def_and_load_or_inline_float64 (to_temp, value, next, hap_offset);
};
translate_nextcode_ops_to_treecode (ncf::PURE { op => ncf::p::PURE_ARITH { op=>ncf::p::BITWISE_OR, kind_and_size }, args => [arg1, arg2], to_temp, next, ... }, hap_offset)
=>
define_and_load_with_kind_and_size (to_temp, kind_and_size, tcf::BITWISE_OR (int_bitsize, def_for_int_codetemp arg1, def_for_int_codetemp arg2), next, hap_offset);
translate_nextcode_ops_to_treecode (ncf::PURE { op => ncf::p::PURE_ARITH { op=>ncf::p::BITWISE_AND, kind_and_size }, args => [arg1, arg2], to_temp, next, ... }, hap_offset)
=>
define_and_load_with_kind_and_size (to_temp, kind_and_size, tcf::BITWISE_AND (int_bitsize, def_for_int_codetemp arg1, def_for_int_codetemp arg2), next, hap_offset);
translate_nextcode_ops_to_treecode
(
ncf::PURE { op => ncf::p::PURE_ARITH { op, kind_and_size },
args => [arg1, arg2],
to_temp,
type,
next
},
hap_offset
)
=>
case kind_and_size
#
ncf::p::INT 31
=>
case op
ncf::p::BITWISE_XOR => define_and_load_tagged_int (to_temp, tagged_intxor ( arg1, arg2), next, hap_offset);
ncf::p::LSHIFT => define_and_load_tagged_int (to_temp, tagged_intlshift ( arg1, arg2), next, hap_offset);
ncf::p::RSHIFT => define_and_load_tagged_int (to_temp, tagged_intrshift (tcf::RIGHT_SHIFT, arg1, arg2), next, hap_offset);
ncf::p::ADD => define_and_load_tagged_int (to_temp, tagged_intadd ( tcf::ADD, arg1, arg2), next, hap_offset);
ncf::p::SUBTRACT => define_and_load_tagged_int (to_temp, tagged_intsub ( tcf::SUB, arg1, arg2), next, hap_offset);
ncf::p::MULTIPLY => define_and_load_tagged_int (to_temp, tagged_intmul (TRUE, tcf::MULS, arg1, arg2), next, hap_offset);
_ => error "translate_nextcode_ops_to_treecode: ncf::PURE ncf::INT 31";
esac;
ncf::p::INT 32
=>
case op
ncf::p::BITWISE_XOR => arith32 (tcf::BITWISE_XOR, arg1, arg2, to_temp, next, hap_offset);
ncf::p::LSHIFT => logical32 (tcf::LEFT_SHIFT, arg1, arg2, to_temp, next, hap_offset);
ncf::p::RSHIFT => logical32 (tcf::RIGHT_SHIFT, arg1, arg2, to_temp, next, hap_offset);
_ => error "translate_nextcode_ops_to_treecode: ncf::PURE ncf::INT 32";
esac;
ncf::p::UNT 31
=>
case op
ncf::p::ADD => define_and_load_tagged_int (to_temp, tagged_intadd ( tcf::ADD, arg1, arg2), next, hap_offset);
ncf::p::SUBTRACT => define_and_load_tagged_int (to_temp, tagged_intsub ( tcf::SUB, arg1, arg2), next, hap_offset);
ncf::p::MULTIPLY => define_and_load_tagged_int (to_temp, tagged_intmul (FALSE, tcf::MULU, arg1, arg2), next, hap_offset);
ncf::p::DIVIDE => # This is not really a pure
# operation -- oh well:
#
{ update_heap_allocation_pointer hap_offset;
define_and_load_tagged_int (to_temp, tagged_intdiv (FALSE, tcf::d::ROUND_TO_ZERO, arg1, arg2), next, 0);
};
ncf::p::REM => # Neither is this -- oh well
#
{ update_heap_allocation_pointer hap_offset;
define_and_load_tagged_int (to_temp, tagged_intrem (FALSE, tcf::d::ROUND_TO_ZERO, arg1, arg2), next, 0);
};
ncf::p::BITWISE_XOR => define_and_load_tagged_int (to_temp, tagged_intxor ( arg1, arg2), next, hap_offset);
ncf::p::LSHIFT => define_and_load_tagged_int (to_temp, tagged_intlshift ( arg1, arg2), next, hap_offset);
ncf::p::RSHIFT => define_and_load_tagged_int (to_temp, tagged_intrshift (tcf::RIGHT_SHIFT, arg1, arg2), next, hap_offset);
ncf::p::RSHIFTL => define_and_load_tagged_int (to_temp, tagged_intrshift (tcf::RIGHT_SHIFT_U, arg1, arg2), next, hap_offset);
#
_ => error "translate_nextcode_ops_to_treecode: ncf::PURE UINT 31";
esac;
ncf::p::UNT 32
=>
case op
ncf::p::ADD => arith32 (tcf::ADD, arg1, arg2, to_temp, next, hap_offset);
ncf::p::SUBTRACT => arith32 (tcf::SUB, arg1, arg2, to_temp, next, hap_offset);
ncf::p::MULTIPLY => arith32 (tcf::MULU, arg1, arg2, to_temp, next, hap_offset);
ncf::p::DIVIDE => { update_heap_allocation_pointer hap_offset;
arith32 (tcf::DIVU, arg1, arg2, to_temp, next, 0);
};
ncf::p::REM => { update_heap_allocation_pointer hap_offset;
arith32 (tcf::REMU, arg1, arg2, to_temp, next, 0);
};
ncf::p::BITWISE_XOR => arith32 (tcf::BITWISE_XOR, arg1, arg2, to_temp, next, hap_offset);
ncf::p::LSHIFT => logical32 (tcf::LEFT_SHIFT, arg1, arg2, to_temp, next, hap_offset);
ncf::p::RSHIFT => logical32 (tcf::RIGHT_SHIFT, arg1, arg2, to_temp, next, hap_offset);
ncf::p::RSHIFTL => logical32 (tcf::RIGHT_SHIFT_U, arg1, arg2, to_temp, next, hap_offset);
_ => error "translate_nextcode_ops_to_treecode: ncf::PURE UINT 32";
esac;
_ => error "unexpected numkind in pure binary arithop";
esac;
translate_nextcode_ops_to_treecode (ncf::PURE { op => ncf::p::PURE_ARITH { op=>ncf::p::BITWISE_NOT, kind_and_size }, args => [ arg ], to_temp, next, ... }, hap_offset)
=>
case kind_and_size
#
(ncf::p::UNT 32 | ncf::p::INT 32)
=>
define_and_load_int1 (to_temp, tcf::BITWISE_XOR (int_bitsize, def_for_int_codetemp arg, unt 0uxFFFFFFFF), next, hap_offset);
(ncf::p::UNT 31 | ncf::p::INT 31)
=>
define_and_load_tagged_int (to_temp, tcf::SUB (int_bitsize, zero, def_for_int_codetemp arg), next, hap_offset);
_ => error "unexpected numkind in pure bitwise_not arithop";
esac;
translate_nextcode_ops_to_treecode (ncf::PURE { op => ncf::p::PURE_ARITH { op=>ncf::p::NEGATE, kind_and_size }, args => [ arg ], to_temp, next, ... }, hap_offset)
=>
case kind_and_size
#
( ncf::p::UNT 32
| ncf::p::INT 32
)
=>
define_and_load_int1 (to_temp, tcf::SUB (int_bitsize, zero, def_for_int_codetemp arg), next, hap_offset);
( ncf::p::UNT 31
| ncf::p::INT 31
)
=>
define_and_load_tagged_int (to_temp, tcf::SUB (int_bitsize, int 2, def_for_int_codetemp arg), next, hap_offset);
_ => error "unexpected numkind in pure ~ baseop";
esac;
translate_nextcode_ops_to_treecode (ncf::PURE { op => ncf::p::COPY ft, args => [ arg ], to_temp, next, ... }, hap_offset)
=>
case ft
#
(31, 32) => define_and_load_int1 (to_temp, tcf::RIGHT_SHIFT_U (int_bitsize, def_for_int_codetemp arg, one), next, hap_offset);
( 8, 32) => define_and_load_int1 (to_temp, tcf::RIGHT_SHIFT_U (int_bitsize, def_for_int_codetemp arg, one), next, hap_offset);
( 8, 31) => copy (chi::i31_type, to_temp, arg, next, hap_offset);
(n, m) => if (n == m) copy_m (m, to_temp, arg, next, hap_offset);
else error "translate_nextcode_ops_to_treecode: ncf::PURE: copy";
fi;
esac;
translate_nextcode_ops_to_treecode (ncf::PURE { op => ncf::p::COPY_TO_INTEGER _, ... }, hap_offset)
=>
error "translate_nextcode_ops_to_treecode: ncf::PURE: copy_inf";
translate_nextcode_ops_to_treecode (ncf::PURE { op => ncf::p::STRETCH ft, args => [ arg ], to_temp, next, ... }, hap_offset)
=>
case ft
(8, 31) => define_and_load_tagged_int (to_temp, tcf::RIGHT_SHIFT (int_bitsize, tcf::LEFT_SHIFT (int_bitsize, def_for_int_codetemp arg, int 23), int 23), next, hap_offset);
(8, 32) => define_and_load_int1 (to_temp, tcf::RIGHT_SHIFT (int_bitsize, tcf::LEFT_SHIFT (int_bitsize, def_for_int_codetemp arg, int 23), int 24), next, hap_offset);
(31, 32) => define_and_load_int1 (to_temp, tcf::RIGHT_SHIFT (int_bitsize, def_for_int_codetemp arg, one), next, hap_offset);
(n, m) => if (n == m) copy_m (m, to_temp, arg, next, hap_offset);
else error "translate_nextcode_ops_to_treecode: ncf::PURE: extend";
fi;
esac;
translate_nextcode_ops_to_treecode (ncf::PURE { op => ncf::p::STRETCH_TO_INTEGER _, ... }, hap_offset)
=>
error "translate_nextcode_ops_to_treecode: ncf::PURE: extend_inf";
translate_nextcode_ops_to_treecode (ncf::PURE { op => ncf::p::CHOP ft, args => [ arg ], to_temp, next, ... }, hap_offset)
=>
case ft
#
(32, 31) => define_and_load_tagged_int (to_temp, tcf::BITWISE_OR (int_bitsize, tcf::LEFT_SHIFT (int_bitsize, def_for_int_codetemp arg, one), one), next, hap_offset);
(31, 8) => define_and_load_int1 (to_temp, tcf::BITWISE_AND (int_bitsize, def_for_int_codetemp arg, int 0x1ff), next, hap_offset);
(32, 8) => define_and_load_int1 (to_temp, tag_unsigned (tcf::BITWISE_AND (int_bitsize, def_for_int_codetemp arg, int 0xff)), next, hap_offset);
(n, m) => if (n == m) copy_m (m, to_temp, arg, next, hap_offset);
else error "translate_nextcode_ops_to_treecode: ncf::PURE: trunc";
fi;
esac;
translate_nextcode_ops_to_treecode (ncf::PURE { op => ncf::p::CHOP_INTEGER _, ... }, hap_offset)
=>
error "translate_nextcode_ops_to_treecode: ncf::PURE: trunc_inf";
translate_nextcode_ops_to_treecode (ncf::PURE { op => ncf::p::HEAPCHUNK_LENGTH_IN_WORDS, args => [ arg ], to_temp, next, ... }, hap_offset)
=>
define_and_load_tagged_int (to_temp, get_heapchunk_length_as_tagged_int arg, next, hap_offset);
translate_nextcode_ops_to_treecode (ncf::PURE { op => ncf::p::VECTOR_LENGTH_IN_SLOTS, args => [ arg ], to_temp, type, next }, hap_offset)
=>
select (1, arg, to_temp, type, next, hap_offset);
translate_nextcode_ops_to_treecode (ncf::PURE { op => ncf::p::RO_VECTOR_GET, args => [ arg, ncf::INT i ], to_temp, next, ... }, hap_offset) # ncf::INT is untagged.
=>
{ # Get data pointer:
#
mem = get_dataptr_ramregion arg;
a = hc_ptr (tcf::LOAD (int_bitsize, def_for_int_codetemp arg, mem));
mem' = get_rw_vector_ramregion mem;
define_and_load_boxed (to_temp, tcf::LOAD (int_bitsize, add_ix4 (a, ncf::INT i), mem'), next, hap_offset); # ncf::INT is untagged.
};
translate_nextcode_ops_to_treecode (ncf::PURE { op => ncf::p::RO_VECTOR_GET, args => [ arg1, arg2 ], to_temp, next, ... }, hap_offset)
=>
{ # Get data pointer:
#
mem = get_dataptr_ramregion arg1;
a = hc_ptr (tcf::LOAD (int_bitsize, def_for_int_codetemp arg1, mem));
mem' = get_rw_vector_ramregion mem;
define_and_load_boxed (to_temp, tcf::LOAD (int_bitsize, add_ix4 (a, arg2), mem'), next, hap_offset);
};
translate_nextcode_ops_to_treecode (ncf::PURE { op => ncf::p::PURE_GET_VECSLOT_NUMERIC_CONTENTS { kind_and_size=>ncf::p::INT 8 }, args => [ vector, index ], to_temp, next, ... }, hap_offset)
=>
{ # Get data pointer:
#
mem = get_dataptr_ramregion vector;
a = hc_ptr (tcf::LOAD (int_bitsize, def_for_int_codetemp vector, mem));
mem' = get_rw_vector_ramregion mem;
define_and_load_tagged_int (to_temp, tag_unsigned (tcf::LOAD (8, add_ix1 (a, index), mem')), next, hap_offset);
};
translate_nextcode_ops_to_treecode (ncf::PURE { op => ncf::p::GET_BATAG_FROM_TAGWORD, args => [ arg ], to_temp, next, ... }, hap_offset)
=>
define_and_load_tagged_int (to_temp, tag_unsigned (tcf::BITWISE_AND (int_bitsize, get_heapchunk_tagword arg, int (tag::pow_tag_width - 1))), next, hap_offset);
#
# tag_width is 7 -- five bits of b-tag and two bits of a-tag.
# pow_tag_width is 2**tag_width == 1 << tag_width == 0b10000000
# pow_tag_width-1 is 2**tag_width == 1 << tag_width == 0b1111111 -- the mask we need to AND off just the b-tag and a-tag bits.
# 'arg' needs to be Int1 (not Tagged_Int) for this to work properly.
translate_nextcode_ops_to_treecode (ncf::PURE { op => ncf::p::MAKE_WEAK_POINTER_OR_SUSPENSION, args => [ctag, arg], to_temp, next, ... }, hap_offset) # ctag specifies weak pointer vs suspension.
=>
{ tagword = case ctag
ncf::INT ctag => int (tagword_to_int (tag::make_tagword (ctag, tag::weak_pointer_or_suspension_btag))); # ncf::INT is untagged.
_ => tcf::BITWISE_OR
( int_bitsize,
tcf::LEFT_SHIFT (int_bitsize, untag_signed(ctag), int tag::tag_width),
int (tagword_to_int tag::weak_pointer_or_suspension_tagword)
);
esac;
# What heapcleaner types are the components?
#
treeify_allot
( to_temp,
allot_record (mark_nothing, mem_disambig to_temp, tagword, [(arg, offp0)], hap_offset),
next,
hap_offset+8 # 64-bit issue: '8' == 2*wordbytes.
);
};
translate_nextcode_ops_to_treecode (ncf::PURE { op => ncf::p::MAKE_REFCELL, args => [ arg ], to_temp, next, ... }, hap_offset)
=>
{ tag = int (tagword_to_int tag::refcell_tagword);
mem = mem_disambig to_temp;
buf.put_op (tcf::STORE_INT (int_bitsize, tcf::ADD (pri::address_width, pri::heap_allocation_pointer, int hap_offset ), tag, mem));
buf.put_op (tcf::STORE_INT (int_bitsize, tcf::ADD (pri::address_width, pri::heap_allocation_pointer, int (hap_offset+4)), def_for_int_codetemp' arg, mem)); # 64-bit issue: 4==wordbytes.
treeify_allot (to_temp, hap_offset+4, next, hap_offset+8); # 64-bit issue: 4==wordbytes. 8==2*wordbytes
};
translate_nextcode_ops_to_treecode (ncf::PURE { op => ncf::p::WRAP_FLOAT64, args =>[u], to_temp, next, ... }, hap_offset) => make_fblock ([(u, offp0)], to_temp, next, hap_offset);
translate_nextcode_ops_to_treecode (ncf::PURE { op => ncf::p::UNWRAP_FLOAT64, args =>[u], to_temp, next, ... }, hap_offset) => fselect (0, u, to_temp, next, hap_offset);
translate_nextcode_ops_to_treecode (ncf::PURE { op => ncf::p::IWRAP, ... }, _) => error "iwrap not implemented";
translate_nextcode_ops_to_treecode (ncf::PURE { op => ncf::p::IUNWRAP, ... }, _) => error "iunwrap not implemented";
translate_nextcode_ops_to_treecode (ncf::PURE { op => ncf::p::WRAP_INT1, args =>[u], to_temp, next, ... }, hap_offset)
=>
make_i32block([(u, offp0)], to_temp, next, hap_offset);
translate_nextcode_ops_to_treecode (ncf::PURE { op => ncf::p::UNWRAP_INT1, args =>[u], to_temp, next, ... }, hap_offset)
=>
select (0, u, to_temp, ncf::typ::INT1, next, hap_offset);
# Note: the hc type is unsafe! XXX BUGGO FIXME
#
translate_nextcode_ops_to_treecode (ncf::PURE { op => ncf::p::CAST, args => [u], to_temp, next, ... }, hap_offset) => copy (chi::ptr_type, to_temp, u, next, hap_offset);
translate_nextcode_ops_to_treecode (ncf::PURE { op => ncf::p::WRAP, args => [u], to_temp, next, ... }, hap_offset) => copy (chi::ptr_type, to_temp, u, next, hap_offset);
translate_nextcode_ops_to_treecode (ncf::PURE { op => ncf::p::UNWRAP, args => [u], to_temp, next, ... }, hap_offset) => copy (chi::i32_type, to_temp, u, next, hap_offset);
translate_nextcode_ops_to_treecode (ncf::PURE { op => ncf::p::GETCON, args => [u], to_temp, type, next }, hap_offset) => select (0, u, to_temp, type, next, hap_offset);
translate_nextcode_ops_to_treecode (ncf::PURE { op => ncf::p::GETEXN, args => [u], to_temp, type, next }, hap_offset) => select (0, u, to_temp, type, next, hap_offset);
translate_nextcode_ops_to_treecode (ncf::PURE { op => ncf::p::GETSEQDATA, args => [u], to_temp, type, next }, hap_offset) => select (0, u, to_temp, type, next, hap_offset);
translate_nextcode_ops_to_treecode (ncf::PURE { op => ncf::p::RECORD_GET, args => [ arg1, ncf::INT arg2 ], to_temp, type, next }, hap_offset) # ncf::INT is untagged.
=>
select (arg2, arg1, to_temp, type, next, hap_offset);
translate_nextcode_ops_to_treecode (ncf::PURE { op => ncf::p::RECORD_GET, args => [ arg1, arg2 ], to_temp, next, ... }, hap_offset)
=>
# No indirection!
#
{ mem = get_rw_vector_ramregion (get_ramregion arg1);
#
define_and_load_tagged_int (to_temp, tcf::LOAD (int_bitsize, add_ix4 (def_for_int_codetemp arg1, arg2), mem), next, hap_offset);
};
translate_nextcode_ops_to_treecode (ncf::PURE { op => ncf::p::RAW64_GET, args => [vector, index], to_temp, next, ... }, hap_offset)
=>
{ mem = get_rw_vector_ramregion (get_ramregion vector);
#
def_and_load_or_inline_float64 (to_temp, tcf::FLOAD (flt_bitsize, add_ix8 (def_for_int_codetemp vector, index), mem), next, hap_offset);
};
translate_nextcode_ops_to_treecode (ncf::PURE { op => ncf::p::MAKE_ZERO_LENGTH_VECTOR, args => [_], to_temp, next, ... }, hap_offset)
=>
{ hdr_tagword = tagword_to_int tag::typeagnostic_rw_vector_tagword;
data_tagword = tagword_to_int tag::refcell_tagword;
data_ptr = make_int_codetemp_info chi::ptr_type;
hdr_m = mem_disambig to_temp;
tag_m = hdr_m;
val_m = hdr_m; # Allen
# Generate code to allot "REF()" for rw_vector data.
# The three instructions here are:
#
# Store tagword for two-word vector data-part.
# Store tagged-zero content for data-part.
# Load address of part into a register (codetemp).
#
buf.put_op (tcf::STORE_INT (int_bitsize, tcf::ADD (pri::address_width, pri::heap_allocation_pointer, int hap_offset), int data_tagword, tag_m));
#
buf.put_op (tcf::STORE_INT (int_bitsize, tcf::ADD (pri::address_width, pri::heap_allocation_pointer, int (hap_offset+4)), tagged_zero, val_m)); # 64-bit issue, '4' is wordbytes.
#
buf.put_op (tcf::LOAD_INT_REGISTER (ptr_bitsize, data_ptr, tcf::ADD (pri::address_width, pri::heap_allocation_pointer, int (hap_offset+4)))); # 64-bit issue, '4' is wordbytes.
# Generate code to allot rw_vector header:
treeify_allot
(
to_temp,
allocate_vector_header
(
hdr_tagword,
hdr_m,
data_ptr, # Pointer to vector data-part, to be stored in header.
0, # length-in-slots.
hap_offset + 8 # +8 steps over data-part, returning pointer to header.
), # 64-bit issue, '8' is 2*wordbytes.
next,
hap_offset + 20 # 20 == 4*5, probably 2 words for refcell, 3 words for header...? # 64-bit issue, '20' is 5*wordbytes.
);
};
translate_nextcode_ops_to_treecode (ncf::PURE { op => ncf::p::ALLOT_RAW_RECORD NULL, args => [ncf::INT n], to_temp, next, ... }, hap_offset) # ncf::INT is untagged.
=>
# Allocate space for nextcode spilling
#
treeify_allot (to_temp, hap_offset, next, hap_offset+n*4); # No tag! # 64-bit issue, '4' is wordbytes
translate_nextcode_ops_to_treecode (ncf::PURE { op => ncf::p::ALLOT_RAW_RECORD (THE rk), args => [ncf::INT n], to_temp, next, ... }, hap_offset) # ncf::INT is untagged.
=>
# Allocate an uninitialized record with a tag
#
{ my (tag, need_doubleword_alignment)
= # tagged version
case rk
#
ncf::rk::FLOAT64_FATE_FN => (tag::eight_byte_aligned_nonpointer_data_btag, TRUE); # 64-bit issue TRUE should be FALSE on 64-bit machines.
ncf::rk::FLOAT64_BLOCK => (tag::eight_byte_aligned_nonpointer_data_btag, TRUE); # " "
#
ncf::rk::INT1_BLOCK => (tag::four_byte_aligned_nonpointer_data_btag, FALSE);
#
ncf::rk::VECTOR => error "rawrecord VECTOR unsupported";
#
_ => (tag::pairs_and_records_btag, FALSE);
esac;
len = if need_doubleword_alignment n+n; # Len of record in words. # 64-bit issue.
else n;
fi;
tagword = tagword_to_int (tag::make_tagword (len, tag)); # record tagword
# Align floating point
hap_offset = if (need_doubleword_alignment and unt::bitwise_and (unt::from_int hap_offset, 0u4) != 0u0) # 64-bit issue 0u4 == wordbytes
#
hap_offset + 4; # 64-bit issue: '4' == wordbytes.
else hap_offset;
fi;
mem = mem_disambig to_temp;
# store tag now!
buf.put_op (tcf::STORE_INT (int_bitsize, ea (pri::heap_allocation_pointer, hap_offset), int tagword, projection (mem, -1)));
treeify_allot (to_temp, hap_offset+4, next, hap_offset+len*4+4); # Assign the address to 'to_temp' # 64-bit issue: '4' == wordbytes.
};
translate_nextcode_ops_to_treecode (ncf::PURE { op => ncf::p::CONDITIONAL_LOAD compare, args, to_temp, type, next }, hap_offset)
=>
conditional_move (compare, args, to_temp, type, next, hap_offset);
########
# ncf::ARITH
########
translate_nextcode_ops_to_treecode # Arity==1 tagged-int ops.
( ncf::ARITH { op => ncf::p::ARITH { kind_and_size=>ncf::p::INT 31, op=>ncf::p::NEGATE },
args => [v],
to_temp,
next,
...
},
hap_offset
)
=>
{ update_heap_allocation_pointer hap_offset;
#
define_and_load_tagged_int (to_temp, sub_or_trap (int_bitsize, int 2, def_for_int_codetemp v), next, 0);
};
translate_nextcode_ops_to_treecode # Arity==2 tagged-int ops.
(
ncf::ARITH { op => ncf::p::ARITH { kind_and_size=>ncf::p::INT 31, op },
args => [v, w],
to_temp,
next,
...
},
hap_offset
)
=>
{ update_heap_allocation_pointer hap_offset;
#
type = case op
ncf::p::ADD => tagged_intadd ( add_or_trap, v, w);
ncf::p::SUBTRACT => tagged_intsub ( sub_or_trap, v, w);
ncf::p::MULTIPLY => tagged_intmul (TRUE, muls_or_trap, v, w);
#
ncf::p::DIVIDE => tagged_intdiv (TRUE, tcf::d::ROUND_TO_ZERO, v, w); # This is the native instruction on Intel32
ncf::p::DIV => tagged_intdiv (TRUE, tcf::d::ROUND_TO_NEGINF, v, w); # This will be slower on Intel32 -- has to be faked.
#
ncf::p::REM => tagged_intrem (TRUE, tcf::d::ROUND_TO_ZERO, v, w); # This is the native instruction on Intel32
ncf::p::MOD => tagged_intrem (TRUE, tcf::d::ROUND_TO_NEGINF, v, w); # This will be slower on Intel32 -- has to be faked.
#
_ => error "translate_nextcode_ops_to_treecode: ncf::ARITH ncf::INT 31";
esac;
define_and_load_tagged_int (to_temp, type, next, 0);
};
translate_nextcode_ops_to_treecode # Arity==1 word-int ops.
(
ncf::ARITH { op => ncf::p::ARITH { kind_and_size=>ncf::p::INT 32, op=>ncf::p::NEGATE },
args => [v],
to_temp,
next,
...
},
hap_offset
)
=>
{ update_heap_allocation_pointer hap_offset;
#
define_and_load_int1 (to_temp, sub_or_trap (int_bitsize, zero, def_for_int_codetemp v), next, 0);
};
translate_nextcode_ops_to_treecode # Arity==2 word-int ops.
(
ncf::ARITH { op => ncf::p::ARITH { kind_and_size=>ncf::p::INT 32, op },
args => [v, w],
to_temp,
next,
...
},
hap_offset
)
=>
{ update_heap_allocation_pointer hap_offset;
#
case op
ncf::p::ADD => arith32 (add_or_trap, v, w, to_temp, next, 0); # 64-bit issue: here arith32 needs to be renamed or replaced on 64-bit machines
ncf::p::SUBTRACT => arith32 (sub_or_trap, v, w, to_temp, next, 0);
ncf::p::MULTIPLY => arith32 (muls_or_trap, v, w, to_temp, next, 0);
#
ncf::p::DIVIDE => arith32 (\\ (type, x, y) = divs_or_trap (tcf::d::ROUND_TO_ZERO, type, x, y), v, w, to_temp, next, 0);
ncf::p::DIV => arith32 (\\ (type, x, y) = divs_or_trap (tcf::d::ROUND_TO_NEGINF, type, x, y), v, w, to_temp, next, 0);
#
ncf::p::REM => arith32 (\\ (type, x, y) = tcf::REMS (tcf::d::ROUND_TO_ZERO, type, x, y), v, w, to_temp, next, 0);
ncf::p::MOD => arith32 (\\ (type, x, y) = tcf::REMS (tcf::d::ROUND_TO_NEGINF, type, x, y), v, w, to_temp, next, 0);
_ => error "ncf::p::ARITH { kind_and_size=ncf::INT 32, op }, [v, w], ...";
esac;
};
# Note: for testu operations we use a somewhat arcane method
# to generate traps on overflow conditions. A better approach
# would be to generate a trap-if-negative instruction available
# on a variety of machines, e.g. sparc (maybe others). XXX BUGGO FIXME (Actually traps are too expensive, we should use a conditional jump. -- CrT)
#
translate_nextcode_ops_to_treecode
( ncf::ARITH { op => ncf::p::SHRINK_UNT (32, 32),
args => [v],
to_temp,
next,
...
},
hap_offset
)
=>
{ xreg = make_int_codetemp_info chi::i32_type;
vreg = def_for_int_codetemp v;
update_heap_allocation_pointer hap_offset;
buf.put_op (tcf::LOAD_INT_REGISTER (int_bitsize, xreg, add_or_trap (int_bitsize, vreg, def_for_int_codetemp (ncf::INT1 0ux80000000)))); # 64-bit issue "0ux80000000" is not wordlength-agnostic.
define_and_load_int1 (to_temp, vreg, next, 0);
};
translate_nextcode_ops_to_treecode
(
ncf::ARITH { op => ncf::p::SHRINK_UNT (31, 31),
args => [v],
to_temp,
next,
...
},
hap_offset
)
=>
{ xreg = make_int_codetemp_info chi::i31_type;
vreg = def_for_int_codetemp v;
update_heap_allocation_pointer hap_offset;
buf.put_op (tcf::LOAD_INT_REGISTER (int_bitsize, xreg, add_or_trap (int_bitsize, vreg, def_for_int_codetemp (ncf::INT1 0ux80000000)))); # 64-bit issue "0ux80000000" is not wordlength-agnostic.
define_and_load_tagged_int (to_temp, vreg, next, 0);
};
translate_nextcode_ops_to_treecode
(
ncf::ARITH { op => ncf::p::SHRINK_UNT (32, 31), # 64-bit issue 32 31 -> 64 63 on 64-bit machines.
args => [v],
to_temp,
next,
...
},
hap_offset
)
=>
{ vreg = def_for_int_codetemp v;
tmp = make_int_codetemp_info chi::i32_type; # 64-bit issue i32_type
tmp_r = tcf::CODETEMP_INFO (int_bitsize, tmp);
label = lbl::make_anonymous_codelabel ();
buf.put_op (tcf::LOAD_INT_REGISTER (int_bitsize, tmp, def_for_int_codetemp (ncf::INT1 0ux3fffffff))); # 64-bit issue "0ux3fffffff" is not wordlength-agnostic.
update_heap_allocation_pointer hap_offset;
buf.put_op (branch_with_probability (tcf::IF_GOTO (tcf::CMP (32, tcf::LEU, vreg, tmp_r), label), THE probability::likely)); # 64-bit issue 32 is presumably wordbits
buf.put_op (tcf::LOAD_INT_REGISTER (int_bitsize, tmp, tcf::LEFT_SHIFT (int_bitsize, tmp_r, one)));
buf.put_op (tcf::LOAD_INT_REGISTER (int_bitsize, tmp, add_or_trap (int_bitsize, tmp_r, tmp_r)));
buf.put_private_label label;
define_and_load_tagged_int (to_temp, tag_unsigned vreg, next, 0);
};
translate_nextcode_ops_to_treecode (ncf::ARITH { op => ncf::p::SHRINK_UNT _, ... }, hap_offset)
=>
error "translate_nextcode_ops_to_treecode: ncf::ARITH: testu with unexpected precisions (not implemented)";
translate_nextcode_ops_to_treecode
(
ncf::ARITH { op => ncf::p::SHRINK_INT (32, 31), args => [v], to_temp, next, ... }, # 64-bit issue 32 31 -> 64 63 on 64-bit machines.
hap_offset
)
=>
{ update_heap_allocation_pointer hap_offset;
#
define_and_load_tagged_int (to_temp, tag_signed (def_for_int_codetemp v), next, 0);
};
translate_nextcode_ops_to_treecode
( ncf::ARITH { op => ncf::p::SHRINK_INT (n, m),
args => [v],
to_temp,
next,
...
},
hap_offset
)
=>
if (n == m) copy_m (m, to_temp, v, next, hap_offset);
else error "translate_nextcode_ops_to_treecode: ncf::ARITH: test";
fi;
translate_nextcode_ops_to_treecode
(
ncf::ARITH { op => ncf::p::SHRINK_INTEGER _, ... },
hap_offset
)
=>
error "translate_nextcode_ops_to_treecode: ncf::ARITH: test_inf";
translate_nextcode_ops_to_treecode # Arity-2 float64 ops.
(
ncf::ARITH { op => ncf::p::ARITH { op, kind_and_size=>ncf::p::FLOAT 64 },
args => [v, w],
to_temp,
next,
...
},
hap_offset
)
=>
{ v = def_for_float_codetemp v;
w = def_for_float_codetemp w;
t = case op
#
ncf::p::ADD => tcf::FADD (flt_bitsize, v, w);
ncf::p::MULTIPLY => tcf::FMUL (flt_bitsize, v, w);
ncf::p::SUBTRACT => tcf::FSUB (flt_bitsize, v, w);
ncf::p::DIVIDE => tcf::FDIV (flt_bitsize, v, w);
_ => error "unexpected baseop in binary float64";
esac;
def_and_load_or_inline_float64 (to_temp, t, next, hap_offset);
};
#########
# ncf::FETCH_FROM_RAM
#########
translate_nextcode_ops_to_treecode (ncf::FETCH_FROM_RAM { op => ncf::p::GET_REFCELL_CONTENTS, args => [v], to_temp, next, ... }, hap_offset)
=>
{ mem = get_rw_vector_ramregion (get_ramregion v);
#
define_and_load_boxed (to_temp, tcf::LOAD (int_bitsize, def_for_int_codetemp v, mem), next, hap_offset);
};
translate_nextcode_ops_to_treecode (ncf::FETCH_FROM_RAM { op => ncf::p::GET_VECSLOT_CONTENTS, args => [v, w], to_temp, next, ... }, hap_offset)
=>
{ # Get data pointer:
#
mem = get_dataptr_ramregion v;
a = hc_ptr (tcf::LOAD (int_bitsize, def_for_int_codetemp v, mem));
mem' = get_rw_vector_ramregion mem;
define_and_load_boxed (to_temp, tcf::LOAD (int_bitsize, add_ix4 (a, w), mem'), next, hap_offset); # 64-bit issue add_ix4
};
translate_nextcode_ops_to_treecode (ncf::FETCH_FROM_RAM { op => ncf::p::GET_VECSLOT_NUMERIC_CONTENTS { kind_and_size => ncf::p::INT 8 }, args => [v, i], to_temp, next, ... }, hap_offset)
=>
{ # Get data pointer:
#
mem = get_dataptr_ramregion v;
a = hc_ptr (tcf::LOAD (int_bitsize, def_for_int_codetemp v, mem));
mem' = get_rw_vector_ramregion mem;
define_and_load_tagged_int (to_temp, tag_unsigned (tcf::LOAD (8, add_ix1 (a, i), mem')), next, hap_offset);
};
translate_nextcode_ops_to_treecode (ncf::FETCH_FROM_RAM { op => ncf::p::GET_VECSLOT_NUMERIC_CONTENTS { kind_and_size => ncf::p::FLOAT 64 }, args => [v, i], to_temp, next, ... }, hap_offset)
=>
{ # Get data pointer:
#
mem = get_dataptr_ramregion v;
a = hc_ptr (tcf::LOAD (int_bitsize, def_for_int_codetemp v, mem));
mem' = get_rw_vector_ramregion mem;
def_and_load_or_inline_float64 (to_temp, tcf::FLOAD (flt_bitsize, add_ix8 (a, i), mem'), next, hap_offset);
};
translate_nextcode_ops_to_treecode (ncf::FETCH_FROM_RAM { op => ncf::p::GET_EXCEPTION_HANDLER_REGISTER, args => [], to_temp, next, ... }, hap_offset)
=>
define_and_load_boxed (to_temp, pri::exception_handler_register use_virtual_framepointer, next, hap_offset);
translate_nextcode_ops_to_treecode (ncf::FETCH_FROM_RAM { op => ncf::p::GET_CURRENT_MICROTHREAD_REGISTER, args => [], to_temp, next, ... }, hap_offset)
=>
define_and_load_boxed (to_temp, pri::current_thread_ptr use_virtual_framepointer, next, hap_offset);
translate_nextcode_ops_to_treecode (ncf::FETCH_FROM_RAM { op => ncf::p::DEFLVAR, args => [], to_temp, next, ... }, hap_offset)
=>
define_and_load_boxed (to_temp, zero, next, hap_offset);
translate_nextcode_ops_to_treecode (ncf::FETCH_FROM_RAM { op => ncf::p::GET_STATE_OF_WEAK_POINTER_OR_SUSPENSION, args => [v], to_temp, next, ... }, hap_offset)
=>
define_and_load_boxed
(
to_temp,
or_tagged_int_tag (tcf::RIGHT_SHIFT (int_bitsize, get_heapchunk_tagword(v), int (tag::tag_width - 1))),
next,
hap_offset
);
translate_nextcode_ops_to_treecode (ncf::FETCH_FROM_RAM { op => ncf::p::PSEUDOREG_GET, args => [i], to_temp, next, ... }, hap_offset)
=>
{
# print "getpseudo not implemented\n";
nop (to_temp, i, next, hap_offset);
};
translate_nextcode_ops_to_treecode (ncf::FETCH_FROM_RAM { op => ncf::p::GET_FROM_NONHEAP_RAM { kind_and_size }, args => [i], to_temp, next, ... }, hap_offset)
=>
rawload (kind_and_size, def_for_int_codetemp i, to_temp, next, hap_offset);
translate_nextcode_ops_to_treecode (ncf::FETCH_FROM_RAM { op => ncf::p::GET_FROM_NONHEAP_RAM { kind_and_size }, args => [i, j], to_temp, next, ... }, hap_offset)
=>
rawload (kind_and_size, tcf::ADD (pri::address_width, def_for_int_codetemp i, def_for_int_codetemp j), to_temp, next, hap_offset);
#########
# ncf::STORE_TO_RAM
#########
translate_nextcode_ops_to_treecode
( ncf::STORE_TO_RAM { op => ncf::p::SET_NONHEAP_RAMSLOT ncf::typ::FLOAT64,
args => [v, i, w],
next
},
hap_offset
)
=>
{ buf.put_op (tcf::STORE_FLOAT (flt_bitsize, add_ix8 (def_for_int_codetemp' v, i), def_for_float_codetemp w, rgn::memory));
#
translate_nextcode_ops_to_treecode (next, hap_offset);
};
translate_nextcode_ops_to_treecode
(
ncf::STORE_TO_RAM { op => ncf::p::SET_NONHEAP_RAMSLOT _,
args => [v, i, w],
next
},
hap_offset
)
=>
{ # XXX BUGGO FIXME Assumes 32-bit. Needs 64-bit support later!
buf.put_op (tcf::STORE_INT (int_bitsize, add_ix4 (def_for_int_codetemp' v, i), def_for_int_codetemp' w, rgn::memory)); # 64-bit issue: Must change add_ix4 to add_ix8 on 64-bit.
#
translate_nextcode_ops_to_treecode (next, hap_offset);
};
translate_nextcode_ops_to_treecode
(
ncf::STORE_TO_RAM { op => ncf::p::SET_REFCELL,
args => [a as ncf::CODETEMP arr, v],
next
},
hap_offset
)
=>
{ ea = def_for_int_codetemp a;
mem = get_rw_vector_ramregion (get_ramregion a);
#
log_boxed_update_to_heap_changelog (ea, hap_offset);
buf.put_op (tcf::STORE_INT (int_bitsize, ea, def_for_int_codetemp v, mem));
translate_nextcode_ops_to_treecode (next, hap_offset+8); # 64-bit issue '8' is 2*wordbytes
};
translate_nextcode_ops_to_treecode
(
ncf::STORE_TO_RAM { op => ncf::p::SET_REFCELL_TO_TAGGED_INT_VALUE,
args => [a, v],
next
},
hap_offset
)
=>
{ mem = get_rw_vector_ramregion (get_ramregion a);
#
buf.put_op (tcf::STORE_INT (int_bitsize, def_for_int_codetemp a, def_for_int_codetemp v, mem));
translate_nextcode_ops_to_treecode (next, hap_offset);
};
translate_nextcode_ops_to_treecode
(
ncf::STORE_TO_RAM { op => ncf::p::RW_VECTOR_SET, # This does v[i] := w, overwriting i-th slot in pre-existing vector 'v'.
args => [v, i, w],
next
},
hap_offset
)
=>
{ # Get data pointer:
mem = get_dataptr_ramregion v;
a = hc_ptr (tcf::LOAD (int_bitsize, def_for_int_codetemp v, mem));
tmp_r = rgk::make_int_codetemp_info (); # Derived pointer!
tmp = tcf::CODETEMP_INFO (int_bitsize, tmp_r);
ea = add_ix4 (a, i); # Address of updated register # 64-bit issue XXX BUGGO FIXME this needs to be add_ix8 on 64-bit architectures.
mem' = get_rw_vector_ramregion mem;
buf.put_op (tcf::LOAD_INT_REGISTER (int_bitsize, tmp_r, ea));
log_boxed_update_to_heap_changelog (tmp, hap_offset);
buf.put_op (tcf::STORE_INT (int_bitsize, tmp, def_for_int_codetemp w, mem'));
translate_nextcode_ops_to_treecode (next, hap_offset+8); # 64-bit issue: '8' == 2 * wordbytes. (For the two words allocated by the heap-changelog entry.)
};
translate_nextcode_ops_to_treecode
(
ncf::STORE_TO_RAM { op => ncf::p::SET_VECSLOT_TO_BOXED_VALUE, args, next },
hap_offset
)
=>
translate_nextcode_ops_to_treecode (ncf::STORE_TO_RAM { op => ncf::p::RW_VECTOR_SET, args, next }, hap_offset);
translate_nextcode_ops_to_treecode
(
ncf::STORE_TO_RAM { op => ncf::p::SET_VECSLOT_TO_TAGGED_INT_VALUE,
args => [v, i, w], # v[i] := w;
next
},
hap_offset
)
=>
{ # Get data pointer:
#
mem = get_dataptr_ramregion v;
a = hc_ptr (tcf::LOAD (int_bitsize, def_for_int_codetemp v, mem));
mem' = get_rw_vector_ramregion mem;
buf.put_op (tcf::STORE_INT (int_bitsize, add_ix4 (a, i), def_for_int_codetemp w, mem')); # 64-bit issue XXX BUGGO FIXME this needs to be add_ix8 on 64-bit architectures.
translate_nextcode_ops_to_treecode (next, hap_offset);
};
translate_nextcode_ops_to_treecode
(
ncf::STORE_TO_RAM { op => ncf::p::SET_VECSLOT_TO_NUMERIC_VALUE { kind_and_size => ncf::p::INT 8 },
args => [s, i, v], # s[i] := v;
next
},
hap_offset
)
=>
{ # Get data pointer:
#
mem = get_dataptr_ramregion v;
a = hc_ptr (tcf::LOAD (int_bitsize, def_for_int_codetemp s, mem));
ea = add_ix1 (a, i);
mem' = get_rw_vector_ramregion mem;
buf.put_op (tcf::STORE_INT (8, ea, untag_unsigned v, mem'));
translate_nextcode_ops_to_treecode (next, hap_offset);
};
translate_nextcode_ops_to_treecode
(
ncf::STORE_TO_RAM { op => ncf::p::SET_VECSLOT_TO_NUMERIC_VALUE { kind_and_size => ncf::p::FLOAT 64 },
args => [v, i, w], # v[i] := w;
next
},
hap_offset
)
=>
{ # Get data pointer:
#
mem = get_dataptr_ramregion v;
a = hc_ptr (tcf::LOAD (int_bitsize, def_for_int_codetemp v, mem));
mem' = get_rw_vector_ramregion mem;
buf.put_op (tcf::STORE_FLOAT (flt_bitsize, add_ix8 (a, i), def_for_float_codetemp w, mem'));
translate_nextcode_ops_to_treecode (next, hap_offset);
};
translate_nextcode_ops_to_treecode
(
ncf::STORE_TO_RAM { op => ncf::p::SET_STATE_OF_WEAK_POINTER_OR_SUSPENSION,
args => [v, i],
next
},
hap_offset
)
=>
{ ea = tcf::SUB (int_bitsize, def_for_int_codetemp v, int 4); # 64-bit issue: the '4' looks like wordbytes...?
#
i' = case i
#
ncf::INT k => int (tagword_to_int (tag::make_tagword (k, tag::weak_pointer_or_suspension_btag))); # ncf::INT is untagged.
_ => tcf::BITWISE_OR
(
int_bitsize,
tcf::LEFT_SHIFT (int_bitsize, untag_signed i, int tag::tag_width),
int (tagword_to_int tag::weak_pointer_or_suspension_tagword)
);
esac;
mem = get_ramregion_projection (v, 0);
buf.put_op (tcf::STORE_INT (int_bitsize, ea, i', mem));
translate_nextcode_ops_to_treecode (next, hap_offset);
};
translate_nextcode_ops_to_treecode
( ncf::STORE_TO_RAM { op => ncf::p::SET_EXCEPTION_HANDLER_REGISTER,
args => [x],
next
},
hap_offset
)
=>
{ buf.put_op (set_rreg (pri::exception_handler_register use_virtual_framepointer, def_for_int_codetemp x));
#
translate_nextcode_ops_to_treecode (next, hap_offset);
};
translate_nextcode_ops_to_treecode
( ncf::STORE_TO_RAM { op => ncf::p::SET_CURRENT_MICROTHREAD_REGISTER,
args => [x],
next
},
hap_offset
)
=>
{ buf.put_op (set_rreg (pri::current_thread_ptr use_virtual_framepointer, def_for_int_codetemp x));
#
translate_nextcode_ops_to_treecode (next, hap_offset);
};
translate_nextcode_ops_to_treecode (ncf::STORE_TO_RAM { op => ncf::p::USELVAR, args => [x], next }, hap_offset) => translate_nextcode_ops_to_treecode (next, hap_offset); # We silently generate no code for any of these. *blink*
translate_nextcode_ops_to_treecode (ncf::STORE_TO_RAM { op => ncf::p::ACCLINK, args => _, next }, hap_offset) => translate_nextcode_ops_to_treecode (next, hap_offset);
translate_nextcode_ops_to_treecode (ncf::STORE_TO_RAM { op => ncf::p::SETMARK, args => _, next }, hap_offset) => translate_nextcode_ops_to_treecode (next, hap_offset);
translate_nextcode_ops_to_treecode (ncf::STORE_TO_RAM { op => ncf::p::FREE, args => [x], next }, hap_offset) => translate_nextcode_ops_to_treecode (next, hap_offset);
translate_nextcode_ops_to_treecode (ncf::STORE_TO_RAM { op => ncf::p::PSEUDOREG_SET, args => _, next }, hap_offset) => translate_nextcode_ops_to_treecode (next, hap_offset);
translate_nextcode_ops_to_treecode
( ncf::STORE_TO_RAM { op => ncf::p::SET_NONHEAP_RAM { kind_and_size },
args => [i, x],
next
},
hap_offset
)
=>
{ rawstore (kind_and_size, def_for_int_codetemp i, x);
#
translate_nextcode_ops_to_treecode (next, hap_offset);
};
translate_nextcode_ops_to_treecode
( ncf::STORE_TO_RAM { op => ncf::p::SET_NONHEAP_RAM { kind_and_size },
args => [i, j, x],
next
},
hap_offset
)
=>
{ rawstore (kind_and_size, tcf::ADD (pri::address_width, def_for_int_codetemp i, def_for_int_codetemp j), x);
#
translate_nextcode_ops_to_treecode (next, hap_offset);
};
translate_nextcode_ops_to_treecode (ncf::RAW_C_CALL { kind, cfun_name, cfun_type, args, to_ttemps, next }, hap_offset)
=>
{ my { result, hap_offset }
=
fcc::ccall
#
{ treecode_to_machcode_stream => buf,
#
get_int_reg_for_ncfval => def_for_int_codetemp,
get_float_reg_for_ncfvar => def_for_float_codetemp,
#
get_ncftype_for_codetemp,
use_virtual_framepointer,
hap_offset
}
#
(kind, cfun_name, cfun_type, args, to_ttemps, next);
case (result, to_ttemps)
#
([], [(to_temp, _)]) => define_and_load_tagged_int (to_temp, tagged_zero, next, hap_offset);
([tcf::FLOAT_EXPRESSION arg], [(to_temp, ncf::typ::FLOAT64)]) => def_and_load_or_inline_float64 (to_temp, arg, next, hap_offset);
# more sanity checking here ?
([tcf::INT_EXPRESSION arg],[(to_temp, ncf::typ::INT1 )]) => define_and_load_int1 (to_temp, arg, next, hap_offset);
([tcf::INT_EXPRESSION arg],[(to_temp, ncf::typ::POINTER _ )]) => define_and_load_boxed (to_temp, arg, next, hap_offset);
( [ tcf::INT_EXPRESSION arg1,
tcf::INT_EXPRESSION arg2
],
[ (to_temp1, ncf::typ::INT1),
(to_temp2, ncf::typ::INT1)
]
) =>
{ r1 = make_int_codetemp_info chi::i32_type;
r2 = make_int_codetemp_info chi::i32_type;
set_int_def_for_codetemp' (to_temp1, r1);
set_int_def_for_codetemp' (to_temp2, r2);
buf.put_op (tcf::LOAD_INT_REGISTER (int_bitsize, r1, arg1));
buf.put_op (tcf::LOAD_INT_REGISTER (int_bitsize, r2, arg2));
translate_nextcode_ops_to_treecode (next, hap_offset);
};
_ => error "ncf::RAW_C_CALL: bad to_ttemps";
esac;
};
#########
# ncf::IF_THEN_ELSE
#########
translate_nextcode_ops_to_treecode
( ncf::IF_THEN_ELSE { op => ncf::p::COMPARE { op, kind_and_size=>ncf::p::INT 31 }, # 64-bit issue: '31' is suspicious.
args => [ncf::INT v, ncf::INT k], # ncf::INT is untagged.
then_next,
else_next,
...
},
hap_offset
)
=>
# We're comparing two tagged-int constants so
# optimize to just 'then' or 'else' branch.
#
if case op
ncf::p::GT => v > k;
ncf::p::GE => v >= k;
ncf::p::LT => v < k;
ncf::p::LE => v <= k;
ncf::p::EQL => v == k;
ncf::p::NEQ => v != k;
esac
translate_nextcode_ops_to_treecode (then_next, hap_offset);
else translate_nextcode_ops_to_treecode (else_next, hap_offset);
fi;
translate_nextcode_ops_to_treecode
( ncf::IF_THEN_ELSE { op => ncf::p::COMPARE { op, kind_and_size=>ncf::p::INT 32 }, # 64-bit issue: '32' is suspicious.
args => [ ncf::INT1 v, ncf::INT1 k ],
then_next,
else_next,
...
},
hap_offset
)
=>
# We're comparing two Int1 constants so
# optimize to just 'then' or 'else' branch:
#
{ v' = one_word_unt::to_multiword_int_x v;
k' = one_word_unt::to_multiword_int_x k;
if case op
ncf::p::GT => v > k;
ncf::p::GE => v >= k;
ncf::p::LT => v < k;
ncf::p::LE => v <= k;
ncf::p::EQL => v == k;
ncf::p::NEQ => v != k;
esac
translate_nextcode_ops_to_treecode (then_next, hap_offset);
else translate_nextcode_ops_to_treecode (else_next, hap_offset);
fi;
};
translate_nextcode_ops_to_treecode
(
ncf::IF_THEN_ELSE { op => ncf::p::COMPARE { op, kind_and_size=>ncf::p::INT 31 }, args, xvar, then_next, else_next }, # 64-bit issue: '31' is suspicious.
hap_offset
)
=>
branch (xvar, to_tcf_signed_compare op, args, then_next, else_next, hap_offset);
translate_nextcode_ops_to_treecode
( ncf::IF_THEN_ELSE { op => ncf::p::COMPARE { op, kind_and_size=>ncf::p::UNT 31 }, # 64-bit issue: '31' is suspicious.
args => [ncf::INT v', ncf::INT k'], # ncf::INT is untagged.
then_next,
else_next,
...
},
hap_offset
)
=>
# We're comparing two Unt constants so
# optimize to just 'then' or 'else' branch:
#
{ include package unt;
#
v = from_int v';
k = from_int k';
if case op
ncf::p::GT => v > k;
ncf::p::GE => v >= k;
ncf::p::LT => v < k;
ncf::p::LE => v <= k;
ncf::p::EQL => v == k;
ncf::p::NEQ => v != k;
esac
translate_nextcode_ops_to_treecode (then_next, hap_offset);
else translate_nextcode_ops_to_treecode (else_next, hap_offset);
fi;
};
translate_nextcode_ops_to_treecode (ncf::IF_THEN_ELSE { op => ncf::p::COMPARE { op, kind_and_size=>ncf::p::UNT 31 }, args, xvar, then_next, else_next }, hap_offset) # 64-bit issue: '31' is suspicious.
=>
branch (xvar, to_tcf_unsigned_compare op, args, then_next, else_next, hap_offset);
translate_nextcode_ops_to_treecode (ncf::IF_THEN_ELSE { op => ncf::p::COMPARE { op, kind_and_size=>ncf::p::UNT 32 }, args => [ncf::INT1 v, ncf::INT1 k], then_next, else_next, ... }, hap_offset) # 64-bit issue: '32' is suspicious.
=>
{ include package one_word_unt; # We're comparing two Unt1 constants: Optimize to just 'then' or 'else' branch.
#
if case op
ncf::p::GT => v > k;
ncf::p::GE => v >= k;
ncf::p::LT => v < k;
ncf::p::LE => v <= k;
ncf::p::EQL => v == k;
ncf::p::NEQ => v != k;
esac
translate_nextcode_ops_to_treecode (then_next, hap_offset);
else translate_nextcode_ops_to_treecode (else_next, hap_offset);
fi;
};
translate_nextcode_ops_to_treecode (ncf::IF_THEN_ELSE { op => ncf::p::COMPARE { op, kind_and_size=>ncf::p::UNT 32 }, args, xvar, then_next, else_next }, hap_offset) # 64-bit issue: '32' is suspicious.
=>
branch (xvar, to_tcf_unsigned_compare op, args, then_next, else_next, hap_offset);
translate_nextcode_ops_to_treecode (ncf::IF_THEN_ELSE { op => ncf::p::COMPARE { op, kind_and_size=>ncf::p::INT 32 }, args, xvar, then_next, else_next }, hap_offset) # 64-bit issue: '32' is suspicious.
=>
branch (xvar, to_tcf_signed_compare op, args, then_next, else_next, hap_offset);
translate_nextcode_ops_to_treecode (ncf::IF_THEN_ELSE { op => ncf::p::COMPARE_FLOATS { op, size=>64 }, args => [v, w], then_next, else_next, ... }, hap_offset) # 64-bit issue: '64' is suspicious.
=>
{ true_label = lbl::make_anonymous_codelabel ();
#
compare = float64cmp (op, v, w);
buf.put_op (tcf::IF_GOTO (compare, true_label));
do_next (else_next, hap_offset);
put_private_label (true_label, then_next, hap_offset);
};
translate_nextcode_ops_to_treecode (ncf::IF_THEN_ELSE { op => ncf::p::POINTER_EQL, args, xvar, then_next, else_next }, hap_offset) => branch (xvar, tcf::EQ, args, then_next, else_next, hap_offset);
translate_nextcode_ops_to_treecode (ncf::IF_THEN_ELSE { op => ncf::p::POINTER_NEQ, args, xvar, then_next, else_next }, hap_offset) => branch (xvar, tcf::NE, args, then_next, else_next, hap_offset);
translate_nextcode_ops_to_treecode (ncf::IF_THEN_ELSE { op => ncf::p::STRING_NEQ, args => [ncf::INT string_len, string1, string2], then_next, else_next, ... }, hap_offset) # ncf::INT is untagged.
=>
branch_streq (string_len, string1, string2, else_next, then_next, hap_offset); # Compare two strings of known length via fully unrolled word-comparison loop.
translate_nextcode_ops_to_treecode (ncf::IF_THEN_ELSE { op => ncf::p::STRING_EQL, args => [ncf::INT string_len, string1, string2], then_next, else_next, ... }, hap_offset) # ncf::INT is untagged.
=>
branch_streq (string_len, string1, string2, then_next, else_next, hap_offset); # Compare two strings of known length via fully unrolled word-comparison loop.
translate_nextcode_ops_to_treecode (ncf::IF_THEN_ELSE { op => ncf::p::IS_BOXED, args => [x], xvar, then_next, else_next }, hap_offset) => branch_if_boxed (xvar, x, then_next, else_next, hap_offset);
translate_nextcode_ops_to_treecode (ncf::IF_THEN_ELSE { op => ncf::p::IS_UNBOXED, args => [x], xvar, then_next, else_next }, hap_offset) => branch_if_boxed (xvar, x, else_next, then_next, hap_offset);
translate_nextcode_ops_to_treecode (e, hap_offset)
=>
{ ppn::print_nextcode_expression e;
print "\n";
error "translate_nextcode_to_treecode::translate_nextcode_ops_to_treecode";
};
end;
#
fun translate_all_pushed_functions ()
=
translate_one_function (nfs::pop_function ())
where
fun translate_next_function ()
=
translate_one_function (nfs::pop_function())
also
fun translate_one_function NULL => ();
#
translate_one_function (THE(_, nfs::PRIVATE_FN _) ) => translate_next_function ();
translate_one_function (THE(_, nfs::PRIVATE_FN_WHICH_NEEDS_HEAPLIMIT_CHECK _) ) => translate_next_function ();
translate_one_function (THE(_, nfs::PUBLIC_FN { fn => REF NULL, ... } ) ) => translate_next_function ();
translate_one_function (THE (fun_codelabel, nfs::PUBLIC_FN { fn as REF (THE (zz as (callers_info, fun_id, fun_formal_args, ncftypes_for_args, fun_body))), ... }))
=>
{ formal_args_in_treecode_form
=
cfa::convert_nextcode_public_fun_args_to_treecode
{
ncftype_for_fun => get_ncftype_for_codetemp fun_id,
ncftypes_for_args,
use_virtual_framepointer
};
fn := NULL;
buf.put_pseudo_op (pb::ALIGN_SIZE 2);
translate_nextcode_function_to_treecode (fun_codelabel, callers_info, fun_id, fun_formal_args, formal_args_in_treecode_form, ncftypes_for_args, fun_body);
translate_next_function ();
};
end;
end; # fun translate_all_pushed_functions
# Execution starts at the first nextcode function:
#
fun push_nextcode_functions (first_function ! remaining_functions: List( ncf::Function ))
=>
{ apply push_nextcode_function remaining_functions;
#
push_nextcode_function first_function;
}
where
fun push_nextcode_function (function as (_, fun_id, _, _, _))
=
set__callers_info__for__fun_id (fun_id, nfs::push_nextcode_function (function, get_codelabel_for_fun_id fun_id));
end;
push_nextcode_functions []
=>
error "push_nextcode_functions";
end;
# Create callgraph connected-component annotations.
# Currently, we only need
# to enter the appropriate
# heapcleaner map information.
#
fun create_cccomponent_annotations ()
=
{ registerinfo
=
if track_types_for_heapcleaner # Currently ALWAYS FALSE -- this appears to be an unfinished project.
#
fun set_heapcleaner_info_on_codetemp_info (tcf::CODETEMP_INFO(_, r), type) => hr::set_heapcleaner_info_on_codetemp_info (r, type);
set_heapcleaner_info_on_codetemp_info _ => ();
end;
hr::set_heapcleaner_info_on_codetemp_info (heap_allocation_pointer_register, chi::HEAP_ALLOCATION_POINTER);
set_heapcleaner_info_on_codetemp_info (pri::heap_allocation_limit use_virtual_framepointer, chi::HEAP_ALLOCATION_LIMIT);
set_heapcleaner_info_on_codetemp_info (pri::base_pointer use_virtual_framepointer, chi::ptr_type);
set_heapcleaner_info_on_codetemp_info (pri::stdlink use_virtual_framepointer, chi::ptr_type);
[ lhn::print_register_info.x_to_note hr::codetemp_info_to_string ];
else
[];
fi;
use_virtual_framepointer
?? lhn::uses_virtual_framepointer.set ((), registerinfo)
:: registerinfo ;
};
push_nextcode_functions cccomponent;
buf.start_new_cccomponent 0; # Here the zero is a dummy; in other contexts it is used to size the codebuffer.
buf.put_pseudo_op pb::TEXT;
translate_all_pushed_functions ();
ihc::put_all_publicfn_heapcleaner_longjumps_and_all_privatefn_heapcleaner_calls_for_cccomponent
#
buf;
translate_machcode_cccomponent_to_execode # def in src/lib/compiler/back/low/main/main/backend-lowhalf-g.pkg per_compile_stuff
(buf.get_completed_cccomponent (create_cccomponent_annotations()));
}; # fun translate_nextcode_cccomponent_to_treecode
#
fun finish_compilation_unit file
=
{ buf = t2m::make_treecode_to_machcode_codebuffer (mkg::make_machcode_codebuffer ());
# 'buf' implementation is in src/lib/compiler/back/low/intel32/treecode/translate-treecode-to-machcode-intel32-g.pkg # 'buf' implementation is in src/lib/compiler/back/low/pwrpc32/treecode/translate-treecode-to-machcode-pwrpc32-g.pkg # 'buf' implementation is in src/lib/compiler/back/low/sparc32/treecode/translate-treecode-to-machcode-sparc32-g.pkg rgk::reset_codetemp_id_allocation_counters();
uvf::use_virtual_framepointer := FALSE; # Assume not until we know otherwise.
buf.start_new_cccomponent 0; # The 0 is a dummy here; in some applications the arg is used to size 'buf'.
buf.put_pseudo_op pb::TEXT;
ihc::put_all_publicfn_heapcleaner_calls_for_package buf;
buf.put_pseudo_op (pb::DATA_READ_ONLY);
buf.put_pseudo_op (pb::EXT (cpo::FILENAME file));
translate_machcode_cccomponent_to_execode
per_compile_stuff
(buf.get_completed_cccomponent no_opt);
};
#
fun get_entrypoint_offset_of_first_function ((_, f, _, _, _) ! _) ()
=>
lbl::get_codelabel_address (get_codelabel_for_fun_id f);
get_entrypoint_offset_of_first_function [] ()
=>
error "entrypoint: no functions";
end;
end; # fun translate_nextcode_to_execode
end;
}; # generic package translate_nextcode_to_treecode_g
end;