Commit d20a7c78 authored by Laszlo Domoszlai's avatar Laszlo Domoszlai
Browse files

select fallback

parent b5b61142
......@@ -532,17 +532,27 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
if(handled) continue;
not_implemented("fallback");
if(((SelectEntry*) expr)->fallback != NULL)
{
stack_top_a -= ((SelectEntry*) expr)->fallback_nrargs;
expr = ((SelectEntry*) expr)->fallback;
continue;
}
abort("no match");
}
case CT_SELECT_ADT:
{
SelectEntry* select = (SelectEntry*) expr;
Thunk* cons = alloc_b();
cons->desc = (Desc*) __INT__;
cons->desc = (Desc*) __STACK_PLACEHOLDER__;
push_a(cons);
exec(((SelectEntry*) expr)->expr, frame_ptr, stack_top_a);
exec(select->expr, frame_ptr, stack_top_a);
cons = pop_a();
expr = ((SelectEntry*) expr)->bodies[((ADTEntry*)cons->desc)->idx];
expr = select->bodies[((ADTEntry*)cons->desc)->idx];
if(expr != NULL)
{
......@@ -553,7 +563,15 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
continue;
}
not_implemented("fallback");
if(select->fallback != NULL)
{
stack_top_a -= select->fallback_nrargs;
expr = select->fallback;
continue;
}
abort("no match");
}
case CT_IF:
{
......
......@@ -49,6 +49,10 @@ struct SelectEntry {
struct Code base;
struct Code* expr;
struct Code* fallback;
// how many arguments to be removed from the stack in the case of fallback
int fallback_nrargs;
union
{
struct SelectLitCaseEntry cases[];
......
......@@ -305,6 +305,7 @@ VarEntry* parseVar(char **ptr, VarEntry* target) {
}
Code* parseTerm(char **ptr);
Code* parseSelectBody(char **ptr, Code* fallback, int fallback_nrargs);
/*
* It is very messy, because it handles 3 cases:
......@@ -436,7 +437,7 @@ Code* parseApp(char **ptr, bool dynamic) {
return (Code*) entry;
}
SelectEntry* parseSelect(char **ptr) {
SelectEntry* parseSelect(char **ptr, Code* fallback, int fallback_nrargs) {
Code* expr = parseTerm(ptr);
int nrCases;
......@@ -455,10 +456,14 @@ SelectEntry* parseSelect(char **ptr) {
isDefault = true;
(*ptr)++;
defaultBody = (Code*) parseTerm(ptr);
defaultBody = (Code*) parseSelectBody(ptr, fallback, fallback_nrargs);
type = **ptr;
}
// If there is no default here, use the parent fallback
Code* child_fallback = isDefault ? defaultBody : fallback;
int child_fallback_base_nrargs = isDefault ? 0 : fallback_nrargs;
bool isADT = type == 'C';
if(isADT)
......@@ -466,12 +471,12 @@ SelectEntry* parseSelect(char **ptr) {
(*ptr)++;
ADTEntry* firstCase = (ADTEntry*) parseFunName(ptr);
Code* firstBody = (Code*) parseTerm(ptr);
Code* firstBody = (Code*) parseSelectBody(ptr, child_fallback,
child_fallback_base_nrargs + firstCase->base.arity);
entry = (SelectEntry*) alloc_code(sizeof (SelectEntry) + sizeof (Code*) * firstCase->nrConses);
entry->base.type = CT_SELECT_ADT;
entry->base.nr_cases = firstCase->nrConses;
entry->expr = expr;
// set the default case for all the entries
for (int i = 0; i < firstCase->nrConses; i++) {
......@@ -486,7 +491,8 @@ SelectEntry* parseSelect(char **ptr) {
for (int i = 0; i < nrCases; i++) {
(*ptr)++; // skip type
ADTEntry* nextCase = (ADTEntry*) parseFunName(ptr);
entry->bodies[nextCase->idx] = (Code*) parseTerm(ptr);
entry->bodies[nextCase->idx] = (Code*) parseSelectBody(ptr, child_fallback,
child_fallback_base_nrargs + nextCase->base.arity);
}
}
else
......@@ -494,7 +500,6 @@ SelectEntry* parseSelect(char **ptr) {
entry = (SelectEntry*) alloc_code(sizeof (SelectEntry) + sizeof (SelectLitCaseEntry) * nrCases);
entry->base.type = CT_SELECT_LIT;
entry->base.nr_cases = nrCases;
entry->expr = expr;
if(isDefault)
{
......@@ -506,14 +511,33 @@ SelectEntry* parseSelect(char **ptr) {
for (int i = 0; i < nrCases; i++) {
(*ptr)++; // skip type
entry->cases[i].lit = parseLit(ptr);
entry->cases[i].body = (Code*) parseTerm(ptr);
entry->cases[i].body = (Code*) parseSelectBody(ptr, child_fallback, child_fallback_base_nrargs);
}
}
entry->expr = expr;
entry->fallback = fallback;
entry->fallback_nrargs = fallback_nrargs;
set_create_thunk_fun((Code*) entry);
return entry;
}
Code* parseSelectBody(char **ptr, Code* fallback, int fallback_nrargs) {
char type = **ptr;
if(type == 'S')
{
(*ptr)++;
return (Code*) parseSelect(ptr, fallback, fallback_nrargs);
}
else
{
return parseTerm(ptr);
}
}
IfEntry* parseIf(char **ptr) {
struct IfEntry* entry = (IfEntry*) alloc_code(sizeof (IfEntry));
entry->base.type = CT_IF;
......@@ -524,7 +548,7 @@ IfEntry* parseIf(char **ptr) {
set_create_thunk_fun((Code*) entry);
return entry;
}
Code* parseTerm(char **ptr) {
// 1. Type char
char type = *(*ptr)++;
......@@ -541,7 +565,7 @@ Code* parseTerm(char **ptr) {
case 'D': // Dynamic application
return (Code*) parseApp(ptr, true);
case 'S': // Select
return (Code*) parseSelect(ptr);
return (Code*) parseSelect(ptr, NULL, 0);
case 'I': // If
return (Code*) parseIf(ptr);
default:
......
main = Sprimes.Start
Sprimes.Start = Sprimes.domain Sprimes.h280
Sprimes.h280 = Sprimes.add Sprimes.h200 Sprimes.eighty
Sprimes.eighty = Sprimes.add Sprimes.forty Sprimes.forty
Sprimes.forty = Sprimes.add Sprimes.twenty Sprimes.twenty
Sprimes.twenty = Sprimes.add Sprimes.ten Sprimes.ten
Sprimes.ten = Sprimes.add Sprimes.five Sprimes.five
Sprimes.five = Sprimes.Suc (Sprimes.Suc (Sprimes.Suc (Sprimes.Suc (Sprimes.Suc Sprimes.Zero))))
:: Sprimes.Natn = Sprimes.Zero | Sprimes.Suc a1
Sprimes.add !_x_0 m_1 = select _x_0 (Sprimes.Zero -> m_1) (Sprimes.Suc n_1_0 -> Sprimes.Suc (Sprimes.add n_1_0 m_1))
Sprimes.h200 = Sprimes.add Sprimes.h60 Sprimes.forty
Sprimes.h60 = Sprimes.add Sprimes.eighty Sprimes.eighty
Sprimes.domain !n_0 = Sprimes.mkeNum (Sprimes.el n_0 Sprimes.primes)
Sprimes.primes = Sprimes.sieve (Sprimes.fr Sprimes.two)
Sprimes.two = Sprimes.Suc (Sprimes.Suc Sprimes.Zero)
Sprimes.fr n_0 = Sprimes.Cons n_0 (Sprimes.fr (Sprimes.Suc n_0))
:: Sprimes.MList = Sprimes.Cons a1 a2 | Sprimes.Empty
Sprimes.sieve !_x_0 = select _x_0 (Sprimes.Cons x_1_0 xs_1_1 -> Sprimes.Cons x_1_0 (Sprimes.sieve (Sprimes.fil (Sprimes.notmodzero x_1_0) xs_1_1)))
Sprimes.notmodzero !x_0 y_1 = Sprimes.ifte (Sprimes.eq (Sprimes.mmod y_1 x_0) Sprimes.Zero) False True
Sprimes.mmod n_0 !m_1 = Sprimes.ifte (Sprimes.gt m_1 n_0) n_0 (Sprimes.mmod (Sprimes.sub n_0 m_1) m_1)
Sprimes.sub !n_0 !_x_1 = select _x_1 (Sprimes.Zero -> n_0) (Sprimes.Suc m_1_0 -> Sprimes.prd (Sprimes.sub n_0 m_1_0))
Sprimes.prd !_x_0 = select _x_0 (Sprimes.Suc n_1_0 -> n_1_0)
Sprimes.gt !_x_0 n_1 = select _x_0 (Sprimes.Zero -> False) (Sprimes.Suc n_1_0 -> select n_1 (Sprimes.Zero -> True) (Sprimes.Suc m_2_0 -> Sprimes.gt n_1_0 m_2_0) )
Sprimes.ifte !b_0 e_1 t_2 = if b_0 e_1 t_2
Sprimes.eq !_x_0 _x_1 = select _x_0 (Sprimes.Zero -> select _x_1 (Sprimes.Zero -> True) ) (Sprimes.Suc n_1_0 -> select _x_1 (Sprimes.Suc m_2_0 -> Sprimes.eq n_1_0 m_2_0) ) (_ -> False)
Sprimes.fil p_0 !_x_1 = select _x_1 (Sprimes.Empty -> Sprimes.Empty) (Sprimes.Cons a_1_0 as_1_1 -> if (p_0 a_1_0) (Sprimes.Cons a_1_0 (Sprimes.fil p_0 as_1_1)) (Sprimes.fil p_0 as_1_1))
Sprimes.el !_x_0 !_x_1 = select _x_0 (Sprimes.Zero -> select _x_1 (Sprimes.Cons a_2_0 as_2_1 -> a_2_0) ) (Sprimes.Suc n_1_0 -> select _x_1 (Sprimes.Cons a_2_0 as_2_1 -> Sprimes.el n_1_0 as_2_1) )
Sprimes.mkeNum !_x_0 = select _x_0 (Sprimes.Zero -> 0) (Sprimes.Suc n_1_0 -> add 1 (Sprimes.mkeNum n_1_0))
[1823]
\ No newline at end of file
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment