## convert-monoarg-to-multiarg-nextcode-g.pkg "Argument flattening"
# 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# "Argument flattening. As mentioned earlier,
# the earlier phases of the compiler use languages
# where functions take and return single values:
# When multiple values are needed, they are
# bundled into a tuple.
#
# "This phase optimizes the code so that such
# bundles are opened up and passed directly in
# registers as multiple arguments or multiple
# return values."
#
# -- Principled Compilation and Scavenging
# Stefan Monnier, 2003 [PhD Thesis, U Montreal]
# http://www.iro.umontreal.ca/~monnier/master.ps.gz
#
# (See also the discussion on page 16-18, ibid.)
### "The traditional mathematics professor of the popular legend is absentminded.
### He usually appears in public with a lost umbrella in each hand.
### He prefers to face the blackboard and to turn his back to the class.
### He writes a, he says b, he means c; but it should be d.
###
### Some of his sayings are handed down from generation to generation:
###
### "In order to solve this differential equation
### you look at it till a solution occurs to you.
###
### "This principle is so perfectly general that
### no particular application of it is possible.
###
### "Geometry is the science of correct reasoning on incorrect figures.
###
### "My method to overcome a difficulty is to go round it.
###
### "What is the difference between method and device?
### A method is a device which you used twice.
###
### "The first rule of discovery is to have brains and good luck.
### "The second rule of discovery is to sit tight and wait
### till you get a bright idea."
###
### -- George Pólya, "How to solve it", 1945.
stipulate
package ncf = nextcode_form; # nextcode_form is from src/lib/compiler/back/top/nextcode/nextcode-form.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 Convert_Monoarg_To_Multiarg_Nextcode {
#
convert_monoarg_to_multiarg_nextcode
:
{ function: ncf::Function,
table: iht::Hashtable( hut::Uniqtypoid ),
click: String -> Void
}
->
ncf::Function;
};
end;
stipulate
package coc = global_controls::compiler; # global_controls is from src/lib/compiler/toplevel/main/global-controls.pkg package err = error_message; # error_message is from src/lib/compiler/front/basics/errormsg/error-message.pkg package ncf = nextcode_form; # nextcode_form is from src/lib/compiler/back/top/nextcode/nextcode-form.pkg package 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.pkg package iht = int_hashtable; # int_hashtable is from src/lib/src/int-hashtable.pkgherein
# This generic is invoked by:
#
# src/lib/compiler/back/top/improve-nextcode/run-optional-nextcode-improvers-g.pkg #
generic package convert_monoarg_to_multiarg_nextcode_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) Convert_Monoarg_To_Multiarg_Nextcode # Convert_Monoarg_To_Multiarg_Nextcode is from src/lib/compiler/back/top/improve-nextcode/convert-monoarg-to-multiarg-nextcode-g.pkg {
say = global_controls::print::say;
fun bug string
=
err::impossible ("Flatten: " + string);
Arity = BOT
| UNK # An arg seen that isn't a known record
| COUNT (Int, Bool) # int is # of record fields; Bool is whether any arguments were unknown records.
| TOP
;
Info = FNINFO { arity: Ref( List( Arity ) ),
alias: Ref( Null_Or( ncf::Codetemp ) ),
escape: Ref( Bool )
}
| ARGINFO Ref( Int ) # The highest-numbered field selected
| RECINFO Int # Number of fields
| MISCINFO
;
fun convert_monoarg_to_multiarg_nextcode { function=>(fkind, fvar, fargs, ctyl, cexp), table, click }
=
{ clicks = REF 0;
maxfree = mp::num_int_regs;
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 = *coc::checknextcode1
and *coc::checknextcode2
and rep_flag;
select_lty
=
(\\ (lt, i) = if type_flag hcf::lt_get_field (lt, i);
else hcf::truevoid_uniqtypoid;
fi
);
exception NFLATTEN;
fun getty v
=
if type_flag
#
(iht::get table v)
except
_ = { global_controls::print::say ("NFLATTEN: Can't find the variable " +
(int::to_string v) + " in the table ***** \n");
raise exception NFLATTEN;
};
else
hcf::truevoid_uniqtypoid;
fi;
addty = if type_flag iht::set table;
else (\\ _ = ());
fi;
fun newty (f, t)
=
if type_flag
#
iht::drop table f;
addty (f, t);
fi;
fun make_var (t)
=
{ v = tmp::issue_highcode_codetemp();
addty (v, t);
v;
};
fun grabty u
=
{ fun g (ncf::CODETEMP v) => getty v;
g (ncf::INT _) => hcf::int_uniqtypoid;
g (ncf::FLOAT64 _) => hcf::float64_uniqtypoid;
g (ncf::STRING _) => hcf::truevoid_uniqtypoid;
g (ncf::LABEL v) => getty v;
g _ => hcf::truevoid_uniqtypoid;
end;
if type_flag g u;
else hcf::truevoid_uniqtypoid;
fi;
};
fun arg_lty [] => hcf::int_uniqtypoid;
arg_lty [t]
=>
hcf::if_uniqtypoid_is_tuple_type
( t,
\\ xs as (_ ! _) => length(xs) < mp::max_rep_regs
?? hcf::make_tuple_uniqtypoid [t]
:: t;
_ => t;
end,
\\ t =>
hcf::if_uniqtypoid_is_package
( t,
\\ xs as (_ ! _) => length (xs) < mp::max_rep_regs
?? hcf::make_tuple_uniqtypoid [t]
:: t;
_ => t;
end,
\\ t = t
);
end
);
arg_lty r => hcf::make_package_uniqtypoid r; # this is INCORRECT !!!!!!! XXX BUGGO FIXME
end;
fun ltc_fun (x, y)
=
if (hcf::uniqtypoid_is_type x and hcf::uniqtypoid_is_type y)
hcf::make_lambdacode_arrow_uniqtypoid (x, y);
else hcf::make_lambdacode_generic_package_uniqtypoid (x, y);
fi;
fun make_fn_lty (_, _, NIL)
=>
bug "make_fn_lty in nflatten";
make_fn_lty (k, cntt ! _, x ! r)
=>
hcf::ltw_is_fate
(
x,
\\ [t2] => (k, ltc_fun (arg_lty r, t2));
_ => bug "unexpected mkfnLty";
end,
\\ [t2] => (k, ltc_fun (arg_lty r, hcf::make_type_uniqtypoid t2));
_ => bug "unexpected mkfnLty";
end,
\\ x = (k, ltc_fun (arg_lty r, x))
);
make_fn_lty (k, _, r)
=>
(k, hcf::make_uniqtypoid_fate([arg_lty r]));
end;
# Note that maxfree has already been reduced by 1 (in CPScomp)
# on most machines to allow for an arithtemp:
#
maxregs = maxfree - mp::num_callee_saves;
stipulate
exception USAGE_MAP;
my m: iht::Hashtable( Info )
= iht::make_hashtable { size_hint => 128, not_found_exception => USAGE_MAP };
umap = iht::get m;
herein
fun get i
=
umap i
except
USAGE_MAP = MISCINFO;
enter = iht::set m;
end;
fun select (ncf::CODETEMP v, i)
=>
case (get v)
ARGINFO (biggest_sel as REF j) => biggest_sel := int::max (i, j);
_ => ();
esac;
select (ncf::LABEL v, i) => select (ncf::CODETEMP v, i);
select _ => ();
end;
fun escape (ncf::CODETEMP v)
=>
case (get v)
FNINFO { escape=>r, ... } => r := TRUE;
_ => ();
esac;
escape (ncf::LABEL v)
=>
escape (ncf::CODETEMP v);
escape _ => ();
end;
fun field' (v, ncf::VIA_SLOT (i, _)) => select (v, i);
field' (v, _) => escape v;
end;
botlist = if *coc::flattenargs map (\\ _ = BOT);
else map (\\ _ = TOP);
fi;
fun enter_fn (_, f, vl, _, cexp)
=
{ enter (f, FNINFO { arity=>REF (botlist vl), alias=>REF NULL, escape=>REF FALSE } );
apply (\\ v = enter (v, ARGINFO (REF -1))) vl;
};
stipulate
exception FOUND;
herein
fun find_fetch (v, k) body
=
# Find whether field k
# of variable v is
# guaranteed to exist:
#
( f body
except FOUND = TRUE
)
where
fun f (ncf::DEFINE_RECORD { fields, next, ... }) => { apply g fields; f next; };
f (ncf::GET_FIELD_I { i, record => ncf::CODETEMP v', next, ... })
=>
if (v==v' and i==k) raise exception FOUND;
else f next;
fi;
f (ncf::GET_FIELD_I r) => f r.next;
f (ncf::GET_ADDRESS_OF_FIELD_I r) => f r.next;
f (ncf::DEFINE_FUNS r) => f r.next;
f (ncf::FETCH_FROM_RAM r) => f r.next;
f (ncf::STORE_TO_RAM r) => f r.next;
f (ncf::ARITH r) => f r.next;
f (ncf::PURE r) => f r.next;
f (ncf::RAW_C_CALL r) => f r.next;
#
f (ncf::IF_THEN_ELSE { then_next, else_next, ... }) => find_fetch (v, k) then_next
and find_fetch (v, k) else_next;
f (ncf::JUMPTABLE { nexts, ... }) => not (list::exists (not o find_fetch (v, k)) nexts);
f _ => FALSE;
end
also
fun g (ncf::CODETEMP v', ncf::VIA_SLOT (i, _)) => if (v==v' and i==k ) raise exception FOUND; fi;
g _ => ();
end;
end;
end;
fun check_flatten (_, f, vl, _, body)
=
case (get f)
#
FNINFO { arity as REF al, alias, escape }
=>
{ fun loop (v ! vl, a ! al, headroom)
=>
case (a, get v)
#
( COUNT (c, some_non_record_actual),
ARGINFO (REF j)
)
=>
if ( j > -1 # exists a select of the formal parameter
and headroom-(c - 1) >= 0
and ( not (some_non_record_actual or *escape)
or *coc::extraflatten
and j == c - 1 and find_fetch (v, j) body)
)
a ! loop (vl, al, headroom-(c - 1));
else TOP ! loop (vl, al, headroom );
fi;
_ => TOP ! loop (vl, al, headroom);
esac;
loop _ => NIL;
end;
a' = loop (vl, al, maxregs - 1 - length(al));
arity := a';
if (list::exists
#
\\ COUNT _ => TRUE;
_ => FALSE;
end
#
a'
)
#
alias := THE (tmp::clone_highcode_codetemp f);
click "F";
clicks := *clicks+1;
fi;
};
_ => (); # Impossible.
esac;
# ************************************************************************
# pass1: Gather usage information on the variables within a nextcode expression.
# ************************************************************************
recursive my pass1
=
\\ ncf::DEFINE_RECORD { fields, to_temp, next, ... } => { enter (to_temp, RECINFO (length fields)); apply field' fields; pass1 next;};
ncf::GET_FIELD_I { i, record, next, ... } => { select (record, i); pass1 next;};
ncf::GET_ADDRESS_OF_FIELD_I { record, next, ... } => { escape record; pass1 next;};
#
ncf::STORE_TO_RAM { args, next, ... } => { apply escape args; pass1 next; };
ncf::FETCH_FROM_RAM { args, next, ... } => { apply escape args; pass1 next; };
#
ncf::ARITH { args, next, ... } => { apply escape args; pass1 next; };
ncf::PURE { args, next, ... } => { apply escape args; pass1 next; };
ncf::RAW_C_CALL { args, next, ... } => { apply escape args; pass1 next; };
#
ncf::JUMPTABLE { i, nexts, ... } => { escape i; apply pass1 nexts;};
ncf::IF_THEN_ELSE { args, then_next, else_next, ... } => { apply escape args; pass1 then_next; pass1 else_next;};
ncf::TAIL_CALL { fn => ncf::CODETEMP f, args }
=>
{ fun loop (t ! r, args0 as (ncf::CODETEMP v) ! args, n)
=>
case (t, get v)
#
(BOT, RECINFO size)
=>
loop (COUNT (size, FALSE) ! r, args0, n);
(BOT, _)
=>
UNK ! loop (r, args, n+1);
(UNK, RECINFO size)
=>
loop (COUNT (size, TRUE) ! r, args0, n);
(UNK, _)
=>
UNK ! loop (r, args, n+1);
(COUNT (a, _), RECINFO size)
=>
a == size ?? t ! loop (r, args, n+1)
:: TOP ! loop (r, args, n+1);
(COUNT (a, _), _)
=>
COUNT (a, TRUE) ! loop (r, args, n+1);
_ => TOP ! loop (r, args, n+1);
esac;
loop (_ ! r, _ ! args, n)
=>
TOP ! loop (r, args, n+1);
loop _
=>
NIL;
end;
apply escape args;
case (get f)
FNINFO { arity as REF al, ... } => arity := loop (al, args, 0);
_ => ();
esac;
};
ncf::TAIL_CALL { args, ... } => apply escape args;
ncf::DEFINE_FUNS { funs, next }
=>
{ apply enter_fn funs;
apply (\\ (_, _, _, _, body) = pass1 body) funs;
pass1 next;
apply check_flatten funs;
};
end ;
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::JUMPTABLE { i, xvar, nexts } => ncf::JUMPTABLE { i, xvar, nexts => map reduce nexts };
#
ncf::FETCH_FROM_RAM { op, args, to_temp, type, next } => ncf::FETCH_FROM_RAM { op, args, to_temp, type, next => reduce next };
ncf::STORE_TO_RAM { op, args, next } => ncf::STORE_TO_RAM { op, args, 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::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::TAIL_CALL { fn => fn as ncf::CODETEMP fv,
args
}
=>
case (get fv)
#
FNINFO { arity=>REF al, alias=>REF (THE f'), ... }
=>
loop (al, args, NIL)
where
fun loop (COUNT (count, _) ! r, v ! vl, args)
=>
g (0, args)
where
lt = grabty v;
fun g (i, args)
=
if (i == count)
#
loop (r, vl, args);
else
tt = select_lty (lt, i);
z = make_var (tt);
ncf::GET_FIELD_I { i, record => v, to_temp => z, type => ncf::uniqtypoid_to_nextcode_type tt, next => g (i+1, ncf::CODETEMP(z) ! args) };
fi;
end;
loop(_ ! r, v ! vl, args) => loop (r, vl, v ! args);
loop(_, _, args) => ncf::TAIL_CALL { fn => ncf::CODETEMP f',
args => reverse args
};
end;
end;
_ => ncf::TAIL_CALL { fn, args };
esac;
ncf::TAIL_CALL funargs =>
ncf::TAIL_CALL funargs;
ncf::DEFINE_FUNS { funs, next }
=>
ncf::DEFINE_FUNS { funs => map reduce_body (process_args funs),
next => reduce next
}
where
fun vars (0, _, l, l')
=>
(l, l');
vars (i, lt, l, l')
=>
{ tt = select_lty (lt, i - 1);
vars (i - 1, lt, (make_var (tt)) ! l, (ncf::uniqtypoid_to_nextcode_type tt) ! l');
};
end;
fun newargs (COUNT (j, _) ! r, v ! vl, _ ! cl)
=>
(new @ vl', ncl @ cl', bodytransform o bt')
where
(getty v) -> lt;
(vars (j, lt, NIL, NIL)) -> (new, ncl);
(newargs (r, vl, cl)) -> (vl', cl', bt');
fun bodytransform body
=
ncf::DEFINE_RECORD
{
kind => ncf::rk::RECORD,
fields => map (\\ x = (ncf::CODETEMP x, ncf::SLOT 0)) new,
to_temp => v,
next => body
};
end;
newargs(_ ! r, v ! vl, ct ! cl)
=>
(v ! vl', ct ! cl', bt')
where
(newargs (r, vl, cl)) -> (vl', cl', bt');
end;
newargs _
=>
([],[], \\ b=b);
end;
fun process_args ((fdef as (fk, f, vl, cl, body)) ! rest)
=>
case (get f)
#
FNINFO { arity=>REF al, alias=>REF (THE f'), ... }
=>
{ my (nargs, ncl, bt) = newargs (al, vl, cl);
my (fk', lt) = make_fn_lty (fk, ncl, map getty nargs);
newty (f', lt);
wl = map tmp::clone_highcode_codetemp vl;
(fk, f, wl, cl, ncf::TAIL_CALL { fn => ncf::CODETEMP f, args => map ncf::CODETEMP wl })
!
(fk', f', nargs, ncl, bt body) ! process_args rest;
};
_ => fdef ! process_args rest;
esac;
process_args NIL
=>
NIL;
end;
fun reduce_body (fk, f, vl, cl, body)
=
(fk, f, vl, cl, reduce body);
end;
end;
fun fprint (function, s: String)
=
{ say "\n"; say s; say "\n \n";
prettyprint_nextcode::print_nextcode_function function;
};
debugprint "Flatten: ";
debugflush();
if debug fprint ((fkind, fvar, fargs, ctyl, cexp), "Before flatten:"); fi;
pass1 cexp;
cexp' = *clicks > 0 ?? reduce cexp
:: cexp;
if debug
#
if (*clicks > 0) fprint ((fkind, fvar, fargs, ctyl, cexp'), "After flatten:");
else say "No flattening this time.\n";
fi;
fi;
debugprint "\n";
( fkind,
fvar,
fargs,
ctyl,
cexp'
);
};
}; # generic package convert_monoarg_to_multiarg_nextcode_g
end; # stipulate
## Copyright 1996 by Bell Laboratories
## Subsequent changes by Jeff Prothero Copyright (c) 2010-2015,
## released per terms of SMLNJ-COPYRIGHT.