## uncurry-nextcode-functions-g.pkg
# Compiled by:
# src/lib/compiler/core.sublib# This file implements one of the nextcode transforms.
# For context, see the comments in
#
# src/lib/compiler/back/top/highcode/highcode-form.api# "It was easy and harmless to do uncurrying as part of
# 'improve_mutually_recursive_anormcode_functions', with the
# added benefit that it merged two tree traversals into
# one. This is particularly important since those phases are
# worth doing often and both traversals need to build a whole
# new result expression, which is slower than read-only traversals."
#
# -- Principled Compilation and Scavenging
# Stefan Monnier, 2003 [PhD Thesis, U Montreal]
# http://www.iro.umontreal.ca/~monnier/master.ps.gz
# "Simple form of uncurrying which turns a curried
# function
#
# fun f x y = e
#
# into an uncurried function
#
# fun f'(x, y) = e
#
# and an uncurry wrapper function
#
# fun f x y = f'(x,y)
#
# "The actual uncurrying at the call sites is done
# later on in the expand phase by inlining the wrapper."
#
# -- Principled Compilation and Scavenging
# Stefan Monnier, 2003 [PhD Thesis, U Montreal]
# http://www.iro.umontreal.ca/~monnier/master.ps.gz
### "I am too good for philosophy
### and not good enough for physics.
### Mathematics is in between."
###
### -- George Pólya
stipulate
package ncf = nextcode_form; # nextcode_form is from src/lib/compiler/back/top/nextcode/nextcode-form.pkg package hct = highcode_type; # highcode_type is from src/lib/compiler/back/top/highcode/highcode-type.pkg package hut = highcode_uniq_types; # highcode_uniq_types is from src/lib/compiler/back/top/highcode/highcode-uniq-types.pkg package iht = int_hashtable; # int_hashtable is from src/lib/src/int-hashtable.pkgherein
api Uncurry_Nextcode_Functions {
#
uncurry_nextcode_functions
:
{ function: ncf::Function,
table: iht::Hashtable( hut::Uniqtypoid ),
click: String -> Void
}
->
ncf::Function;
};
end;
# 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 ncf = nextcode_form; # nextcode_form is from src/lib/compiler/back/top/nextcode/nextcode-form.pkg package hcf = highcode_form; # highcode_form is from src/lib/compiler/back/top/highcode/highcode-form.pkg package tmp = highcode_codetemp; # highcode_codetemp is from src/lib/compiler/back/top/highcode/highcode-codetemp.pkgherein
# We are invoked from:
#
# src/lib/compiler/back/top/improve-nextcode/run-optional-nextcode-improvers-g.pkg generic package uncurry_nextcode_functions_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) Uncurry_Nextcode_Functions # Uncurry_Nextcode_Functions is from src/lib/compiler/back/top/improve-nextcode/uncurry-nextcode-functions-g.pkg {
fun bug s = err::impossible ("Uncurry: " + s);
fun freein v
=
g
where
fun try (ncf::CODETEMP w) => v == w;
try (ncf::LABEL w) => v == w;
try _ => FALSE;
end;
fun any (w ! rest) => try w or any rest;
any NIL => FALSE;
end;
fun any1 ((w, _) ! rest) => try w or any1 rest;
any1 NIL => FALSE;
end;
recursive my g
=
\\ ncf::TAIL_CALL { fn, args } => try fn or any args;
ncf::JUMPTABLE { i, nexts, ... } => try i or list::exists g nexts;
#
ncf::DEFINE_RECORD { fields, next, ... } => any1 fields or g next;
ncf::GET_FIELD_I { record, next, ... } => try record or g next;
ncf::GET_ADDRESS_OF_FIELD_I { record, next, ... } => try record or g next;
#
( ncf::STORE_TO_RAM { args, next, ... }
| ncf::FETCH_FROM_RAM { args, next, ... }
| ncf::ARITH { args, next, ... }
| ncf::PURE { args, next, ... }
| ncf::RAW_C_CALL { args, next, ... }
) =>
any args or g next;
ncf::IF_THEN_ELSE { args, then_next, else_next, ... }
=>
any args or
g then_next or
g else_next;
ncf::DEFINE_FUNS { funs, next } => list::exists (g o #5) funs or g next;
end ;
end;
fun uncurry_nextcode_functions
{
function => (fkind, fvar, fargs, ctyl, cexp),
table => typetable, click
}
=
{ debug = *global_controls::compiler::debugnextcode; # FALSE
fun debugprint s = if debug global_controls::print::say s; fi;
fun debugflush () = if debug global_controls::print::flush(); fi;
rep_flag = mp::representations;
type_flag = *global_controls::compiler::checknextcode1
and *global_controls::compiler::checknextcode2
and rep_flag;
default_arrow = hcf::make_lambdacode_arrow_uniqtypoid (hcf::truevoid_uniqtypoid, hcf::truevoid_uniqtypoid);
fun extend_lty (t,[]) => t;
extend_lty (t, a) => default_arrow;
end;
#########################################################################
# Count the number of int and float registers needed for a list of lvars:
unboxedfloat = mp::unboxed_floats;
fun is_flt_cty ncf::typ::FLOAT64 => unboxedfloat;
is_flt_cty _ => FALSE;
end;
num_csgpregs = mp::num_callee_saves;
num_csfpregs = mp::num_float_callee_saves;
maxgpregs = mp::num_int_regs - num_csgpregs - 1;
maxfpregs = mp::num_float_regs - num_csfpregs - 2;
fun checklimit (cl)
=
h (cl, 0, 0)
where
fun h (ncf::typ::FLOAT64 ! rest, m, n) => if unboxedfloat h (rest, m, n+1); else h (rest, m+1, n); fi;
h (_ ! rest, m, n) => h (rest, m+1, n);
h ([], m, n) => (m <= maxgpregs) and (n <= maxfpregs);
end;
end;
exception NEWETA;
fun getty v
=
if type_flag
#
(int_hashtable::get typetable v)
except
_ = { global_controls::print::say ("NEWETA: Can't find the variable " +
(int::to_string v) + " in the typetable ***** \n");
raise exception NEWETA;
};
else
hcf::truevoid_uniqtypoid;
fi;
fun addty (f, t)
=
if type_flag
#
int_hashtable::set typetable (f, t);
fi;
fun make_var (t)
=
{ v = tmp::issue_highcode_codetemp();
addty (v, t);
v;
};
fun copy_lvar v
=
{ x = tmp::clone_highcode_codetemp (v);
addty (x, getty v);
x;
};
# fun userfun (f) = case hcf::out (getty (f)) of hcf::ARROW _ => TRUE
# | _ => FALSE
recursive my reduce
=
\\ ncf::DEFINE_RECORD { kind, fields, to_temp, next }
=> ncf::DEFINE_RECORD { kind, fields, to_temp, next => reduce next };
#
ncf::GET_FIELD_I { i, record, to_temp, type, next }
=> ncf::GET_FIELD_I { i, record, to_temp, type, next => reduce next };
#
ncf::GET_ADDRESS_OF_FIELD_I { i, record, to_temp, next }
=> ncf::GET_ADDRESS_OF_FIELD_I { i, record, to_temp, next => reduce next };
#
ncf::TAIL_CALL funargs => ncf::TAIL_CALL funargs;
#
ncf::JUMPTABLE { i, xvar, nexts }
=> ncf::JUMPTABLE { i, xvar, nexts => map reduce nexts };
ncf::IF_THEN_ELSE { op, args, xvar, then_next, else_next }
=> ncf::IF_THEN_ELSE { op, args, xvar, then_next => reduce then_next, else_next => reduce else_next };
ncf::FETCH_FROM_RAM { op, args, to_temp, type, next }
=> ncf::FETCH_FROM_RAM { op, args, to_temp, type, next => reduce next };
ncf::ARITH { op, args, to_temp, type, next } => ncf::ARITH { op, args, to_temp, type, next => reduce next };
ncf::PURE { op, args, to_temp, type, next } => ncf::PURE { op, args, to_temp, type, next => reduce next };
ncf::RAW_C_CALL { kind, cfun_name, cfun_type, args, to_ttemps, next }
=> ncf::RAW_C_CALL { kind, cfun_name, cfun_type, args, to_ttemps, next => reduce next };
ncf::STORE_TO_RAM { op, args, next }
=> ncf::STORE_TO_RAM { op, args, next => reduce next };
ncf::DEFINE_FUNS { funs, next }
=>
{ ncf::DEFINE_FUNS { funs => fold_backward (\\ (fd, r) = (uncurry fd) @ r) [] funs,
next => reduce next
};
}
where
fun uncurry (fd as (ncf::FATE_FN, _, _, _, _))
=>
[ reduce_body fd ];
uncurry
(fd as
( fk,
f,
k ! vl, ct ! cl,
body as ncf::DEFINE_FUNS
{
funs => [(gk, g, ul, cl', body2)],
#
next =>
ncf::TAIL_CALL { fn => ncf::CODETEMP c,
args => [ncf::CODETEMP g']
}
}
)
)
=>
if (k==c and g==g' # And userfun (g)
and not (freein k body2)
and not (freein g body2) # g not recursive
and checklimit (cl@cl')
)
ul' = map copy_lvar ul;
vl' = map copy_lvar vl;
k' = copy_lvar k;
g' = copy_lvar g;
newlt = extend_lty (getty (g), (map getty vl));
f' = make_var (newlt);
click "u";
( ncf::NO_INLINE_INTO,
f,
k' ! vl',
ct ! cl,
ncf::DEFINE_FUNS
{
funs =>
[ ( gk,
g',
ul',
cl',
ncf::TAIL_CALL { fn => ncf::CODETEMP f',
args => map ncf::CODETEMP (ul' @ vl')
}
)
],
#
next =>
ncf::TAIL_CALL { fn => ncf::CODETEMP k',
args => [ ncf::CODETEMP g' ]
}
}
)
!
uncurry (fk, f', ul@vl, cl'@cl, body2 );
else
[reduce_body fd];
fi;
uncurry fd => [reduce_body fd];
end
also
fun reduce_body (fk, f, vl, cl, e)
=
(fk, f, vl, cl, reduce e);
end;
end;
debugprint "Uncurry: ";
debugflush();
(fkind, fvar, fargs, ctyl, reduce cexp) then debugprint "\n";
};
}; # generic package uncurry_g
end; # stipulate
## Copyright 1996 by Bell Laboratories
## Subsequent changes by Jeff Prothero Copyright (c) 2010-2015,
## released per terms of SMLNJ-COPYRIGHT.