## translate-anormcode-to-nextcode-g.pkg
#
# Converting anormcode_form::Function
# to nextcode_form::Function.
#
#
#
# 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 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 first backend lowhalf code representation, used only transitionally. It is typically slightly specialized for each target architecture, e.g. Intel32 (x86).
# 7) Machcode is the second and chief backend lowhalf code representation. It abstracts the target architecture machine instructions.
# 8) Execode is absolute executable binary machine instructions for the target architecture.
#
# Our task here is converting from the fourth to the fifth form.
#
#
#
# For anormcode code format see: src/lib/compiler/back/top/anormcode/anormcode-form.api# For nextcode code format see: src/lib/compiler/back/top/nextcode/nextcode-form.api# We get invoked (only) from: src/lib/compiler/back/top/main/backend-tophalf-g.pkg#
# This generic defines function translate_anormcode_to_nextcode
# which constitutes the transition from the first to the second
# half of 'highcode', the back end upper half.
# It is called from translate_anormcode_to_execode in
#
# src/lib/compiler/back/top/main/backend-tophalf-g.pkg#
# "[nextcode] Conversion: In this phase [lambdacode] is converted into [nextcode].
# The [nextcode] language is designed to match the execution model of a
# von Neumann register machine: functions in [nextcode] can have multiple
# arguments, and variables (and function arguments) correspond closely to
# machine registers. Like the [lambdacode] language, the [nextcode] language
# here is also typed, but with an even simpler set of types. [...] This phase
# also determines the argument-passing convention for all function calls and
# returns, and the representation for all records and concrete sumtypes."
#
# -- p33, "Compiling Standard ML For Efficient Execution on Modern Machines"
# http://flint.cs.yale.edu/flint/publications/zsh-thesis.pdf
#
# (Anormcode was not supported in the above-described version of the compiler, 1994.)
#
# The real work here is converting from anormcode's tree-structured
# expressions to the 'next'-chained linear expressions of nextcode.
#
# This gets done in fun "loop'"
#
# We also do switch optimization at this point, delegating the work to
#
# src/lib/compiler/back/top/nextcode/improve-anormcode-switch-fn.pkg# Compiled by:
# src/lib/compiler/core.sublib# *************************************************************************
# IMPORTANT NOTES *
# *
# The nextcode code generated by this phase should not *
# use OFFSET and RECORD accesspath SELp. *
# generated by this module. *
# *************************************************************************
stipulate
package acf = anormcode_form; # anormcode_form is from src/lib/compiler/back/top/anormcode/anormcode-form.pkg package ncf = nextcode_form; # nextcode_form is from src/lib/compiler/back/top/nextcode/nextcode-form.pkgherein
api Translate_Anormcode_To_Nextcode {
#
translate_anormcode_to_nextcode
:
acf::Function
->
ncf::Function;
};
end;
# Machine_Properties is from src/lib/compiler/back/low/main/main/machine-properties.apistipulate
package acf = anormcode_form; # anormcode_form is from src/lib/compiler/back/top/anormcode/anormcode-form.pkg package acj = anormcode_junk; # anormcode_junk is from src/lib/compiler/back/top/anormcode/anormcode-junk.pkg package da = varhome; # varhome is from src/lib/compiler/front/typer-stuff/basics/varhome.pkg package di = debruijn_index; # debruijn_index is from src/lib/compiler/front/typer/basics/debruijn-index.pkg package hbo = highcode_baseops; # highcode_baseops is from src/lib/compiler/back/top/highcode/highcode-baseops.pkg package hcf = highcode_form; # highcode_form is from src/lib/compiler/back/top/highcode/highcode-form.pkg package iht = int_hashtable; # int_hashtable is from src/lib/src/int-hashtable.pkg package im = int_binary_map; # int_binary_map is from src/lib/src/int-binary-map.pkg package isf = improve_anormcode_switch_fn; # improve_anormcode_switch_fn is from src/lib/compiler/back/top/nextcode/improve-anormcode-switch-fn.pkg package ncf = nextcode_form; # nextcode_form is from src/lib/compiler/back/top/nextcode/nextcode-form.pkg package rat = recover_anormcode_type_info; # recover_anormcode_type_info is from src/lib/compiler/back/top/improve/recover-anormcode-type-info.pkg package tmp = highcode_codetemp; # highcode_codetemp is from src/lib/compiler/back/top/highcode/highcode-codetemp.pkgherein
# This generic is invoked (only) from:
#
# src/lib/compiler/back/top/main/backend-tophalf-g.pkg #
generic package translate_anormcode_to_nextcode_g (
# =================================
#
machine_properties: Machine_Properties # Typically src/lib/compiler/back/low/main/intel32/machine-properties-intel32.pkg )
: (weak) Translate_Anormcode_To_Nextcode # Translate_Anormcode_To_Nextcode is from src/lib/compiler/back/top/nextcode/translate-anormcode-to-nextcode-g.pkg {
fun bug s
=
error_message::impossible ("translate_anormcode_to_nextcode_g: " + s);
say = global_controls::print::say;
make_codetemp = \\ _ = tmp::issue_highcode_codetemp (); # The '_' is a little trick that lets us do map make_codetemp xs to make a list with as many codetemps as there are elements in 'xs'.
clone_codetemp = tmp::clone_highcode_codetemp; # Create and return a fresh codetemp. If we're tracking human-readable codetemp names for debugging purposes, make the new codetemp have the same name as the original.
fun with_fresh_codetemp f
=
{ v = make_codetemp ();
f v;
};
nop_fn = \\ le = le; # no-op fn, aka "identity \\".
offp0 = ncf::SLOT 0;
# Test whether two values are
# equivalent Variable values
fun veq (ncf::CODETEMP x, ncf::CODETEMP y) => x == y;
veq _ => FALSE;
end;
# *************************************************************************
# CONSTANTS AND UTILITY FUNCTIONS *
# *************************************************************************
fun unwrapf64 (u, to_temp, next) = ncf::PURE { op => ncf::p::UNWRAP_FLOAT64, args => [u], to_temp, type => ncf::typ::FLOAT64, next };
fun unwrapi32 (u, to_temp, next) = ncf::PURE { op => ncf::p::UNWRAP_INT1, args => [u], to_temp, type => ncf::typ::INT1, next }; # 64-bit issue. We have at least a naming issue here.
fun wrapf64 (u, to_temp, next) = ncf::PURE { op => ncf::p::WRAP_FLOAT64, args => [u], to_temp, type => ncf::bogus_pointer_type, next };
fun wrapi32 (u, to_temp, next) = ncf::PURE { op => ncf::p::WRAP_INT1, args => [u], to_temp, type => ncf::bogus_pointer_type, next }; # 64-bit issue. We have at least a naming issue here.
fun all_float (ncf::typ::FLOAT64 ! r) => all_float r;
all_float (_ ! r) => FALSE;
all_float [] => TRUE;
end;
fun get_field_from_all_float_record (i, record, to_temp, type, next) # Get a field from an all-float record.
=
ncf::GET_FIELD_I { i, record, to_temp, type, next };
fun get_field (i, record, to_temp, type, next) # Get a field from a record which is not all floats.
=
case type
#
ncf::typ::FLOAT64 => with_fresh_codetemp (\\ codetemp = ncf::GET_FIELD_I { i, record, to_temp => codetemp, type => ncf::bogus_pointer_type, next => unwrapf64 (ncf::CODETEMP codetemp, to_temp, next) } );
ncf::typ::INT1 => with_fresh_codetemp (\\ codetemp = ncf::GET_FIELD_I { i, record, to_temp => codetemp, type => ncf::bogus_pointer_type, next => unwrapi32 (ncf::CODETEMP codetemp, to_temp, next) } );
#
_ => ncf::GET_FIELD_I { i, record, to_temp, type, next };
esac;
fun all_float_record (fields, _, to_temp, next)
=
ncf::DEFINE_RECORD
{
kind => ncf::rk::FLOAT64_BLOCK,
fields => map (\\ field = (field, ncf::SLOT 0)) fields,
to_temp,
next
};
fun record (fields, field_types, to_temp, next)
=
{ (do_fields (field_types, fields, [], \\ x = x))
->
(fields, header);
header (ncf::DEFINE_RECORD { kind => ncf::rk::RECORD, fields, to_temp, next });
}
where
fun do_fields (ncf::typ::FLOAT64 ! more_fieldtypes, field ! more_fields, fields', header')
=>
with_fresh_codetemp (\\ codetemp = do_fields ( more_fieldtypes,
more_fields,
(ncf::CODETEMP codetemp, ncf::SLOT 0) ! fields',
\\ ce = header' (wrapf64 (field, codetemp, ce))
)
);
do_fields (ncf::typ::INT1 ! more_fieldtypes, field ! more_fields, fields', header')
=>
with_fresh_codetemp (\\ codetemp = do_fields ( more_fieldtypes,
more_fields,
(ncf::CODETEMP codetemp, ncf::SLOT 0) ! fields',
\\ ce = header' (wrapi32 (field, codetemp, ce))
)
);
do_fields (_ ! more_fieldtypes, field ! more_fields, fields', header')
=>
do_fields (more_fieldtypes, more_fields, (field, offp0) ! fields', header');
do_fields ([], [], fields', header')
=>
(reverse fields', header');
do_fields _ => bug "unexpected in recordNM in convert";
end;
end;
# *************************************************************************
# UTILITY FUNCTIONS FOR PROCESSING THE BASEOPS *
# *************************************************************************
fun translate_number_kind_and_size (hbo::INT bits) => ncf::p::INT bits;
translate_number_kind_and_size (hbo::UNT bits) => ncf::p::UNT bits;
translate_number_kind_and_size (hbo::FLOAT bits) => ncf::p::FLOAT bits;
end;
fun translate_compare_op compare_op
=
case compare_op
#
{ op=>hbo::EQL, kind_and_size=>hbo::INT 31 }
=>
ncf::p::ieql;
{ op=>hbo::NEQ, kind_and_size=>hbo::INT 31 }
=>
ncf::p::ineq;
{ op, kind_and_size=>hbo::FLOAT size }
=>
{ fun c hbo::GT => ncf::p::f::GT;
c hbo::GE => ncf::p::f::GE;
c hbo::LT => ncf::p::f::LT;
c hbo::LE => ncf::p::f::LE;
c hbo::EQL => ncf::p::f::EQ;
c hbo::NEQ => ncf::p::f::ULG;
c _ => bug "translate_compare_op: kind_and_size=hbo::FLOAT";
end;
ncf::p::COMPARE_FLOATS { op=> c op, size };
};
{ op, kind_and_size }
=>
ncf::p::COMPARE { op => c op, kind_and_size => translate_number_kind_and_size kind_and_size }
where
fun check (_, hbo::UNT _) => ();
check (op, _) => bug ("check" + op);
end;
fun c hbo::GT => ncf::p::GT;
c hbo::GE => ncf::p::GE;
c hbo::LT => ncf::p::LT;
c hbo::LE => ncf::p::LE;
c hbo::LEU => { check ("leu", kind_and_size); ncf::p::LE ;};
c hbo::LTU => { check ("ltu", kind_and_size); ncf::p::LT ;};
c hbo::GEU => { check ("geu", kind_and_size); ncf::p::GE ;};
c hbo::GTU => { check ("gtu", kind_and_size); ncf::p::GT ;};
c hbo::EQL => ncf::p::EQL;
c hbo::NEQ => ncf::p::NEQ;
end;
end;
esac;
fun translate_compare (p: hbo::Baseop)
=
case p
#
hbo::IS_BOXED => ncf::p::IS_BOXED;
hbo::IS_UNBOXED => ncf::p::IS_UNBOXED;
#
hbo::COMPARE compare_op => translate_compare_op compare_op;
#
hbo::POINTER_EQL => ncf::p::POINTER_EQL;
hbo::POINTER_NEQ => ncf::p::POINTER_NEQ;
#
_ => bug "unexpected primops in translate_compare";
esac;
fun translate_wrap_op ncf::typ::INT => ncf::p::IWRAP;
translate_wrap_op ncf::typ::INT1 => ncf::p::WRAP_INT1;
translate_wrap_op ncf::typ::FLOAT64 => ncf::p::WRAP_FLOAT64;
translate_wrap_op _ => ncf::p::WRAP;
end;
fun translate_unwrap_op ncf::typ::INT => ncf::p::IUNWRAP;
translate_unwrap_op ncf::typ::INT1 => ncf::p::UNWRAP_INT1;
translate_unwrap_op ncf::typ::FLOAT64 => ncf::p::UNWRAP_FLOAT64;
translate_unwrap_op _ => ncf::p::UNWRAP;
end;
fun translate_arithop hbo::NEGATE => ncf::p::NEGATE;
translate_arithop hbo::ABS => ncf::p::ABS;
translate_arithop hbo::FSQRT => ncf::p::FSQRT;
#
translate_arithop hbo::FSIN => ncf::p::FSIN;
translate_arithop hbo::FCOS => ncf::p::FCOS;
translate_arithop hbo::FTAN => ncf::p::FTAN;
#
translate_arithop hbo::DIVIDE => ncf::p::DIVIDE; # Round-to-zero division -- this is the native instruction on Intel32.
translate_arithop hbo::DIV => ncf::p::DIV; # Round-to-negative-infinity division -- this will be much slower on Intel32, has to be faked.
#
translate_arithop hbo::REM => ncf::p::REM; # Round-to-zero remainder -- this is the native instruction on Intel32.
translate_arithop hbo::MOD => ncf::p::MOD; # Round-to-negative-infinity remainder -- this will be much slower on Intel32, has to be faked.
#
translate_arithop hbo::ADD => ncf::p::ADD;
translate_arithop hbo::SUBTRACT => ncf::p::SUBTRACT;
translate_arithop hbo::MULTIPLY => ncf::p::MULTIPLY;
#
translate_arithop hbo::LSHIFT => ncf::p::LSHIFT;
translate_arithop hbo::RSHIFT => ncf::p::RSHIFT;
translate_arithop hbo::RSHIFTL => ncf::p::RSHIFTL;
#
translate_arithop hbo::BITWISE_NOT => ncf::p::BITWISE_NOT;
translate_arithop hbo::BITWISE_AND => ncf::p::BITWISE_AND;
translate_arithop hbo::BITWISE_OR => ncf::p::BITWISE_OR;
translate_arithop hbo::BITWISE_XOR => ncf::p::BITWISE_XOR;
end;
Baseop_Kind # Classify baseops based on memory/purity semantics.
= STORE_TO_RAM ncf::p::Store_To_Ram
| PURE_PRIMOP ncf::p::Pure
| FETCH_FROM_RAM ncf::p::Fetch_From_Ram
| ARITHMETIC_PRIMOP ncf::p::Arith
;
fun translate_baseop (baseop: hbo::Baseop)
=
case baseop
#
hbo::SHRINK_INT (from, to) => ARITHMETIC_PRIMOP (ncf::p::SHRINK_INT (from, to));
hbo::SHRINK_UNT (from, to) => ARITHMETIC_PRIMOP (ncf::p::SHRINK_UNT (from, to));
hbo::COPY (from, to) => PURE_PRIMOP (ncf::p::COPY (from, to));
hbo::STRETCH (from, to) => PURE_PRIMOP (ncf::p::STRETCH (from, to));
hbo::CHOP (from, to) => PURE_PRIMOP (ncf::p::CHOP (from, to));
hbo::SHRINK_INTEGER to => ARITHMETIC_PRIMOP (ncf::p::SHRINK_INTEGER to);
hbo::CHOP_INTEGER to => PURE_PRIMOP (ncf::p::CHOP_INTEGER to);
hbo::COPY_TO_INTEGER from => PURE_PRIMOP (ncf::p::COPY_TO_INTEGER from);
hbo::STRETCH_TO_INTEGER from => PURE_PRIMOP (ncf::p::STRETCH_TO_INTEGER from);
hbo::ARITH { op, kind_and_size, overflow=>TRUE } => ARITHMETIC_PRIMOP (ncf::p::ARITH { op=>translate_arithop op, kind_and_size=>translate_number_kind_and_size kind_and_size } );
hbo::ARITH { op, kind_and_size, overflow=>FALSE } => PURE_PRIMOP (ncf::p::PURE_ARITH { op=>translate_arithop op, kind_and_size=>translate_number_kind_and_size kind_and_size } );
hbo::ROUND { floor, from, to }
=>
ARITHMETIC_PRIMOP (ncf::p::ROUND { floor,
from => translate_number_kind_and_size from,
to => translate_number_kind_and_size to
}
);
hbo::CONVERT_FLOAT { from, to }
=>
PURE_PRIMOP (ncf::p::CONVERT_FLOAT { to => translate_number_kind_and_size to,
from => translate_number_kind_and_size from
}
);
hbo::RO_VECTOR_GET => PURE_PRIMOP ncf::p::RO_VECTOR_GET;
hbo::MAKE_REFCELL => PURE_PRIMOP ncf::p::MAKE_REFCELL;
hbo::VECTOR_LENGTH_IN_SLOTS => PURE_PRIMOP ncf::p::VECTOR_LENGTH_IN_SLOTS;
hbo::HEAPCHUNK_LENGTH_IN_WORDS => PURE_PRIMOP ncf::p::HEAPCHUNK_LENGTH_IN_WORDS;
hbo::GET_BATAG_FROM_TAGWORD => PURE_PRIMOP ncf::p::GET_BATAG_FROM_TAGWORD;
hbo::MAKE_WEAK_POINTER_OR_SUSPENSION => PURE_PRIMOP ncf::p::MAKE_WEAK_POINTER_OR_SUSPENSION;
# hbo::THROW => PURE_PRIMOP ncf::p::CAST;
hbo::CAST => PURE_PRIMOP ncf::p::CAST;
hbo::MAKE_EXCEPTION_TAG => PURE_PRIMOP ncf::p::MAKE_REFCELL;
hbo::MAKE_ZERO_LENGTH_VECTOR => PURE_PRIMOP ncf::p::MAKE_ZERO_LENGTH_VECTOR;
hbo::GET_VECTOR_DATACHUNK => PURE_PRIMOP ncf::p::GETSEQDATA;
hbo::RECORD_GET => PURE_PRIMOP ncf::p::RECORD_GET;
hbo::RAW64_GET => PURE_PRIMOP ncf::p::RAW64_GET;
hbo::RW_VECTOR_GET => FETCH_FROM_RAM (ncf::p::GET_VECSLOT_CONTENTS);
hbo::GET_VECSLOT_NUMERIC_CONTENTS { kind_and_size, immutable=>FALSE, checkbounds=>FALSE } => FETCH_FROM_RAM ( ncf::p::GET_VECSLOT_NUMERIC_CONTENTS { kind_and_size=>translate_number_kind_and_size kind_and_size } );
hbo::GET_VECSLOT_NUMERIC_CONTENTS { kind_and_size, immutable=>TRUE, checkbounds=>FALSE } => PURE_PRIMOP (ncf::p::PURE_GET_VECSLOT_NUMERIC_CONTENTS { kind_and_size=>translate_number_kind_and_size kind_and_size } );
hbo::GET_REFCELL_CONTENTS => FETCH_FROM_RAM ncf::p::GET_REFCELL_CONTENTS;
hbo::GET_RUNTIME_ASM_PACKAGE_RECORD => FETCH_FROM_RAM ncf::p::GET_RUNTIME_ASM_PACKAGE_RECORD;
hbo::GET_EXCEPTION_HANDLER_REGISTER => FETCH_FROM_RAM ncf::p::GET_EXCEPTION_HANDLER_REGISTER;
hbo::GET_CURRENT_MICROTHREAD_REGISTER => FETCH_FROM_RAM ncf::p::GET_CURRENT_MICROTHREAD_REGISTER;
hbo::PSEUDOREG_GET => FETCH_FROM_RAM ncf::p::PSEUDOREG_GET;
hbo::GET_STATE_OF_WEAK_POINTER_OR_SUSPENSION => FETCH_FROM_RAM ncf::p::GET_STATE_OF_WEAK_POINTER_OR_SUSPENSION;
hbo::DEFLVAR => FETCH_FROM_RAM ncf::p::DEFLVAR;
hbo::SET_EXCEPTION_HANDLER_REGISTER => STORE_TO_RAM ncf::p::SET_EXCEPTION_HANDLER_REGISTER;
hbo::SET_VECSLOT_TO_NUMERIC_VALUE { kind_and_size, checkbounds=>FALSE } => STORE_TO_RAM (ncf::p::SET_VECSLOT_TO_NUMERIC_VALUE { kind_and_size=>translate_number_kind_and_size kind_and_size } );
hbo::SET_VECSLOT_TO_TAGGED_INT_VALUE => STORE_TO_RAM ncf::p::SET_VECSLOT_TO_TAGGED_INT_VALUE;
hbo::SET_VECSLOT_TO_BOXED_VALUE => STORE_TO_RAM ncf::p::SET_VECSLOT_TO_BOXED_VALUE;
hbo::RW_VECTOR_SET => STORE_TO_RAM ncf::p::RW_VECTOR_SET;
hbo::SET_REFCELL => STORE_TO_RAM ncf::p::SET_REFCELL;
hbo::SET_REFCELL_TO_TAGGED_INT_VALUE => STORE_TO_RAM ncf::p::SET_REFCELL_TO_TAGGED_INT_VALUE;
hbo::SET_CURRENT_MICROTHREAD_REGISTER => STORE_TO_RAM ncf::p::SET_CURRENT_MICROTHREAD_REGISTER;
hbo::PSEUDOREG_SET => STORE_TO_RAM ncf::p::PSEUDOREG_SET;
hbo::SETMARK => STORE_TO_RAM ncf::p::SETMARK;
hbo::DISPOSE => STORE_TO_RAM ncf::p::FREE;
hbo::SET_STATE_OF_WEAK_POINTER_OR_SUSPENSION => STORE_TO_RAM ncf::p::SET_STATE_OF_WEAK_POINTER_OR_SUSPENSION;
hbo::USELVAR => STORE_TO_RAM (ncf::p::USELVAR);
hbo::GET_FROM_NONHEAP_RAM nk => FETCH_FROM_RAM (ncf::p::GET_FROM_NONHEAP_RAM { kind_and_size => translate_number_kind_and_size nk } );
hbo::SET_NONHEAP_RAM nk => STORE_TO_RAM (ncf::p::SET_NONHEAP_RAM { kind_and_size => translate_number_kind_and_size nk } );
hbo::RAW_ALLOCATE_C_RECORD { fblock => FALSE } => PURE_PRIMOP (ncf::p::ALLOT_RAW_RECORD (THE ncf::rk::INT1_BLOCK));
hbo::RAW_ALLOCATE_C_RECORD { fblock => TRUE } => PURE_PRIMOP (ncf::p::ALLOT_RAW_RECORD (THE ncf::rk::FLOAT64_BLOCK));
_ => bug ("bad baseop in translate_baseop: " + (hbo::baseop_to_string baseop) + "\n");
esac;
# *************************************************************************
# SWITCH OPTIMIZATIONS AND COMPILATIONS *
# *************************************************************************
# BUG: The definition of e_unt is clearly incorrect since it can raise exceptions
# and overflow at code generation time. A clean solution would be
# to add an UNT constructor into the nextcode language -- daunting!
# The revolting hack solution would be to put the right int constant
# that gets converted to the right set of bits for the word constant. XXX BUGGO FIXME
fun do_switch_fn rename
=
isf::make_anormcode_switch_fn_improver
{
e_int => \\ i = if (i < -0x20000000 or i >= 0x20000000) raise exception isf::TOO_BIG;
else ncf::INT i;
fi,
e_unt => \\ w = # if w >= 0wx20000000
# then raise exception Switch::TOO_BIG else
ncf::INT (unt::to_int_x w),
e_real => (\\ s = ncf::FLOAT64 s),
e_switchlimit => 4,
e_neq => ncf::p::ineq,
e_w32neq => ncf::p::COMPARE { op=>ncf::p::NEQ, kind_and_size=>ncf::p::UNT 32 },
e_i32neq => ncf::p::COMPARE { op=>ncf::p::NEQ, kind_and_size=>ncf::p::INT 32 },
e_unt1 => ncf::INT1,
e_int1 => ncf::INT1,
e_wneq => ncf::p::COMPARE { op=>ncf::p::NEQ, kind_and_size=>ncf::p::UNT 31 },
e_pneq => ncf::p::POINTER_NEQ,
e_fneq => ncf::p::fneq,
e_less => ncf::p::ilt,
e_branch => (\\ (op, x, y, then_next, else_next) = ncf::IF_THEN_ELSE { op, args => [x, y], xvar => make_codetemp(), then_next, else_next }),
e_strneq => (\\ (w, str, then_next, else_next) = ncf::IF_THEN_ELSE { op => ncf::p::STRING_NEQ, args => [ncf::INT (size str), w, ncf::STRING str], xvar => make_codetemp(), then_next, else_next }),
e_switch => (\\ (i, nexts) = ncf::JUMPTABLE { i, xvar => make_codetemp(), nexts }),
e_add => (\\ (x, y, c)
=
with_fresh_codetemp
(\\ to_temp
=
ncf::ARITH { op => ncf::p::iadd,
args => [x, y],
to_temp,
type => ncf::typ::INT,
next => c (ncf::CODETEMP to_temp)
}
) ),
e_gettag => (\\ (arg, c) = with_fresh_codetemp (\\ to_temp = ncf::PURE { op => ncf::p::GETCON, args =>[arg], to_temp, type => ncf::typ::INT, next => c (ncf::CODETEMP to_temp ) } )),
e_unwrap => (\\ (arg, c) = with_fresh_codetemp (\\ to_temp = ncf::PURE { op => ncf::p::UNWRAP, args =>[arg], to_temp, type => ncf::typ::INT, next => c (ncf::CODETEMP to_temp ) } )),
e_getexn => (\\ (arg, c) = with_fresh_codetemp (\\ to_temp = ncf::PURE { op => ncf::p::GETEXN, args =>[arg], to_temp, type => ncf::bogus_pointer_type, next => c (ncf::CODETEMP to_temp ) } )),
e_length => (\\ (arg, c) = with_fresh_codetemp (\\ to_temp = ncf::PURE { op => ncf::p::VECTOR_LENGTH_IN_SLOTS, args =>[arg], to_temp, type => ncf::typ::INT, next => c (ncf::CODETEMP to_temp ) } )),
e_boxed => (\\ (x, then_next, else_next) = ncf::IF_THEN_ELSE { op => ncf::p::IS_BOXED,
args => [x],
xvar => make_codetemp(),
then_next,
else_next
}
),
e_path => \\ (da::HIGHCODE_VARIABLE v, k) => k (rename v);
_ => bug "unexpected path in do_switch_fn";
end
};
###########################################################################
# UTILITY FUNCTIONS FOR DEALING WITH META-LEVEL FATES
###########################################################################
Metafate # An abstract representation of the meta-level fate.
=
METAFATE { fate: List (ncf::Value) -> ncf::Instruction,
types: List( ncf::Type )
};
fun apply_metafate
( METAFATE { fate, ... },
values: List (ncf::Value)
)
: ncf::Instruction
=
fate values;
fun make_metafate (fate, types)
=
METAFATE { fate, types };
fun get_types_from_metafate (METAFATE { types, ... } )
=
types;
###########################################################################
# THE MAIN FUNCTION
###########################################################################
# This function is invoked (only) as phase "translate_anormcode_to_nextcode" in
# the toplevel highcode driver module,
#
# src/lib/compiler/back/top/main/backend-tophalf-g.pkg #
fun translate_anormcode_to_nextcode (function_declaration: acf::Function): ncf::Function
=
{ (rat::recover_anormcode_type_info (function_declaration, TRUE))
->
{ get_uniqtypoid_for_anormcode_value, clean_up, ... };
uniqtypoid_to_nextcode_types = map ncf::uniqtypoid_to_nextcode_type;
fun res_ctys f
=
{ lt = get_uniqtypoid_for_anormcode_value (acf::VAR f);
if (hcf::uniqtypoid_is_generic_package lt) uniqtypoid_to_nextcode_types (#2 (hcf::unpack_generic_package_uniqtypoid lt));
elif (hcf::uniqtypoid_is_arrow_type lt) uniqtypoid_to_nextcode_types (#3 (hcf::unpack_arrow_uniqtypoid lt));
else [ ncf::bogus_pointer_type ];
fi;
};
fun get_nextcode_type_for_anormcode_value v
=
ncf::uniqtypoid_to_nextcode_type (get_uniqtypoid_for_anormcode_value v);
fun is_float_record u
=
hcf::if_uniqtypoid_is_type
(
get_uniqtypoid_for_anormcode_value u,
\\ tc = hcf::if_uniqtype_is_tuple (
tc,
\\ l = all_float (map ncf::uniqtype_to_nextcode l),
\\ _ = FALSE
),
\\ _ = FALSE
);
bogus_fate_codetemp = make_codetemp();
fun bogus_header next
=
{ bogus_knownf = make_codetemp();
ncf::DEFINE_FUNS
{
funs => [ ( ncf::PRIVATE_FN,
bogus_knownf,
[ make_codetemp () ],
[ ncf::bogus_pointer_type ],
#
ncf::TAIL_CALL { fn => ncf::CODETEMP bogus_knownf,
args => [ ncf::STRING "bogus" ]
}
)
],
next => ncf::DEFINE_FUNS
{
funs =>
[ ( ncf::FATE_FN,
bogus_fate_codetemp,
[ make_codetemp () ],
[ ncf::bogus_pointer_type ],
#
ncf::TAIL_CALL { fn => ncf::CODETEMP bogus_knownf,
args => [ncf::STRING "bogus"]
}
)
],
next
}
};
};
exception RENAME;
renaming_table = iht::make_hashtable { size_hint => 32, not_found_exception => RENAME }
: iht::Hashtable( ncf::Value )
;
fun rename_codetemp (codetemp: tmp::Codetemp): ncf::Value
=
iht::get renaming_table codetemp
except
RENAME = ncf::CODETEMP codetemp;
fun newname ( codetemp: tmp::Codetemp,
value: ncf::Value
)
: Void
=
{ case value
#
ncf::CODETEMP value' => tmp::share_name (codetemp, value');
_ => ();
esac;
iht::set renaming_table (codetemp, value);
};
fun newnames ([]: List(tmp::Codetemp), []: List(ncf::Value)): Void
=>
();
newnames ( codetemp ! codetemps,
value ! values
)
=>
{ newname (codetemp, value);
newnames (codetemps, values);
};
newnames _ => bug "unexpected case in newnames";
end;
# "eta reduction" gets rid of functions like
# fun foo x = bar x;
# which simply pass their argument to another function,
# we we can't do this if the function calls itself like
# fun foo x = foo x;
#
stipulate
fun calls_self
( ncf::TAIL_CALL { fn => w as ncf::CODETEMP lv,
args => vl
},
ul: List(ncf::Value)
): Null_Or(ncf::Value)
=>
# If the function is in the global renaming table and it is
# renamed to itself, then it is most likely a while loop and
# should *not* be eta-reduced
if ( case (iht::get renaming_table lv)
#
ncf::CODETEMP lv' => lv == lv';
_ => FALSE;
esac
except
RENAME = FALSE
)
NULL;
else
h (ul, vl)
where
fun h (x ! xs, y ! ys)
=>
(veq (x, y) and not (veq (w, y)))
?? h (xs, ys)
:: NULL;
h ([], [])
=>
THE w;
h _ =>
NULL;
end;
end;
fi;
calls_self _ => NULL;
end;
herein
fun prevent_erroneous_eta_reductions (METAFATE { fate, types } ): ((ncf::Instruction -> ncf::Instruction), ncf::Value)
=
{ vl = map make_codetemp types;
ul = map ncf::CODETEMP vl;
b = fate ul;
case (calls_self (b, ul) )
#
THE w => (nop_fn, w);
NULL => { f = make_codetemp();
( \\ next = ncf::DEFINE_FUNS { funs => [(ncf::FATE_FN, f, vl, types, b)], next },
ncf::CODETEMP f
);
};
esac;
};
end;
do_switch # Switch optimization
=
do_switch_fn rename_codetemp;
fun translate_value (acf::VAR c) => rename_codetemp c;
translate_value (acf::UNT1 w) => ncf::INT1 w;
translate_value (acf::INT i) => ncf::INT i;
translate_value (acf::UNT w) => ncf::INT (unt::to_int_x w);
translate_value (acf::FLOAT64 r) => ncf::FLOAT64 r;
translate_value (acf::STRING s) => ncf::STRING s;
translate_value (acf::INT1 i)
=>
{ int1_to_unt1 = one_word_unt::from_multiword_int
o
one_word_int::to_multiword_int;
ncf::INT1 (int1_to_unt1 i);
};
end;
fun translate_values (vl: List(acf::Value)): List(ncf::Value)
=
h (vl, [])
where
fun h ( [], z) => reverse z;
h (a ! r, z) => h (r, (translate_value a) ! z);
end;
end;
fun loop' (tailmap: im::Map(tmp::Codetemp))
#
( expression: acf::Expression,
metafate: Metafate
)
: ncf::Instruction
=
{ loop = loop' tailmap;
#
case expression
#
acf::RET vs => apply_metafate (metafate, translate_values vs);
#
acf::LET (vs, e1, e2)
=>
loop (e1, metafate')
where
metafate' = make_metafate
( \\ ws = { newnames (vs, ws);
loop (e2, metafate);
},
map (get_nextcode_type_for_anormcode_value o acf::VAR) vs
);
end;
acf::MUTUALLY_RECURSIVE_FNS (fds, e)
=>
{
fun lpfd ((fk, f, fn_parameters, e): acf::Function): ncf::Function
=
{ k = make_codetemp();
cl = ncf::typ::FATE ! (map (ncf::uniqtypoid_to_nextcode_type o #2) fn_parameters); # #2 gives us the type of a fn parameter.
metafate' = make_metafate
( \\ args = ncf::TAIL_CALL { fn => ncf::CODETEMP k, args },
res_ctys f
);
my (vl, body)
=
case fk
#
{ loop_info => THE (_, acf::TAIL_RECURSIVE_LOOP), ... }
=>
{ # For tail recursive loops, we create a
# local function that takes its fate
# from the dictionary:
f' = clone_codetemp f;
newname (f', ncf::CODETEMP f'); # Add an entry for f' in the global renaming table to stop calls_self from marking it for "eta reduction" (elimination):
vl = k ! (map (clone_codetemp o #1) fn_parameters); # #1 yields the codetemp naming a fn parameter.
vl' = map #1 fn_parameters;
cl' = map (ncf::uniqtypoid_to_nextcode_type o #2) fn_parameters;
( vl,
ncf::DEFINE_FUNS
{
funs =>
[ ( ncf::PRIVATE_TAIL_RECURSIVE_FN,
f',
vl',
cl',
loop' (im::set (tailmap, f, f')) (e, metafate') # Add the function to the tailmap.
)
],
next =>
ncf::TAIL_CALL { fn => ncf::CODETEMP f',
args => map ncf::CODETEMP (tail vl)
}
}
);
};
_ => ( k ! (map #1 fn_parameters), # #1 gives us the codetemp naming a fn parameter.
loop (e, metafate')
);
esac;
(ncf::PUBLIC_FN, f, vl, cl, body);
};
ncf::DEFINE_FUNS { funs => map lpfd fds,
next => loop (e, metafate)
};
};
acf::APPLY (f as acf::VAR lv, vs)
=>
# First check if it's a recursive call to a tail loop:
#
case (im::get (tailmap, lv))
#
THE f' => ncf::TAIL_CALL { fn => ncf::CODETEMP f',
args => translate_values vs
};
NULL => # Code for the non-tail case.
# Sadly this is *not* exceptional
{ (prevent_erroneous_eta_reductions metafate) -> (header, fff);
#
fn = translate_value f;
ul = translate_values vs;
header (ncf::TAIL_CALL { fn, args => fff ! ul });
};
esac;
acf::APPLY _ => bug "unexpected ncf::TAIL_CALL in convert";
acf::TYPEFUN _ => bug "unexpected TYPEFUN in convert";
acf::APPLY_TYPEFUN _ => bug "unexpected APPLY_TYPEFUN in convert";
acf::CONSTRUCTOR (dc, ts, u, v, e) => bug "unexpected case CONSTRUCTOR during anormcode-to-nextcode conversion";
acf::RECORD (acf::RK_VECTOR _, [], v, e) => bug "zero length vectors in convert";
acf::RECORD (rk, [], v, e)
=>
{ newname (v, ncf::INT 0);
loop (e, metafate);
};
acf::RECORD (record_notes, values, to_temp, e)
=>
{ types' = map get_nextcode_type_for_anormcode_value values;
values' = translate_values values;
next = loop (e, metafate);
case record_notes
#
acf::RK_TUPLE _
=>
all_float types'
?? all_float_record (values', types', to_temp, next)
:: record (values', types', to_temp, next);
acf::RK_VECTOR _
=>
ncf::DEFINE_RECORD
{ kind => ncf::rk::VECTOR,
fields => map (\\ x = (x, offp0)) values',
to_temp,
next
};
_ => record (values', types', to_temp, next);
esac;
};
acf::GET_FIELD (record, slot, name, expression) # Use codetemp 'name' as a name for record[slot] during execution of 'expression'
=>
{ type' = get_nextcode_type_for_anormcode_value (acf::VAR name);
record' = translate_value record;
expression' = loop (expression, metafate);
if (is_float_record record) get_field_from_all_float_record (slot, record', name, type', expression');
else get_field (slot, record', name, type', expression');
fi;
};
acf::SWITCH (e, l, [ a as (acf::VAL_CASETAG((_, da::CONSTANT 0, _), _, _), _),
b as (acf::VAL_CASETAG((_, da::CONSTANT 1, _), _, _), _)
],
NULL)
=>
loop (acf::SWITCH (e, l, [b, a], NULL), metafate);
acf::SWITCH (u, an_api, l, d)
=>
{ (prevent_erroneous_eta_reductions metafate) -> (header, fn);
metafate' = make_metafate ( \\ args = ncf::TAIL_CALL { fn, args },
get_types_from_metafate metafate
);
next = { df = make_codetemp();
#
fun proc (cn as (acf::VAL_CASETAG (dc, _, v)), e)
=>
(cn, loop (acf::LET([v], acf::RET [u], e), metafate'));
proc (cn, e)
=>
(cn, loop (e, metafate'));
end;
next = do_switch { an_api,
expression => translate_value u,
cases => map proc l,
default => ncf::TAIL_CALL { fn => ncf::CODETEMP df,
args => [ ncf::INT 0 ]
}
};
case d
#
NULL => next;
THE de => ncf::DEFINE_FUNS { next,
funs => [ ( ncf::FATE_FN,
df,
[make_codetemp()],
[ncf::typ::INT],
loop (de, metafate')
)
]
};
esac;
};
header next;
};
acf::RAISE (exception_to_raise, result_type)
=>
{ apply_metafate (metafate, (map (\\ _ = ncf::CODETEMP (make_codetemp())) result_type)); # Execute the metafate for side effects.
#
h = make_codetemp(); # Now call the exception handler.
ncf::FETCH_FROM_RAM
{
op => ncf::p::GET_EXCEPTION_HANDLER_REGISTER,
args => [],
to_temp => h,
type => ncf::typ::FUN,
next => ncf::TAIL_CALL { fn => ncf::CODETEMP h,
args => [ ncf::CODETEMP bogus_fate_codetemp, translate_value exception_to_raise ]
}
};
};
acf::EXCEPT (expression, new_exception_handler) # Execute 'expression' with 'new_exception_handler' in force, restoring the original exception handler when done.
=>
{ (prevent_erroneous_eta_reductions metafate) -> (header, fn);
old_exception_handler_codetemp # Somewhere to save original exception handler while we're executing.
=
make_codetemp();
metafate'
=
make_metafate
( \\ args = ncf::STORE_TO_RAM { op => ncf::p::SET_EXCEPTION_HANDLER_REGISTER, # This is the code that will restore the original exception handler at end of 'expression' execution.
args => [ncf::CODETEMP old_exception_handler_codetemp],
next => ncf::TAIL_CALL { fn, args }
},
get_types_from_metafate metafate
);
body = { new_exception_handler_codetemp = make_codetemp();
new_exception_handler_arg_codetemp = make_codetemp();
ncf::DEFINE_FUNS
{
funs => [ ( ncf::PUBLIC_FN,
new_exception_handler_codetemp, # Name for new handler.
[ make_codetemp(), new_exception_handler_arg_codetemp ], # Args for new handler.
[ ncf::typ::FATE, ncf::bogus_pointer_type ], # Arg types.
ncf::STORE_TO_RAM # Handler body.
{ op => ncf::p::SET_EXCEPTION_HANDLER_REGISTER, # First thing new handler does is restore original handler.
args => [ ncf::CODETEMP old_exception_handler_codetemp ],
next => ncf::TAIL_CALL { fn => translate_value new_exception_handler,
args => [ fn, ncf::CODETEMP new_exception_handler_arg_codetemp]
}
}
)
],
next => ncf::STORE_TO_RAM # Set up new exception handler as the currently active one.
{ op => ncf::p::SET_EXCEPTION_HANDLER_REGISTER,
args => [ ncf::CODETEMP new_exception_handler_codetemp ],
next => loop (expression, metafate') # Do 'expression'. Our metafate' will restore original exception handler, then continue normally.
}
};
};
ncf::FETCH_FROM_RAM # Save original exception handler.
{ op => ncf::p::GET_EXCEPTION_HANDLER_REGISTER,
args => [],
to_temp => old_exception_handler_codetemp,
type => ncf::typ::FUN,
next => header body
};
};
acf::BASEOP((_, p as (hbo::CALLCC | hbo::CALL_WITH_CURRENT_CONTROL_FATE), _, _), [f], v, e)
=>
{ my (kont_decs, fn)
=
{ k = make_codetemp();
ct = get_nextcode_type_for_anormcode_value f;
( [ (ncf::FATE_FN, k, [v], [ct], loop (e, metafate)) ],
ncf::CODETEMP k
);
};
my (hdr1, hdr2)
=
case p
#
hbo::CALLCC
=>
with_fresh_codetemp
(\\ codetemp
=
( \\ next = ncf::STORE_TO_RAM { op => ncf::p::SET_EXCEPTION_HANDLER_REGISTER,
args => [ ncf::CODETEMP codetemp ],
next
},
\\ next = ncf::FETCH_FROM_RAM { op => ncf::p::GET_EXCEPTION_HANDLER_REGISTER,
args => [],
to_temp => codetemp,
type => ncf::bogus_pointer_type,
next
}
)
);
_ => (nop_fn, nop_fn);
esac;
my (ccont_decs, ccont_var)
=
{ k = make_codetemp(); # Captured fate.
x = make_codetemp();
( [ ( ncf::PUBLIC_FN,
k,
[ make_codetemp(), x ],
[ ncf::typ::FATE, ncf::bogus_pointer_type ],
hdr1 (ncf::TAIL_CALL { fn, args => [ncf::CODETEMP x] })
)
],
k
);
};
ncf::DEFINE_FUNS
{
funs => kont_decs,
#
next =>
hdr2 (ncf::DEFINE_FUNS
{
funs => ccont_decs,
#
next => ncf::TAIL_CALL { fn => translate_value f,
args => [fn, ncf::CODETEMP ccont_var]
}
}
)
};
};
acf::BASEOP ((_, hbo::MAKE_ISOLATED_FATE, lt, ts), [f], v, e)
=>
{ my (exndecs, exnvar)
=
{ h = make_codetemp ();
z = make_codetemp ();
x = make_codetemp ();
( [ ( ncf::PUBLIC_FN,
h,
[z, x],
[ncf::typ::FATE, ncf::bogus_pointer_type],
ncf::TAIL_CALL { fn => ncf::CODETEMP bogus_fate_codetemp,
args => [ncf::CODETEMP x]
}
)
],
h
);
};
newfdecs
=
{ nf = v;
z = make_codetemp ();
x = make_codetemp ();
[ ( ncf::PUBLIC_FN,
v,
[z, x],
[ncf::typ::FATE, ncf::bogus_pointer_type],
ncf::STORE_TO_RAM
{ op => ncf::p::SET_EXCEPTION_HANDLER_REGISTER,
args => [ncf::CODETEMP exnvar],
next => ncf::TAIL_CALL { fn => translate_value f,
args => [ncf::CODETEMP bogus_fate_codetemp, ncf::CODETEMP x]
}
}
)
];
};
ncf::DEFINE_FUNS { funs => exndecs,
#
next => ncf::DEFINE_FUNS { funs => newfdecs,
next => loop (e, metafate)
}
};
};
acf::BASEOP (po as (_, hbo::THROW, _, _), [u], v, e)
=>
{ newname (v, translate_value u);
loop (e, metafate);
};
acf::BASEOP (po as (_, hbo::WCAST, _, _), [u], v, e)
=>
{ newname (v, translate_value u);
loop (e, metafate);
};
acf::BASEOP (po as (_, hbo::WRAP, _, _), [u], to_temp, next)
=>
{ ct = ncf::uniqtype_to_nextcode (acj::get_wrap_type po);
#
ncf::PURE { op => translate_wrap_op ct,
args => [translate_value u],
to_temp,
type => ncf::bogus_pointer_type,
next => loop (next, metafate)
};
};
acf::BASEOP (po as (_, hbo::UNWRAP, _, _), [u], to_temp, next)
=>
{ type = ncf::uniqtype_to_nextcode (acj::get_un_wrap_type po);
#
ncf::PURE { op => translate_unwrap_op type,
args => [translate_value u],
to_temp,
type,
next => loop (next, metafate)
};
};
acf::BASEOP (po as (_, hbo::MARK_EXCEPTION_WITH_STRING, _, _), [x, m], v, e)
=>
{ bty = hcf::truevoid_uniqtypoid;
ety = hcf::make_tuple_uniqtypoid [bty, bty, bty];
xx = make_codetemp();
x0 = make_codetemp();
x1 = make_codetemp();
x2 = make_codetemp();
y = make_codetemp();
z = make_codetemp();
z' = make_codetemp();
ncf::PURE { op => ncf::p::UNWRAP, args => [translate_value x], to_temp => xx, type => ncf::uniqtypoid_to_nextcode_type (ety), next =>
ncf::GET_FIELD_I { i => 0, record => ncf::CODETEMP xx, to_temp => x0, type => ncf::bogus_pointer_type, next =>
ncf::GET_FIELD_I { i => 1, record => ncf::CODETEMP xx, to_temp => x1, type => ncf::bogus_pointer_type, next =>
ncf::GET_FIELD_I { i => 2, record => ncf::CODETEMP xx, to_temp => x2, type => ncf::bogus_pointer_type, next =>
ncf::DEFINE_RECORD { kind => ncf::rk::RECORD, fields => [(translate_value m, offp0),
(ncf::CODETEMP x2, offp0)], to_temp => z, next =>
ncf::PURE { op => ncf::p::WRAP, args => [ncf::CODETEMP z], to_temp => z', type => ncf::bogus_pointer_type, next =>
ncf::DEFINE_RECORD { kind => ncf::rk::RECORD, fields => [(ncf::CODETEMP x0, offp0),
(ncf::CODETEMP x1, offp0),
(ncf::CODETEMP z', offp0)],
to_temp => y, next =>
ncf::PURE { op => ncf::p::WRAP, args => [ncf::CODETEMP y], to_temp => v, type => ncf::bogus_pointer_type, next =>
loop (e, metafate) } } } } } } } };
};
acf::BASEOP ((_, hbo::RAW_CCALL NULL, _, _), _ ! _ ! a ! _, v, e)
=>
# Code generated here should
# never be executed anyway,
# so we just fake it:
{
# print "*** pro-forma raw-ccall\n";
newname (v, translate_value a);
loop (e, metafate);
};
acf::BASEOP ((_, hbo::RAW_CCALL (THE i), lt, ts), f ! a ! _ ! _, to_temp, e)
=>
{ i -> { c_prototype => p,
ml_argument_representations => lib7_args,
ml_result_representation => ml_res_opt,
is_reentrant=>reentrant
};
fun cty hbo::CCR64 => ncf::typ::FLOAT64;
cty hbo::CCI32 => ncf::typ::INT1;
cty hbo::CCML => ncf::bogus_pointer_type;
cty hbo::CCI64 => ncf::bogus_pointer_type;
end;
a' = translate_value a;
rcckind = if reentrant ncf::REENTRANT_RCC;
else ncf::FAST_RCC;
fi;
fun rcc args
=
{ al = map ncf::CODETEMP args;
my (al, cfun_name)
=
case f
#
acf::STRING cfun_name => (al, cfun_name);
_ => (translate_value f ! al, "");
esac;
case ml_res_opt
#
NULL => ncf::RAW_C_CALL { kind => rcckind, cfun_name, cfun_type => p, args => al, to_ttemps => [(to_temp, ncf::typ::INT)], next => loop (e, metafate) };
#
THE hbo::CCI64
=>
{ v1 = make_codetemp ();
v2 = make_codetemp ();
ncf::RAW_C_CALL
{ kind => rcckind,
cfun_name,
cfun_type => p,
args => al,
to_ttemps => [(v1, ncf::typ::INT1), (v2, ncf::typ::INT1)],
next => record([ncf::CODETEMP v1, ncf::CODETEMP v2],[ncf::typ::INT1, ncf::typ::INT1], to_temp, loop (e, metafate))
};
};
THE rt
=>
{ v' = make_codetemp ();
res_cty = cty rt;
ncf::RAW_C_CALL
{ kind => rcckind,
cfun_name,
cfun_type => p,
args => al,
to_ttemps => [(v', res_cty)],
next => ncf::PURE { op => translate_wrap_op res_cty,
args => [ncf::CODETEMP v'],
to_temp,
type => ncf::bogus_pointer_type,
next => loop (e, metafate )
}
};
};
esac;
};
sel = if (is_float_record a) get_field_from_all_float_record;
else get_field;
fi;
fun build ([], rvl, _)
=>
rcc (reverse rvl);
build (ft ! ftl, rvl, i)
=>
{
t = cty ft;
v = make_codetemp ();
sel (i, a', v, t, build (ftl, v ! rvl, i + 1));
};
end;
case lib7_args
#
[ft] => {
# If there is precisely one arg,
# then it will not come packaged
# into a record:
#
type = cty ft;
to_temp = make_codetemp ();
ncf::PURE { op => translate_unwrap_op type,
args => [a'],
to_temp,
type,
next => rcc [to_temp]
};
};
_ => build (lib7_args, [], 0);
esac;
};
acf::BASEOP ((_, hbo::RAW_CCALL _, _, _), _, _, _)
=>
bug "bad raw_ccall";
acf::BASEOP ((_, hbo::RAW_ALLOCATE_C_RECORD _, _, _),[x as acf::VAR _], v, e)
=>
# Code generated here should
# never be executed anyway,
# so we just fake it:
{
# print "*** pro-forma raw-record\n";
newname (v, translate_value x);
loop (e, metafate);
};
acf::BASEOP (po as (_, p, lt, ts), ul, to_temp, next)
=>
{ type = case (#3 (hcf::unpack_arrow_uniqtypoid (hcf::apply_typeagnostic_type_to_arglist_with_single_result (lt, ts))))
#
[x] => ncf::uniqtypoid_to_nextcode_type x;
_ => bug "unexpected case in acf::BASEOP";
esac;
args = translate_values ul;
case (translate_baseop p)
#
ARITHMETIC_PRIMOP op => ncf::ARITH { op, args, to_temp, type, next => loop (next, metafate) };
FETCH_FROM_RAM op => ncf::FETCH_FROM_RAM { op, args, to_temp, type, next => loop (next, metafate) };
PURE_PRIMOP op => ncf::PURE { op, args, to_temp, type, next => loop (next, metafate) };
#
STORE_TO_RAM op => { newname (to_temp, ncf::INT 0);
#
ncf::STORE_TO_RAM { op, args, next => loop (next, metafate) };
};
esac;
};
acf::BRANCH (po as (_, compare, _, _), ul, then_next, else_next)
=>
{ (prevent_erroneous_eta_reductions metafate) -> (header, fn);
#
fate = make_metafate (\\ args = ncf::TAIL_CALL { fn, args }, get_types_from_metafate metafate);
header (ncf::IF_THEN_ELSE { op => translate_compare compare,
args => translate_values ul,
xvar => make_codetemp(),
#
then_next => loop (then_next, fate),
else_next => loop (else_next, fate)
}
);
};
esac;
};
function_declaration -> (fk, fn_name_codetemp, fn_parameters, body_expression); # Process the top-level Function_Declaration:
return_fate_codetemp = make_codetemp(); # Top-level return fate.
fate = make_metafate
( \\ args = ncf::TAIL_CALL { fn => ncf::CODETEMP return_fate_codetemp, args },
res_ctys fn_name_codetemp
);
body = loop' im::empty (body_expression, fate); # Construct the nextcode-form \\ body from the anormcode-form body. Here's where all the work gets done. :-)
vl = return_fate_codetemp ! (map #1 fn_parameters); # #1 gives us the codetemp naming the parameter.
cl = ncf::typ::FATE ! (map (ncf::uniqtypoid_to_nextcode_type o #2) fn_parameters); # #2 gives us the type for the parameter.
(ncf::PUBLIC_FN, fn_name_codetemp, vl, cl, bogus_header body)
then
clean_up ();
}; # fun translate_anormcode_to_nextcode
}; # generic package translate_anormcode_to_nextcode_g
end; # toplevel stipulate
## COPYRIGHT 1998 BY YALE FLINT PROJECT
## Subsequent changes by Jeff Prothero Copyright (c) 2010-2015,
## released per terms of SMLNJ-COPYRIGHT.