## improve-anormcode-switch-fn.pkg
#
# Our make_anormcode_switch_fn_improver entrypoint is called (only) from:
#
# src/lib/compiler/back/top/nextcode/translate-anormcode-to-nextcode-g.pkg# Compiled by:
# src/lib/compiler/core.sublibstipulate
package acf = anormcode_form; # anormcode_form is from src/lib/compiler/back/top/anormcode/anormcode-form.pkg package vh = varhome; # varhome is from src/lib/compiler/front/typer-stuff/basics/varhome.pkgherein
api Improve_Anormcode_Switch_Fn {
#
exception TOO_BIG;
make_anormcode_switch_fn_improver
:
{ e_int: Int -> A_value, # May raise TOO_BIG; not all ints need be representable.
e_real: String -> A_value,
e_switchlimit: Int,
e_neq: A_comparison,
e_w32neq: A_comparison,
e_i32neq: A_comparison,
e_unt1: one_word_unt::Unt -> A_value,
e_int1: one_word_unt::Unt -> A_value,
e_wneq: A_comparison,
e_unt: Unt -> A_value,
e_pneq: A_comparison,
e_fneq: A_comparison,
e_less: A_comparison,
e_branch: (A_comparison, A_value, A_value, A_cexp, A_cexp) -> A_cexp,
e_strneq: (A_value, String, A_cexp, A_cexp) -> A_cexp,
e_switch: (A_value, List( A_cexp )) -> A_cexp,
e_add: (A_value, A_value, (A_value -> A_cexp)) -> A_cexp,
e_gettag: (A_value, (A_value -> A_cexp)) -> A_cexp,
e_getexn: (A_value, (A_value -> A_cexp)) -> A_cexp,
e_length: (A_value, (A_value -> A_cexp)) -> A_cexp,
e_unwrap: (A_value, (A_value -> A_cexp)) -> A_cexp,
e_boxed: (A_value, A_cexp, A_cexp) -> A_cexp,
e_path: (vh::Varhome, (A_value -> A_cexp)) -> A_cexp
}
->
{ expression: A_value,
an_api: vh::Valcon_Signature,
cases: List( (acf::Casetag, A_cexp) ),
default: A_cexp
}
->
A_cexp;
};
end;
stipulate
package acf = anormcode_form; # anormcode_form is from src/lib/compiler/back/top/anormcode/anormcode-form.pkg package lms = list_mergesort; # list_mergesort is from src/lib/src/list-mergesort.pkg package vh = varhome; # varhome is from src/lib/compiler/front/typer-stuff/basics/varhome.pkgherein
package improve_anormcode_switch_fn
: (weak) Improve_Anormcode_Switch_Fn # Improve_Anormcode_Switch_Fn is from src/lib/compiler/back/top/nextcode/improve-anormcode-switch-fn.pkg {
fun bug s
=
error_message::impossible ("Switch: " + s);
exception TOO_BIG;
fun sublist test
=
subl
where
fun subl (a ! r)
=>
test a ?? a ! (subl r)
:: (subl r);
subl x
=>
x;
end;
end;
fun nthcdr (l, 0) => l;
nthcdr (a ! r, n) => nthcdr (r, n - 1);
nthcdr _ => bug "nthcdr in switch";
end;
fun count test
=
subl 0
where
fun subl acc (a ! r)
=>
subl
(test a ?? 1+acc
:: acc
)
r;
subl acc NIL
=>
acc;
end;
end;
fun make_anormcode_switch_fn_improver
{
e_int: Int -> A_value, # May raise TOO_BIG; not all ints need be representable.
e_real: String -> A_value,
e_switchlimit: Int,
#
e_neq: A_comparison,
e_w32neq: A_comparison,
e_i32neq: A_comparison,
#
e_unt1: one_word_unt::Unt -> A_value,
e_int1: one_word_unt::Unt -> A_value,
e_unt: Unt -> A_value,
#
e_wneq: A_comparison,
e_pneq: A_comparison,
e_fneq: A_comparison,
e_less: A_comparison,
#
e_branch: (A_comparison, A_value, A_value, A_cexp, A_cexp) -> A_cexp,
#
e_strneq: (A_value, String, A_cexp, A_cexp) -> A_cexp,
e_switch: (A_value, List( A_cexp )) -> A_cexp,
e_add: (A_value, A_value, (A_value -> A_cexp)) -> A_cexp,
#
e_gettag: (A_value, (A_value -> A_cexp)) -> A_cexp,
e_getexn: (A_value, (A_value -> A_cexp)) -> A_cexp,
e_length: (A_value, (A_value -> A_cexp)) -> A_cexp,
e_unwrap: (A_value, (A_value -> A_cexp)) -> A_cexp,
#
e_boxed: (A_value, A_cexp, A_cexp) -> A_cexp,
e_path: (vh::Varhome, (A_value -> A_cexp)) -> A_cexp
}
=
\\ { cases => NIL, default, ... }
=>
default;
{ expression, an_api, cases as (c, _) ! _, default }
=>
case c
#
acf::INT_CASETAG _
=>
int_switch (expression, map un_int cases, default, NULL)
where
fun un_int (acf::INT_CASETAG i, e) => (i, e);
un_int _ => bug "un_int";
end;
end;
acf::VAL_CASETAG((_, vh::EXCEPTION _, _), _, _)
=>
exn_switch (expression, cases, default);
acf::VAL_CASETAG _ => valcon_switch (expression, an_api, cases, default);
acf::FLOAT64_CASETAG _ => float64_switch (expression, cases, default);
acf::STRING_CASETAG _ => string_switch (expression, cases, default);
acf::UNT_CASETAG _ => unt_switch (expression, cases, default);
acf::UNT1_CASETAG _ => unt1_switch (expression, cases, default);
acf::INT1_CASETAG _ => int1_switch (expression, cases, default);
_ => bug "unexpected Constructor in make_switch";
esac;
end
where
fun switch1 (e: A_value, cases: List( (Int, A_cexp) ), default: A_cexp, (lo, hi))
=
{ delta = 2;
fun collapse (l as (li, ui, ni, xi) ! (lj, uj, nj, xj) ! r )
=>
(ni+nj) * delta > ui-lj
?? collapse((lj, ui, ni+nj, xj) ! r)
:: l;
collapse l
=>
l;
end;
fun f (z, x as (i, _) ! r)
=>
f (collapse((i, i, 1, x) ! z), r);
f (z, NIL)
=>
z;
end;
fun tackon (stuff as (l, u, n, x) ! r)
=>
(n*delta > u-l and n>e_switchlimit and hi>u)
?? tackon((l, u+1, n+1, x @ [(u+1, default)]) ! r)
:: stuff;
tackon NIL
=>
bug "switch.3217";
end;
fun separate((z as (l, u, n, x)) ! r)
=>
if (n < e_switchlimit
and n > 1
)
my ix as (i, _)
=
list::nth (x, (n - 1));
(i, i, 1,[ix]) ! separate((l, l, n - 1, x) ! r);
else z ! separate r;
fi;
separate NIL => NIL;
end;
chunks = reverse (separate (tackon (f (NIL, cases))));
fun g (1, (l, h, 1, (i, b) ! _) ! _, (lo, hi))
=>
if (lo==i and hi==i) b;
else e_branch (e_neq, e, e_int i, default, b);
fi;
g (1, (l, h, n, x) ! _, (lo, hi))
=>
{ fun f (0, _, _)
=>
NIL;
f (n, i, l as (j, b) ! r)
=>
if (i+lo == j)
b ! f (n - 1, i+1, r);
else (default ! f (n, i+1, l));
fi;
f _ => bug "switch.987";
end;
list = f (n, 0, x);
body = if (lo==0)
e_switch (e, list);
else e_add (e, e_int(-lo), \\ v = e_switch (v, list));
fi;
a = if (lo < l) e_branch (e_less, e, e_int l, default, body); else body; fi;
b = if (hi > h) e_branch (e_less, e_int h, e, default, a ); else a; fi;
b;
};
g (n, cases, (lo, hi))
=>
{ n2 = n / 2;
c2 = nthcdr (cases, n2);
my (l, r)
=
case c2
(l1, _, _, _) ! r1
=>
(l1, r1);
_ => bug "switch.111";
esac;
e_branch
( e_less,
e,
e_int l,
g (n2, cases, (lo, l - 1)),
g (n-n2, c2, (l, hi))
);
};
end;
g (list::length chunks, chunks, (lo, hi));
};
sortcases
=
lms::sort_list
#
(\\ ((i: Int, _), (j, _)) = i > j);
fun int_switch (e: A_value, l, default, inrange)
=
{ len = list::length l;
fun isbig i
=
{ e_int i;
FALSE;
}
except
TOO_BIG = TRUE;
anybig = list::exists (isbig o #1) l;
fun construct (i, c)
=
if (isbig i)
j = i / 2;
construct
( j,
\\ j' = construct
( i-j,
\\ k' = e_add (j', k', c)
)
);
else
c (e_int i);
fi;
fun ifelse NIL
=>
default;
ifelse ((i, b) ! r)
=>
construct (i, \\ i' = e_branch (e_neq, i', e, ifelse r, b));
end;
fun ifelse_n [(i, b)] => b;
ifelse_n ((i, b) ! r) => e_branch (e_neq, e_int i, e, ifelse_n r, b);
ifelse_n _ => bug "switch.224";
end;
l = sortcases l;
case (anybig or len<e_switchlimit, inrange)
(TRUE, NULL)
=>
ifelse l;
(TRUE, THE n)
=>
if (n+1==len) ifelse_n l;
else ifelse l;
fi;
(FALSE, NULL)
=>
{ hi = #1 (list::last l
except list::EMPTY = bug "switch::last132"
);
my (low, r)
=
case l
(low', _) ! r' => (low', r');
_ => bug "switch.23";
esac;
e_branch (e_less, e, e_int low, default,
e_branch (e_less, e_int hi, e, default,
switch1 (e, l, default, (low, hi))));
};
(FALSE, THE n)
=>
switch1 (e, l, default, (0, n));
esac;
};
fun isboxed (acf::VAL_CASETAG((_, vh::CONSTANT _, _), _, _)) => FALSE;
isboxed (acf::VAL_CASETAG((_, vh::LISTNIL, _), _, _)) => FALSE;
isboxed (acf::VAL_CASETAG((_, representation, _), _, _)) => TRUE;
isboxed (acf::FLOAT64_CASETAG _) => TRUE;
isboxed (acf::STRING_CASETAG s) => TRUE;
isboxed _ => FALSE;
end;
fun isexn (acf::VAL_CASETAG((_, vh::EXCEPTION _, _), _, _)) => TRUE;
isexn _ => FALSE;
end;
fun exn_switch (w, l, default)
=
e_getexn
( w,
\\ u = g l
where
fun g((acf::VAL_CASETAG((_, vh::EXCEPTION p, _), _, _), x) ! r)
=>
e_path (p, \\ v = e_branch (e_pneq, u, v, g r, x));
g NIL => default;
g _ => bug "switch.21";
end;
end
);
fun valcon_switch (w, an_api, l: List( (acf::Casetag, A_cexp) ), default)
=
{
fun tag (acf::VAL_CASETAG((_, vh::CONSTANT i, _), _, _)) => i;
tag (acf::VAL_CASETAG((_, vh::TAGGED i, _), _, _)) => i;
# tag (acf::VAL_CASETAG((_, vh::TAGGEDREC (i, _), _), _, _)) = i;
tag _ => 0;
end;
fun tag'(c, e)
=
(tag c, e);
boxed = sublist (isboxed o #1) l;
unboxed = sublist (not o isboxed o #1) l;
b = map tag' boxed;
u = map tag' unboxed;
case an_api
#
vh::CONSTRUCTOR_SIGNATURE (0, n)
=>
e_unwrap (w, \\ w' = int_switch (w', u, default, THE (n - 1)));
vh::CONSTRUCTOR_SIGNATURE (n, 0)
=>
e_gettag (w, \\ w' = int_switch (w', b, default, THE (n - 1)));
vh::CONSTRUCTOR_SIGNATURE (1, nu)
=>
e_boxed (w, int_switch (e_int 0, b, default, THE 0),
e_unwrap (w, \\ w' = int_switch (w', u, default, THE (nu - 1))));
vh::CONSTRUCTOR_SIGNATURE (nb, nu)
=>
e_boxed (w,
e_gettag (w, \\ w' = int_switch (w', b, default, THE (nb - 1))),
e_unwrap (w, \\ w' = int_switch (w', u, default, THE (nu - 1))));
vh::NULLARY_CONSTRUCTOR => bug "valcon_switch";
esac;
};
fun coalesce (l: List( (String, X) )) : List ((Int, List( (String, X) )) )
=
gather (size s, l', [],[])
where
l' = lms::sort_list
#
(\\ ((s1, _), (s2, _)) = size s1 > size s2)
#
l;
s = #1 (list::head l');
fun gather (n,[], current, acc)
=>
(n, current) ! acc;
gather (n, (x as (s, a)) ! rest, current, acc)
=>
{ s1 = size s;
#
if (s1 == n) gather (n, rest, x ! current, acc);
else gather (s1, rest,[x], (n, current) ! acc);
fi;
};
end;
end;
fun string_switch (w, l, default)
=
{ fun strip (acf::STRING_CASETAG s, x)
=>
(s, x);
strip _ => bug "string_switch";
end;
b = map strip l;
bylength = coalesce b;
fun one_len (0, (_, e) ! _)
=>
(0, e);
one_len (len, l)
=>
(len, try l)
where
fun try ((s, e) ! rest) => e_strneq (w, s, try rest, e);
try NIL => default;
end;
end;
end;
genbs = e_length ( w,
\\ len = int_switch (len, map one_len bylength, default, NULL)
);
genbs;
};
fun float64_switch (w, (acf::FLOAT64_CASETAG rval, x) ! r, default)
=>
e_branch (e_fneq, w, e_real rval, float64_switch (w, r, default), x);
float64_switch(_, NIL, default) => default;
float64_switch _ => bug "switch.81";
end;
fun unt_switch (w, (acf::UNT_CASETAG wval, e) ! rest, default)
=>
e_branch (e_wneq, w, e_unt wval, unt_switch (w, rest, default), e);
unt_switch(_, NIL, default) => default;
unt_switch _ => bug "switch.88";
end;
fun unt1_switch (w, (acf::UNT1_CASETAG i32val, e) ! rest, default)
=>
e_branch (e_w32neq, w, e_unt1 i32val, unt1_switch (w, rest, default), e);
unt1_switch(_, NIL, default) => default;
unt1_switch _ => bug "switch.78";
end;
fun int1_switch (w, (acf::INT1_CASETAG i32val, e) ! r, default)
=>
{ int1to_unt1 = one_word_unt::from_multiword_int o one_word_int::to_multiword_int;
e_branch (e_i32neq, w, e_int1 (int1to_unt1 i32val),
int1_switch (w, r, default), e);
};
int1_switch(_, NIL, default) => default;
int1_switch _ => bug "switch.77";
end;
end; # fun improve_anormcode_switch_fn
}; # package improve_anormcode_switch_fn
end; # stipulate