## nextcode-preimprover-transform-g.pkg
# Compiled by:
# src/lib/compiler/core.sublib# In this file we handle the initial nextcode
# transforms performed immediately after
# conversion from A-Normal to nextcode form,
# as set-up our core nextcode optimizations.
#
# I'm not sure specifically what is supposed to
# be happening here. It seems to involve some
# type munging.
#
# We get invoked from the
#
# src/lib/compiler/back/top/main/backend-tophalf-g.pkg#
# function
#
# translate_anormcode_to_execode()
#
# which uses us in the transform sequence
#
# translate_anormcode_to_nextcode()
# nextcode_preimprover_transform()
# optional_nextcode_improvers()
# For context, see the comments in
#
# src/lib/compiler/back/top/highcode/highcode-form.api# Our runtime invocation is from
#
# src/lib/compiler/back/top/main/backend-tophalf-g.pkgstipulate
package ncf = nextcode_form; # nextcode_form is from src/lib/compiler/back/top/nextcode/nextcode-form.pkgherein
api Nextcode_Preimprover_Transform {
#
nextcode_preimprover_transform: ncf::Function -> ncf::Function;
};
end;
# We are invoked from:
#
# src/lib/compiler/back/top/main/backend-tophalf-g.pkg # Machine_Properties is from src/lib/compiler/back/low/main/main/machine-properties.apistipulate
package err = error_message; # error_message is from src/lib/compiler/front/basics/errormsg/error-message.pkg package iht = int_hashtable; # int_hashtable is from src/lib/src/int-hashtable.pkg package l2 = paired_lists; # paired_lists is from src/lib/std/src/paired-lists.pkg package ncf = nextcode_form; # nextcode_form is from src/lib/compiler/back/top/nextcode/nextcode-form.pkg package tmp = highcode_codetemp; # highcode_codetemp is from src/lib/compiler/back/top/highcode/highcode-codetemp.pkgherein
generic package nextcode_preimprover_transform_g (
# ================================
#
mp: Machine_Properties # Machine_Properties is from src/lib/compiler/back/low/main/main/machine-properties.api # 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 #
)
: (weak) Nextcode_Preimprover_Transform
{
fun bug s = err::impossible ("Nextcode_Preimprover_Transform: " + s);
fun ident x = x;
issue_codetemp = tmp::issue_highcode_codetemp;
###########################################################################
# TOP OF THE MAIN FUNCTION #
###########################################################################
# We get invoked from the
#
# src/lib/compiler/back/top/main/backend-tophalf-g.pkg #
# function
#
# translate_anormcode_to_execode()
#
# which uses us in the transform sequence
#
# translate_anormcode_to_nextcode()
# nextcode_preimprover_transform()
# optional_nextcode_improvers()
#
fun nextcode_preimprover_transform fe
=
functrans fe
where
unboxedfloat = mp::unboxed_floats;
untaggedint = mp::untagged_int;
exception NEXTCODE_SUBSTITUTION;
stipulate
my mmm: iht::Hashtable( ncf::Value ) = iht::make_hashtable { size_hint => 32, not_found_exception => NEXTCODE_SUBSTITUTION };
herein
addvl = iht::set mmm;
fun mapvl v = ((iht::get mmm v) except NEXTCODE_SUBSTITUTION = ncf::CODETEMP v);
end;
exception CTYMAP;
stipulate
my ct: iht::Hashtable( ncf::Type )
= iht::make_hashtable { size_hint => 32, not_found_exception => CTYMAP };
herein
addty = iht::set ct;
getty = iht::get ct;
end;
fun grabty (ncf::CODETEMP v) => ((getty v) except _ = ncf::bogus_pointer_type);
grabty (ncf::FLOAT64 _) => ncf::typ::FLOAT64;
grabty (ncf::INT _) => ncf::typ::INT;
grabty (ncf::INT1 _) => ncf::typ::INT1;
grabty _ => ncf::bogus_pointer_type;
end;
fun select (i, record, to_temp, type, next)
=
ncf::GET_FIELD_I { i, record, to_temp, type, next };
fun record (kind, fields, to_temp, next)
=
ncf::DEFINE_RECORD { kind, fields, to_temp, next };
# Wrappers around floats and ints are now dealt with in the convert phase
# fun unwrapfloat (arg, to_temp, next) = ncf::PURE { op => ncf::p::funwrap, args => [arg], to_temp, type => ncf::typ::FLOAT64, next }
# fun wrapfloat (arg, to_temp, next) = ncf::PURE { op => ncf::p::fwrap, args => [arg], to_temp, type => ncf::bogus_pointer_type, next }
# fun unwrapint (arg, to_temp, next) = ncf::PURE { op => ncf::p::iunwrap, args => [arg], to_temp, type => ncf::typ::INT, next }
# fun wrapint (arg, to_temp, next) = ncf::PURE { op => ncf::p::iwrap, args => [arg], to_temp, type => ncf::bogus_pointer_type, next }
# fun unwrapint1 (arg, to_temp, next) = ncf::PURE { op => ncf::p::i32unwrap, args => [arg], to_temp, type => ncf::typ::INT1, next }
# fun wrapint1 (arg, to_temp, next) = ncf::PURE { op => ncf::p::i32wrap, args => [arg], to_temp, type => ncf::bogus_pointer_type, next }
#
# fun select (i, u, x, ct, ce) =
# case (ct, unboxedfloat, untaggedint)
# of (ncf::typ::FLOAT64, TRUE, _) => let v = issue_codetemp()
# in ncf::GET_FIELD_I { i, record => u, to_temp => v, type => ncf::bogus_pointer_type, next => unwrapfloat (ncf::CODETEMP v, x, ce) }
# end
# | (ncf::typ::INT, _, TRUE) => let v = issue_codetemp()
# in ncf::GET_FIELD_I { i, record => u, to_temp => v, type => ncf::bogus_pointer_type, next => unwrapint (ncf::CODETEMP v, x, ce) }
# end
# | (ncf::typ::INT1, _, _) => let v = issue_codetemp()
# in ncf::GET_FIELD_I { i, record => u, to_temp => v, type => ncf::bogus_pointer_type, next => unwrapint1 (ncf::CODETEMP v, x, ce) }
# end
# | _ => ncf::GET_FIELD_I { i, record => u, to_temp => x, type => ct, next => ce }
#
# fun record (k, ul, w, ce) =
# let fun h ((ncf::typ::FLOAT64, u), (l, h)) =
# if unboxedfloat then
# (let v = issue_codetemp()
# in ((ncf::CODETEMP v, OFFp 0) ! l, \\ ce => wrapfloat(#1 u, v, h (ce)))
# end)
# else (u ! l, h)
# | h((ncf::typ::INT, u), (l, h)) =
# if untaggedint then
# (let v = issue_codetemp()
# in ((ncf::CODETEMP v, OFFp 0) ! l, \\ ce => wrapint(#1 u, v, h (ce)))
# end)
# else (u ! l, h)
# | h((ncf::typ::INT1, u), (l, h)) =
# let v = issue_codetemp()
# in ((ncf::CODETEMP v, OFFp 0) ! l, \\ ce => wrapint1(#1 u, v, h (ce)))
# end
# | h((_, u), (l, h)) = (u ! l, h)
#
# info = map (\\ (u as (v, _)) => (grabty v, u)) ul
# my (nul, header) = fold h info ([], ident)
# in header (ncf::DEFINE_RECORD { kind => k, field => nul, to_temp => w, next => ce })
# end
# ************************************************************************
# UTILITY FUNCTIONS THAT DO THE ARGUMENT SPILLING *
# ************************************************************************
stipulate
# arg_spill(), spill_in() and spill_out()
# are private support functions for
# make_arg_in and make_arg_out:
# The following figures must be consistent with the choices made
# in the closure or spilling phases:
stipulate
#
fpnum = int::min (mp::num_float_regs - 2, mp::num_arg_regs);
nregs = mp::num_int_regs - mp::num_callee_saves;
gpnum = int::min (nregs - 3, mp::num_arg_regs);
#
herein
fun arg_spill (args, ctys)
=
{ fun h ([], [], ngp, nfp, ovs, ots, [], [], []) => NULL;
h([], [], ngp, nfp, ovs, ots, [x], [_], []) => NULL;
h([], [], ngp, nfp, ovs, ots, gvs, gts, fvs)
=>
THE (reverse ovs, reverse ots, reverse gvs, reverse gts, reverse fvs);
h (x ! xs, ct ! cts, ngp, nfp, ovs, ots, gvs, gts, fvs)
=>
case ct
#
ncf::typ::FLOAT64 => if (nfp > 0) h (xs, cts, ngp, nfp - 1, x ! ovs, ct ! ots, gvs, gts, fvs);
else h (xs, cts, ngp, nfp, ovs, ots, gvs, gts, x ! fvs);
fi;
_ => if (ngp > 0) h (xs, cts, ngp - 1, nfp, x ! ovs, ct ! ots, gvs, gts, fvs);
else h (xs, cts, ngp, nfp, ovs, ots, x ! gvs, ct ! gts, fvs);
fi;
esac;
h _ =>
bug "unexpected case in arg_spill";
end;
n = length args;
if (n > fpnum
or n > gpnum)
h (args, ctys, gpnum, fpnum, [], [], [], [], []);
else NULL;
fi;
}; # fun arg_spill
end; # stipulate
# 'spgvars' may be 'spilled general-purpose variables'.
fun spill_in (origargs, origctys, spgvars, spgctys, spfvars) # 'spfvars' may be 'spilled float variables'.
=
{ my (fhdr, spgvars, spgctys)
=
case spfvars
#
[] => (ident, spgvars, spgctys);
_ => { to_temp = issue_codetemp();
fields = map (\\ x = (x, ncf::SLOT 0)) spfvars;
ct = ncf::typ::POINTER (ncf::FPT (length fields));
fh = \\ next = ncf::DEFINE_RECORD { kind => ncf::rk::FLOAT64_BLOCK, fields, to_temp, next };
(fh, (ncf::CODETEMP to_temp) ! spgvars, ct ! spgctys);
};
esac;
my (spgv, ghdr)
=
case spgvars
#
[] => (NULL, fhdr);
[x] => (THE x, fhdr);
_ => { to_temp = issue_codetemp();
fields = map (\\ x = (x, ncf::SLOT 0)) spgvars;
( THE (ncf::CODETEMP to_temp),
\\ next = fhdr (ncf::DEFINE_RECORD { kind => ncf::rk::RECORD, fields, to_temp, next })
);
};
esac;
case spgv
THE x => THE (origargs @ [x], ghdr);
NULL => NULL;
esac;
};
fun spill_out (origargs, origctys, spgvars, spgctys, spfvars)
=
{ my (spfv, fhdr, spgvars, spgctys)
=
case spfvars
#
[] => (NULL, ident, spgvars, spgctys);
_ => { v = issue_codetemp ();
record = ncf::CODETEMP v;
fun g (to_temp, (i, header))
=
(i+1, \\ next = header (ncf::GET_FIELD_I { i, record, to_temp, type => ncf::typ::FLOAT64, next }));
my (n, fh) = fold_forward g (0, ident) spfvars;
ct = ncf::typ::POINTER (ncf::FPT n);
(THE v, fh, v ! spgvars, ct ! spgctys);
};
esac;
my (spgv, ghdr)
=
case (spgvars, spgctys)
#
([], _) => (NULL, fhdr);
#
([x], t ! _) => (THE (x, t), fhdr);
_ => { v = issue_codetemp ();
#
record = ncf::CODETEMP v;
fun g (to_temp, type, (i, header))
=
(i+1, \\ next = header (ncf::GET_FIELD_I { i, record, to_temp, type, next }));
my (n, gh)
=
l2::fold_forward g (0, fhdr) (spgvars, spgctys);
ct = ncf::typ::POINTER (ncf::RPT n);
(THE (v, ct), gh);
};
esac;
case spgv
#
THE (x, t) => THE (origargs @ [x], origctys @ [t], ghdr);
NULL => NULL;
esac;
};
herein
# make_arg_in: List( value ) -> Null_Or( cexp -> cexp * List( value ) )
#
fun make_arg_in (args: List( ncf::Value ))
=
{ ctys = map grabty args;
case (arg_spill (args, ctys))
#
THE xx => spill_in xx;
NULL => NULL;
esac;
};
# make_arg_out: List(Variable) -> ( Null_Or( List(Variable), List(cty), cexp) -> cexp )
#
fun make_arg_out args
=
{ ctys = map getty args;
case (arg_spill (args, ctys))
THE xx => spill_out xx;
NULL => NULL;
esac;
};
end; # stipulate
###########################################################################
# Main functions that translate nextcode code #
###########################################################################
fun cexptrans (ce)
=
case ce
#
ncf::DEFINE_RECORD { kind, fields, to_temp, next }
=>
record( kind,
map rectrans fields,
to_temp,
cexptrans next
);
ncf::GET_FIELD_I { i, record, to_temp, type, next }
=>
{ addty (to_temp, type);
record = vtrans record;
next = cexptrans next;
select (i, record, to_temp, getty to_temp, next );
};
ncf::GET_ADDRESS_OF_FIELD_I { i, record, to_temp, next }
=>
ncf::GET_ADDRESS_OF_FIELD_I { i, record => vtrans record, to_temp, next => cexptrans next };
ncf::TAIL_CALL { fn, args }
=>
case (make_arg_in args)
#
THE (args, header) => cexptrans (header (ncf::TAIL_CALL { fn, args }));
NULL => ncf::TAIL_CALL { fn => vtrans fn, args => map vtrans args };
esac;
ncf::DEFINE_FUNS { funs, next }
=>
ncf::DEFINE_FUNS { funs => map functrans funs,
next => cexptrans next
};
ncf::JUMPTABLE { i, xvar, nexts }
=>
ncf::JUMPTABLE
{ i => vtrans i,
xvar,
nexts => map cexptrans nexts
};
ncf::FETCH_FROM_RAM { op, args, to_temp, type, next }
=>
{ addty (to_temp, type);
args = map vtrans args;
next = cexptrans next;
type = getty to_temp;
ncf::FETCH_FROM_RAM { op, args, to_temp, type, next };
};
ncf::STORE_TO_RAM { op, args, next }
=>
ncf::STORE_TO_RAM { op,
args => map vtrans args,
next => cexptrans next
};
ncf::ARITH { op, args, to_temp, type, next }
=>
{ addty (to_temp, type);
#
ncf::ARITH { op, args => map vtrans args, to_temp, type, next => cexptrans next };
};
ncf::RAW_C_CALL { kind, cfun_name, cfun_type, args, to_ttemps, next }
=>
{ apply addty to_ttemps;
#
ncf::RAW_C_CALL { kind, cfun_name, cfun_type, args => map vtrans args, to_ttemps, next => cexptrans next };
};
/*** this special case is a temporary hack; ask ZHONG for details XXX BUGGO FIXME */
# ncf::PURE { op => ncf::p::WRAP, args =>[u], to_temp, type as ncf::typ::POINTER (ncf::FPT _), next } =>
# (addty (w, t); ncf::PURE { op => ncf::p::wrap, args => [vtrans u], to_temp, type, next => cexptrans next })
# ncf::PURE { op => ncf::p::UNWRAP, args =>[u], to_temp, type as ncf::typ::POINTER (ncf::FPT _), next } =>
# (addty (w, t); ncf::PURE { op => ncf::p::unwrap, args => [vtrans u], to_temp, type, next => cexptrans next })
ncf::PURE { op => ncf::p::WRAP,
args => [u],
to_temp,
type,
next
}
=>
{ addvl (to_temp, vtrans u);
#
cexptrans next;
};
ncf::PURE { op => ncf::p::UNWRAP,
args => [u],
to_temp,
type,
next
}
=>
{ case u ncf::CODETEMP z => addty (z, type);
_ => ();
esac;
addvl (to_temp, vtrans u);
cexptrans next;
};
ncf::PURE { op => ncf::p::WRAP_FLOAT64,
args => [u],
to_temp,
type,
next
}
=>
if unboxedfloat
#
addty (to_temp, type);
#
ncf::PURE { op => ncf::p::WRAP_FLOAT64,
args => [vtrans u],
to_temp,
type,
next => cexptrans next
};
else
addvl (to_temp, vtrans u);
cexptrans next;
fi;
ncf::PURE { op => ncf::p::UNWRAP_FLOAT64,
args => [u],
to_temp,
type,
next
}
=>
if unboxedfloat
#
addty (to_temp, type);
#
ncf::PURE { op => ncf::p::UNWRAP_FLOAT64,
args => [vtrans u],
to_temp,
type,
next => cexptrans next
};
else
addvl (to_temp, vtrans u);
#
cexptrans next;
fi;
ncf::PURE { op => ncf::p::IWRAP,
args => [u],
to_temp,
type,
next
}
=>
if untaggedint
#
addty (to_temp, type);
#
ncf::PURE { op => ncf::p::IWRAP,
args => [vtrans u],
to_temp,
type,
next => cexptrans next
};
else
addvl (to_temp, vtrans u);
#
cexptrans next;
fi;
ncf::PURE { op => ncf::p::IUNWRAP,
args => [u],
to_temp,
type,
next
}
=>
if untaggedint
#
addty (to_temp, type);
#
ncf::PURE { op => ncf::p::IUNWRAP,
args => [vtrans u],
to_temp,
type,
next => cexptrans next
};
else
addvl (to_temp, vtrans u);
#
cexptrans next;
fi;
ncf::PURE { op => ncf::p::WRAP_INT1,
args => [u],
to_temp,
type,
next
}
=>
{ addty (to_temp, type);
#
ncf::PURE { op => ncf::p::WRAP_INT1,
args => [vtrans u],
to_temp,
type,
next => cexptrans next
};
};
ncf::PURE { op => ncf::p::UNWRAP_INT1,
args => [u],
to_temp,
type,
next
}
=>
{ addty (to_temp, type);
#
ncf::PURE { op => ncf::p::UNWRAP_INT1,
args => [vtrans u],
to_temp,
type,
next => cexptrans next
};
};
# ncf::PURE { op => ncf::p::CAST,
# args => [u],
# to_temp,
# next,
# ...
# }
# =>
# { addvl (to_temp, vtrans u);
# cexptrans next;
# };
ncf::PURE { op => ncf::p::GETCON,
args => [u],
to_temp,
type,
next
}
=>
{ addty (to_temp, type);
#
select (0, vtrans u, to_temp, type, cexptrans next);
};
ncf::PURE { op => ncf::p::GETEXN,
args => [u],
to_temp,
type,
next
}
=>
{ addty (to_temp, type);
#
select (0, vtrans u, to_temp, type, cexptrans next);
};
ncf::PURE { op, args, to_temp, type, next }
=>
{ addty (to_temp, type);
args = map vtrans args;
next = cexptrans next;
ncf::PURE { op, args, to_temp, type => getty to_temp, next };
};
ncf::IF_THEN_ELSE { op, args, xvar, then_next, else_next }
=>
ncf::IF_THEN_ELSE { op, args => map vtrans args, xvar, then_next => cexptrans then_next,
else_next => cexptrans else_next
};
esac
also
fun functrans (fk, v, args, cl, ce)
=
{ l2::apply addty (args, cl);
#
ce' = cexptrans ce;
case (make_arg_out args)
#
THE (nargs, nctys, fhdr)
=>
(fk, v, nargs, nctys, fhdr ce');
NULL
=>
(fk, v, args, cl, ce');
esac;
}
also
fun rectrans (v, acp)
=
(vtrans v, acp)
also
fun vtrans (ncf::CODETEMP v) => mapvl v;
vtrans u => u;
end;
end; # fun nextcode_preimprover_transform
}; # package nextcode_preimprover_transform_g
end; # stipulate
## Copyright 1996 by Bell Laboratories
## Subsequent changes by Jeff Prothero Copyright (c) 2010-2015,
## released per terms of SMLNJ-COPYRIGHT.