## 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) is the second backend code representation, and the first used for optimization.
# 5) Nextcode 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# Compiled by:
# src/lib/compiler/core.sublib# 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 datatypes."
#
# -- 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.)
# *************************************************************************
# 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_var = fn _ = tmp::issue_highcode_codetemp ();
cplv = tmp::clone_highcode_codetemp;
fun make_fn f
=
{ v = make_var ();
f v;
};
ident = fn le = le;
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 };
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 };
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 => make_fn (fn n = ncf::GET_FIELD_I { i, record, to_temp => n, type => ncf::bogus_pointer_type, next => unwrapf64 (ncf::CODETEMP n, to_temp, next) } );
ncf::typ::INT1 => make_fn (fn n = ncf::GET_FIELD_I { i, record, to_temp => n, type => ncf::bogus_pointer_type, next => unwrapi32 (ncf::CODETEMP n, 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 (fn field = (field, ncf::SLOT 0)) fields,
to_temp,
next
};
fun record (fields, field_types, to_temp, next)
=
{ (g (field_types, fields, [], fn x = x))
->
(fields, header);
header (ncf::DEFINE_RECORD { kind => ncf::rk::RECORD, fields, to_temp, next });
}
where
fun g (ncf::typ::FLOAT64 ! r, u ! z, fields', header')
=>
make_fn (fn v = g ( r,
z,
(ncf::CODETEMP v, ncf::SLOT 0) ! fields',
fn ce = header' (wrapf64 (u, v, ce))
)
);
g (ncf::typ::INT1 ! r, u ! z, fields', header')
=>
make_fn (fn v = g ( r,
z,
(ncf::CODETEMP v, ncf::SLOT 0) ! fields',
fn ce = header' (wrapi32 (u, v, ce))
)
);
g (_ ! r, u ! z, fields', header')
=>
g (r, z, (u, offp0) ! fields', header');
g ([], [], fields', header')
=>
(reverse fields', header');
g _ => bug "unexpected in recordNM in convert";
end;
end;
# *************************************************************************
# UTILITY FUNCTIONS FOR PROCESSING THE BASEOPS *
# *************************************************************************
# numkind: hbo::Int_Bitsize -> ncf::p::numkind
#
fun numkind (hbo::INT bits) => ncf::p::INT bits;
numkind (hbo::UNT bits) => ncf::p::UNT bits;
numkind (hbo::FLOAT bits) => ncf::p::FLOAT bits;
end;
# Cmpop: hbo::stuff -> ncf::p::branch
#
fun cmpop stuff
=
case stuff
#
{ op=>hbo::EQL, kindbits=>hbo::INT 31 }
=>
ncf::p::ieql;
{ op=>hbo::NEQ, kindbits=>hbo::INT 31 }
=>
ncf::p::ineq;
{ op, kindbits=>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 "cmpop: kindbits=hbo::FLOAT";
end;
ncf::p::COMPARE_FLOATS { op=> c op, size };
};
{ op, kindbits }
=>
ncf::p::COMPARE { op => c op, kindbits => numkind kindbits }
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", kindbits); ncf::p::LE ;};
c hbo::LTU => { check ("ltu", kindbits); ncf::p::LT ;};
c hbo::GEU => { check ("geu", kindbits); ncf::p::GE ;};
c hbo::GTU => { check ("gtu", kindbits); ncf::p::GT ;};
c hbo::EQL => ncf::p::EQL;
c hbo::NEQ => ncf::p::NEQ;
end;
end;
esac;
# map_branch: hbo::baseop -> ncf::p::branch
#
fun map_branch p
=
case p
#
hbo::IS_BOXED => ncf::p::IS_BOXED;
hbo::IS_UNBOXED => ncf::p::IS_UNBOXED;
#
hbo::CMP stuff => cmpop stuff;
#
hbo::POINTER_EQL => ncf::p::POINTER_EQL;
hbo::POINTER_NEQ => ncf::p::POINTER_NEQ;
#
_ => bug "unexpected primops in map_branch";
esac;
# primwrap: cty -> ncf::p::pure
#
fun primwrap ncf::typ::INT => ncf::p::IWRAP;
primwrap ncf::typ::INT1 => ncf::p::WRAP_INT1;
primwrap ncf::typ::FLOAT64 => ncf::p::WRAP_FLOAT64;
primwrap _ => ncf::p::WRAP;
end;
# primunwrap: cty -> ncf::p::pure
#
fun primunwrap ncf::typ::INT => ncf::p::IUNWRAP;
primunwrap ncf::typ::INT1 => ncf::p::UNWRAP_INT1;
primunwrap ncf::typ::FLOAT64 => ncf::p::UNWRAP_FLOAT64;
primunwrap _ => ncf::p::UNWRAP;
end;
# Arithop: hbo::arithop -> ncf::p::arithop
#
fun arithop hbo::NEGATE => ncf::p::NEGATE;
arithop hbo::ABS => ncf::p::ABS;
arithop hbo::FSQRT => ncf::p::FSQRT;
#
arithop hbo::FSIN => ncf::p::FSIN;
arithop hbo::FCOS => ncf::p::FCOS;
arithop hbo::FTAN => ncf::p::FTAN;
#
arithop hbo::DIVIDE => ncf::p::DIVIDE; # Round-to-zero division -- this is the native instruction on Intel32.
arithop hbo::DIV => ncf::p::DIV; # Round-to-negative-infinity division -- this will be much slower on Intel32, has to be faked.
#
arithop hbo::REM => ncf::p::REM; # Round-to-zero remainder -- this is the native instruction on Intel32.
arithop hbo::MOD => ncf::p::MOD; # Round-to-negative-infinity remainder -- this will be much slower on Intel32, has to be faked.
#
arithop hbo::ADD => ncf::p::ADD;
arithop hbo::SUBTRACT => ncf::p::SUBTRACT;
arithop hbo::MULTIPLY => ncf::p::MULTIPLY;
#
arithop hbo::LSHIFT => ncf::p::LSHIFT;
arithop hbo::RSHIFT => ncf::p::RSHIFT;
arithop hbo::RSHIFTL => ncf::p::RSHIFTL;
#
arithop hbo::BITWISE_NOT => ncf::p::BITWISE_NOT;
arithop hbo::BITWISE_AND => ncf::p::BITWISE_AND;
arithop hbo::BITWISE_OR => ncf::p::BITWISE_OR;
arithop hbo::BITWISE_XOR => ncf::p::BITWISE_XOR;
end;
# A temporary classifier of various kinds of nextcode primops # XXX BUGGO FIXME
#
Primop_Kind
= 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
;
# map_primop: hbo::baseop -> pkind
#
fun map_primop p
=
case p
#
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::MATH { op, kindbits, overflow=>TRUE }
=>
ARITHMETIC_PRIMOP (ncf::p::MATH { op=>arithop op, kindbits=>numkind kindbits } );
hbo::MATH { op, kindbits, overflow=>FALSE }
=>
PURE_PRIMOP (ncf::p::PURE_ARITH { op=>arithop op, kindbits=>numkind kindbits } );
hbo::ROUND { floor, from, to }
=>
ARITHMETIC_PRIMOP (ncf::p::ROUND { floor, from=>numkind from,
to=>numkind to } );
hbo::CONVERT_FLOAT { from, to }
=>
PURE_PRIMOP (ncf::p::CONVERT_FLOAT { to=>numkind to, from=>numkind from } );
hbo::GET_RO_VECSLOT_CONTENTS => PURE_PRIMOP (ncf::p::GET_RO_VECSLOT_CONTENTS);
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::GET_RECSLOT_CONTENTS => PURE_PRIMOP (ncf::p::GET_RECSLOT_CONTENTS);
hbo::GET_RAW64SLOT_CONTENTS => PURE_PRIMOP (ncf::p::GET_RAW64SLOT_CONTENTS);
hbo::GET_RW_VECSLOT_CONTENTS => FETCH_FROM_RAM (ncf::p::GET_VECSLOT_CONTENTS);
hbo::GET_VECSLOT_NUMERIC_CONTENTS { kindbits, immutable=>FALSE, checked=>FALSE } =>
FETCH_FROM_RAM (ncf::p::GET_VECSLOT_NUMERIC_CONTENTS { kindbits=>numkind kindbits } );
hbo::GET_VECSLOT_NUMERIC_CONTENTS { kindbits, immutable=>TRUE, checked=>FALSE } =>
PURE_PRIMOP (ncf::p::PURE_GET_VECSLOT_NUMERIC_CONTENTS { kindbits=>numkind kindbits } );
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_THREAD_REGISTER => FETCH_FROM_RAM (ncf::p::GET_CURRENT_THREAD_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 { kindbits, checked=>FALSE } => STORE_TO_RAM (ncf::p::SET_VECSLOT_TO_NUMERIC_VALUE { kindbits=>numkind kindbits } );
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::SET_VECSLOT => STORE_TO_RAM ncf::p::SET_VECSLOT;
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_THREAD_REGISTER => STORE_TO_RAM (ncf::p::SET_CURRENT_THREAD_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 { kindbits => numkind nk } );
hbo::SET_NONHEAP_RAM nk => STORE_TO_RAM (ncf::p::SET_NONHEAP_RAM { kindbits => numkind 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 map_primop: " + (hbo::baseop_to_string p) + "\n");
esac;
# *************************************************************************
# SWITCH OPTIMIZATIONS AND COMPILATIONS *
# *************************************************************************
# BUG: The definition of E_word is clearly incorrect since it can raise exception
# an overflow at code generation time. A clean solution would be
# to add a WORD ("UNT" -- CrT) 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 => fn i = if (i < -0x20000000 or i >= 0x20000000) raise exception isf::TOO_BIG;
else ncf::INT i;
fi,
e_unt => fn w = # if w >= 0wx20000000
# then raise exception Switch::TOO_BIG else
ncf::INT (unt::to_int_x w),
e_real => (fn s = ncf::FLOAT64 s),
e_switchlimit => 4,
e_neq => ncf::p::ineq,
e_w32neq => ncf::p::COMPARE { op=>ncf::p::NEQ, kindbits=>ncf::p::UNT 32 },
e_i32neq => ncf::p::COMPARE { op=>ncf::p::NEQ, kindbits=>ncf::p::INT 32 },
e_unt1 => ncf::INT1,
e_int1 => ncf::INT1,
e_wneq => ncf::p::COMPARE { op=>ncf::p::NEQ, kindbits=>ncf::p::UNT 31 },
e_pneq => ncf::p::POINTER_NEQ,
e_fneq => ncf::p::fneq,
e_less => ncf::p::ilt,
e_branch => (fn (op, x, y, then_next, else_next) = ncf::IF_THEN_ELSE { op, args => [x, y], xvar => make_var(), then_next, else_next }),
e_strneq => (fn (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_var(), then_next, else_next }),
e_switch => (fn (i, nexts) = ncf::JUMPTABLE { i, xvar => make_var(), nexts }),
e_add => (fn (x, y, c) = make_fn (fn to_temp = ncf::MATH { op => ncf::p::iadd,
args => [x, y],
to_temp,
type => ncf::typ::INT,
next => c (ncf::CODETEMP to_temp)
}
) ),
e_gettag => (fn (arg, c) = make_fn (fn to_temp = ncf::PURE { op => ncf::p::GETCON, args =>[arg], to_temp, type => ncf::typ::INT, next => c (ncf::CODETEMP to_temp ) } )),
e_unwrap => (fn (arg, c) = make_fn (fn to_temp = ncf::PURE { op => ncf::p::UNWRAP, args =>[arg], to_temp, type => ncf::typ::INT, next => c (ncf::CODETEMP to_temp ) } )),
e_getexn => (fn (arg, c) = make_fn (fn 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 => (fn (arg, c) = make_fn (fn 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 => (fn (x, then_next, else_next) = ncf::IF_THEN_ELSE { op => ncf::p::IS_BOXED, args => [x], xvar => make_var(), then_next, else_next } ),
e_path => fn (da::HIGHCODE_VARIABLE v, k) => k (rename v);
_ => bug "unexpected path in convpath";
end
};
###########################################################################
# UTILITY FUNCTIONS FOR DEALING WITH META-LEVEL FATES #
###########################################################################
Meta_Fate # An abstract representation of the meta-level fate.
=
META_FATE { count: List (ncf::Value) -> ncf::Instruction,
ts: List( ncf::Type )
};
fun appmc (META_FATE { count, ... }, vs) # Appmc: mcont * List (value) -> cexp
=
count vs;
fun make_meta_fate (count, ts) # make_meta_fate: (List (value) -> cexp) * List (cty) -> cexp
=
META_FATE { count, ts };
fun rttys (META_FATE { ts, ... } ) # rttys: mcont -> List (cty)
=
ts;
###########################################################################
# THE MAIN FUNCTION
# Converts acf::Function -> nextcode::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 fdec
=
{ (rat::recover_anormcode_type_info (fdec, TRUE))
->
{ get_lty, clean_up, ... };
ctypes = map ncf::ctype;
fun res_ctys f
=
{ lt = get_lty (acf::VAR f);
if (hcf::uniqtype_is_generic_package lt) ctypes (#2 (hcf::unpack_generic_package_uniqtype lt));
elif (hcf::uniqtype_is_arrow_type lt) ctypes (#3 (hcf::unpack_arrow_uniqtype lt));
else [ ncf::bogus_pointer_type ];
fi;
};
fun get_cty v
=
ncf::ctype (get_lty v);
fun is_float_record u
=
hcf::if_uniqtype_is_typ
(
get_lty u,
fn tc = hcf::if_uniqtyp_is_tuple (
tc,
fn l = all_float (map ncf::ctyc l),
fn _ = FALSE
),
fn _ = FALSE
);
bogus_cont = make_var();
fun bogus_header next
=
{ bogus_knownf = make_var();
ncf::DEFINE_FUNS
{
funs =>
[ ( ncf::PRIVATE_FN,
bogus_knownf,
[ make_var () ],
[ ncf::bogus_pointer_type ],
ncf::TAIL_CALL { func => ncf::CODETEMP bogus_knownf,
args => [ ncf::STRING "bogus" ]
}
)
],
next =>
ncf::DEFINE_FUNS
{
funs =>
[ ( ncf::NEXT_FN,
bogus_cont,
[ make_var () ],
[ ncf::bogus_pointer_type ],
#
ncf::TAIL_CALL { func => ncf::CODETEMP bogus_knownf,
args => [ncf::STRING "bogus"]
}
)
],
next
}
};
};
# with
exception RENAME;
my m: iht::Hashtable( ncf::Value )
= iht::make_hashtable { size_hint => 32, not_found_exception => RENAME };
# do
# acf::Variable -> nextcode::value
#
fun rename v
=
iht::get m v
except
RENAME = ncf::CODETEMP v;
# (acf::Variable, nextcode::Value) -> Void
#
fun newname (v, w)
=
{ case w
#
ncf::CODETEMP w' => tmp::share_name (v, w');
_ => ();
esac;
iht::set m (v, w);
};
# ( List( acf::Variable ),
# List( nextcode::Value )
# )
# -> Void
#
fun newnames (v ! vs, w ! ws)
=>
{ newname (v, w);
newnames (vs, ws);
};
newnames ([], [])
=>
();
newnames _
=>
bug "unexpected case in newnames";
end;
# is_eta: cexp * List (value) -> Null_Or( value )
#
fun is_eta
( ncf::TAIL_CALL { func => w as ncf::CODETEMP lv,
args => vl
},
ul
)
=>
# If the function is in the global renaming table and it's
# renamed to itself, then it's most likely a while loop and
# should *not* be eta-reduced
if ( case (iht::get m 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;
is_eta _ => NULL;
end;
# end # local of Rename
fun prevent_eta (META_FATE { count=>c, ts } ) # prevent_eta: mcont -> (cexp -> cexp) * value
=
{ vl = map make_var ts;
ul = map ncf::CODETEMP vl;
b = c ul;
case (is_eta (b, ul) )
#
THE w => (ident, w);
NULL
=>
{ f = make_var();
( fn next = ncf::DEFINE_FUNS { funs => [(ncf::NEXT_FN, f, vl, ts, b)], next },
ncf::CODETEMP f
);
};
esac;
};
do_switch # Switch optimization
=
do_switch_fn rename;
# lpvar: acf::value -> value
fun lpvar (acf::VAR v) => rename v;
lpvar (acf::UNT1 w) => ncf::INT1 w;
lpvar (acf::INT i) => ncf::INT i;
lpvar (acf::UNT w) => ncf::INT (unt::to_int_x w);
lpvar (acf::FLOAT64 r) => ncf::FLOAT64 r;
lpvar (acf::STRING s) => ncf::STRING s;
lpvar (acf::INT1 i)
=>
{ int1to_unt1
=
one_word_unt::from_multiword_int o one_word_int::to_multiword_int;
ncf::INT1 (int1to_unt1 i);
};
end;
# lpvars: List( acf::value ) -> List( value )
#
fun lpvars vl
=
h (vl, [])
where
fun h ( [], z) => reverse z;
h (a ! r, z) => h (r, (lpvar a) ! z);
end;
end;
# loop: acf::Lambda_Expression * (List( value ) -> cexp) -> cexp
#
fun loop' m (le, c)
=
{ loop = loop' m;
case le
#
acf::RET vs => appmc (c, lpvars vs);
#
acf::LET (vs, e1, e2)
=>
loop (e1, kont)
where
kont = make_meta_fate
( fn ws = { newnames (vs, ws); loop (e2, c);},
map (get_cty o acf::VAR) vs
);
end;
acf::MUTUALLY_RECURSIVE_FNS (fds, e)
=>
{
# lpfd: acf::Function -> function
#
fun lpfd ((fk, f, vts, e): acf::Function)
=
{ k = make_var();
cl = ncf::typ::FATE ! (map (ncf::ctype o #2) vts);
kont = make_meta_fate (fn args = ncf::TAIL_CALL { func => 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' = cplv f;
# Here we add a dumb entry for f' in the
# global renaming table just so that is_eta
# can avoid eta-reducing it:
newname (f', ncf::CODETEMP f');
vl = k ! (map (cplv o #1) vts);
vl' = map #1 vts;
cl' = map (ncf::ctype o #2) vts;
( vl,
ncf::DEFINE_FUNS
{
funs =>
[ ( ncf::PRIVATE_TAIL_RECURSIVE_FN,
f',
vl',
cl',
loop' (im::set (m, f, f')) (e, kont) # Add the function to the tail map
)
],
next =>
ncf::TAIL_CALL { func => ncf::CODETEMP f',
args => map ncf::CODETEMP (tail vl)
}
}
);
};
_ => (k ! (map #1 vts), loop (e, kont));
esac;
(ncf::PUBLIC_FN, f, vl, cl, body);
};
ncf::DEFINE_FUNS { funs => map lpfd fds,
next => loop (e, c)
};
};
acf::APPLY (f as acf::VAR lv, vs)
=>
# First check if it's a recursive call to a tail loop:
#
case (im::get (m, lv))
#
THE f'
=>
ncf::TAIL_CALL { func => ncf::CODETEMP f',
args => lpvars vs
};
NULL
=>
# Code for the non-tail case.
# Sadly this is *not* exceptional
{ my (header, fff) = prevent_eta c;
func = lpvar f;
ul = lpvars vs;
header (ncf::TAIL_CALL { func, args => fff ! ul });
};
esac;
acf::APPLY _
=>
bug "unexpected ncf::TAIL_CALL in convert";
(acf::TYPEFUN _ | acf::APPLY_TYPEFUN _)
=>
bug "unexpected TYPEFUN and APPLY_TYPEFUN in convert";
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, c);
};
acf::RECORD (rk, vl, to_temp, e)
=>
{ ts = map get_cty vl;
nvl = lpvars vl;
next = loop (e, c);
case rk
#
acf::RK_TUPLE _
=>
all_float ts
?? all_float_record (nvl, ts, to_temp, next)
:: record (nvl, ts, to_temp, next);
acf::RK_VECTOR _
=>
ncf::DEFINE_RECORD { kind => ncf::rk::VECTOR, fields => map (fn x = (x, offp0)) nvl, to_temp, next };
_ =>
record (nvl, ts, to_temp, next);
esac;
};
acf::GET_FIELD (u, i, v, e)
=>
{ ct = get_cty (acf::VAR v);
nu = lpvar u;
ce = loop (e, c);
if (is_float_record u) get_field_from_all_float_record (i, nu, v, ct, ce);
else get_field (i, nu, v, ct, ce);
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), c);
acf::SWITCH (u, an_api, l, d)
=>
{ (prevent_eta c) -> (header, func);
kont = make_meta_fate (fn args = ncf::TAIL_CALL { func, args }, rttys c);
next =
{ df = make_var();
fun proc (cn as (acf::VAL_CASETAG (dc, _, v)), e)
=>
(cn, loop (acf::LET([v], acf::RET [u], e), kont));
proc (cn, e)
=>
(cn, loop (e, kont));
end;
next = do_switch { an_api,
expression => lpvar u,
cases => map proc l,
default => ncf::TAIL_CALL { func => ncf::CODETEMP df,
args => [ ncf::INT 0 ]
}
};
case d
#
NULL => next;
THE de => ncf::DEFINE_FUNS { next,
funs => [ ( ncf::NEXT_FN,
df,
[make_var()],
[ncf::typ::INT],
loop (de, kont)
)
]
};
esac;
};
header next;
};
acf::CONSTRUCTOR (dc, ts, u, v, e)
=>
bug "unexpected case CONSTRUCTOR during anormcode-to-nextcode conversion";
acf::RAISE (u, lts)
=>
{ # Execute the fate
# for side effects:
#
appmc (c, (map (fn _ = ncf::CODETEMP (make_var())) lts));
h = make_var();
ncf::FETCH_FROM_RAM
{
op => ncf::p::GET_EXCEPTION_HANDLER_REGISTER,
args => [],
to_temp => h,
type => ncf::typ::FUN,
next => ncf::TAIL_CALL { func => ncf::CODETEMP h,
args => [ ncf::CODETEMP bogus_cont, lpvar u ]
}
};
};
acf::EXCEPT (e, u) # recover type from u
=>
{ (prevent_eta c) -> (header, func);
h = make_var();
kont = make_meta_fate
( fn args = ncf::STORE_TO_RAM { op => ncf::p::SET_EXCEPTION_HANDLER_REGISTER,
args => [ncf::CODETEMP h],
next => ncf::TAIL_CALL { func, args }
},
rttys c
);
body = { k = make_var();
v = make_var();
ncf::DEFINE_FUNS
{
funs =>
[ ( ncf::PUBLIC_FN,
k,
[ make_var(), v ],
[ ncf::typ::FATE, ncf::bogus_pointer_type ],
ncf::STORE_TO_RAM
{ op => ncf::p::SET_EXCEPTION_HANDLER_REGISTER,
args => [ ncf::CODETEMP h ],
next => ncf::TAIL_CALL { func => lpvar u,
args => [ func, ncf::CODETEMP v]
}
}
)
],
next =>
ncf::STORE_TO_RAM
{ op => ncf::p::SET_EXCEPTION_HANDLER_REGISTER,
args => [ ncf::CODETEMP k ],
next => loop (e, kont)
}
};
};
ncf::FETCH_FROM_RAM
{ op => ncf::p::GET_EXCEPTION_HANDLER_REGISTER,
args => [],
to_temp => h,
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, func)
=
{ k = make_var();
ct = get_cty f;
( [ (ncf::NEXT_FN, k, [v], [ct], loop (e, c)) ],
ncf::CODETEMP k
);
};
my (hdr1, hdr2)
=
case p
#
hbo::CALLCC
=>
make_fn (fn h = ( fn next = ncf::STORE_TO_RAM { op => ncf::p::SET_EXCEPTION_HANDLER_REGISTER,
args => [ncf::CODETEMP h],
next
},
fn next = ncf::FETCH_FROM_RAM { op => ncf::p::GET_EXCEPTION_HANDLER_REGISTER,
args => [],
to_temp => h,
type => ncf::bogus_pointer_type,
next
}
)
);
_ => (ident, ident);
esac;
my (ccont_decs, ccont_var)
=
{ k = make_var(); # Captured fate.
x = make_var();
( [ ( ncf::PUBLIC_FN,
k,
[ make_var(), x ],
[ ncf::typ::FATE, ncf::bogus_pointer_type ],
hdr1 (ncf::TAIL_CALL { func, args => [ncf::CODETEMP x] })
)
],
k
);
};
ncf::DEFINE_FUNS
{
funs => kont_decs,
#
next =>
hdr2 (ncf::DEFINE_FUNS
{
funs => ccont_decs,
#
next =>
ncf::TAIL_CALL { func => lpvar f,
args => [func, ncf::CODETEMP ccont_var]
}
}
)
};
};
acf::BASEOP ((_, hbo::MAKE_ISOLATED_FATE, lt, ts), [f], v, e)
=>
{ my (exndecs, exnvar)
=
{ h = make_var ();
z = make_var ();
x = make_var ();
( [ ( ncf::PUBLIC_FN,
h,
[z, x],
[ncf::typ::FATE, ncf::bogus_pointer_type],
ncf::TAIL_CALL { func => ncf::CODETEMP bogus_cont,
args => [ncf::CODETEMP x]
}
)
],
h
);
};
newfdecs
=
{ nf = v;
z = make_var ();
x = make_var ();
[ ( 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 { func => lpvar f,
args => [ncf::CODETEMP bogus_cont, ncf::CODETEMP x]
}
}
)
];
};
ncf::DEFINE_FUNS { funs => exndecs,
#
next => ncf::DEFINE_FUNS { funs => newfdecs,
next => loop (e, c)
}
};
};
acf::BASEOP (po as (_, hbo::THROW, _, _), [u], v, e)
=>
{ newname (v, lpvar u);
loop (e, c);
};
acf::BASEOP (po as (_, hbo::WCAST, _, _), [u], v, e)
=>
{ newname (v, lpvar u);
loop (e, c);
};
acf::BASEOP (po as (_, hbo::WRAP, _, _), [u], to_temp, next)
=>
{ ct = ncf::ctyc (acj::get_wrap_typ po);
#
ncf::PURE { op => primwrap ct,
args => [lpvar u],
to_temp,
type => ncf::bogus_pointer_type,
next => loop (next, c)
};
};
acf::BASEOP (po as (_, hbo::UNWRAP, _, _), [u], to_temp, next)
=>
{ type = ncf::ctyc (acj::get_un_wrap_typ po);
#
ncf::PURE { op => primunwrap type,
args => [lpvar u],
to_temp,
type,
next => loop (next, c )
};
};
acf::BASEOP (po as (_, hbo::MARK_EXCEPTION_WITH_STRING, _, _), [x, m], v, e)
=>
{ bty = hcf::truevoid_uniqtype;
ety = hcf::make_tuple_uniqtype [bty, bty, bty];
my (xx, x0, x1, x2)
=
(make_var(), make_var(), make_var(), make_var());
my (y, z, z')
=
( make_var (),
make_var (),
make_var ()
);
ncf::PURE { op => ncf::p::UNWRAP, args => [lpvar x], to_temp => xx, type => ncf::ctype (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 => [(lpvar 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, c) } } } } } } } };
};
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, lpvar a); loop (e, c);
};
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' = lpvar 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);
_ => (lpvar 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, c) };
#
THE hbo::CCI64
=>
{ v1 = make_var ();
v2 = make_var ();
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, c))
};
};
THE rt
=>
{ v' = make_var ();
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 => primwrap res_cty,
args => [ncf::CODETEMP v'],
to_temp,
type => ncf::bogus_pointer_type,
next => loop (e, c )
}
};
};
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_var ();
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_var ();
ncf::PURE { op => primunwrap 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, lpvar x); loop (e, c);
};
acf::BASEOP (po as (_, p, lt, ts), ul, to_temp, next)
=>
{ type = case (#3 (hcf::unpack_arrow_uniqtype (hcf::apply_typeagnostic_type_to_arglist_with_single_result (lt, ts))))
#
[x] => ncf::ctype x;
_ => bug "unexpected case in acf::BASEOP";
esac;
args = lpvars ul;
case (map_primop p)
#
ARITHMETIC_PRIMOP op => ncf::MATH { op, args, to_temp, type, next => loop (next, c) };
FETCH_FROM_RAM op => ncf::FETCH_FROM_RAM { op, args, to_temp, type, next => loop (next, c) };
PURE_PRIMOP op => ncf::PURE { op, args, to_temp, type, next => loop (next, c) };
#
STORE_TO_RAM op => { newname (to_temp, ncf::INT 0);
#
ncf::STORE_TO_RAM { op, args, next => loop (next, c) };
};
esac;
};
acf::BRANCH (po as (_, p, _, _), ul, then_next, else_next)
=>
{ (prevent_eta c) -> (header, func);
kont = make_meta_fate (fn args = ncf::TAIL_CALL { func, args }, rttys c);
header (ncf::IF_THEN_ELSE { op => map_branch p, args => lpvars ul, xvar => make_var(), then_next => loop (then_next, kont),
else_next => loop (else_next, kont)
}
);
};
esac;
};
# Process the top-level Function_Declaration:
fdec -> (fk, f, vts, be);
k = make_var(); # Top-level return fate.
kont = make_meta_fate (fn args = ncf::TAIL_CALL { func => ncf::CODETEMP k, args }, res_ctys f);
body = loop' im::empty (be, kont);
vl = k ! (map #1 vts);
cl = ncf::typ::FATE ! (map (ncf::ctype o #2) vts);
(ncf::PUBLIC_FN, f, vl, cl, bogus_header body)
before
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-2013,
## released per terms of SMLNJ-COPYRIGHT.