Commit 4f6c6a9b authored by Laszlo Domoszlai's avatar Laszlo Domoszlai
Browse files

basic LET support (LETREC is broken yet)

parent ae8d3929
......@@ -141,6 +141,7 @@ void set_create_thunk_fun(Code* code)
case CT_SELECT_ADT:
case CT_SELECT_LIT:
case CT_IF:
case CT_LET:
code->create_thunk = NULL;
break;
}
......@@ -586,6 +587,27 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
continue;
}
}
case CT_LET:
{
for(int i=0; i<expr->nr_bindings; i++)
{
LetBindingEntry* binding = ((LetEntry*) expr)->bindings[i];
// Normal
if(binding->type == 0)
{
push_a(binding->body->create_thunk(binding->body, frame_ptr));
}
else // strict (including unboxed))
{
push_a(NULL);
exec(binding->body, frame_ptr, stack_top_a);
}
}
expr = ((LetEntry*) expr)->body;
continue;
}
}
}
}
......
......@@ -9,7 +9,7 @@ enum CodeType {
CT_APP_PRIM2,
CT_APP_THUNK, CT_APP_DYN,
CT_APP_FUN, CT_APP_FUN1, CT_APP_FUN2,
CT_SELECT_ADT, CT_SELECT_LIT, CT_IF,
CT_SELECT_ADT, CT_SELECT_LIT, CT_IF, CT_LET,
CT_THUNK
};
......@@ -17,6 +17,7 @@ struct Code {
CodeType type : 5;
unsigned int nr_args : 5; // used in AppEntry
unsigned int nr_cases : 5; // used in SelectEntry
unsigned int nr_bindings : 8; // used in LetEntry
unsigned int strict : 1; // used in VarEntry
unsigned int arg_pattern : 3;
struct Thunk* (*create_thunk)(Code*, int);
......@@ -68,6 +69,17 @@ struct IfEntry {
struct Code* fexpr;
};
struct LetBindingEntry {
struct Code* body;
int type; // 0 - normal, 1 - strict, 2 - unboxable
};
struct LetEntry {
struct Code base;
struct Code* body;
struct LetBindingEntry* bindings[];
};
typedef Thunk* (*create_thunk_fun)(Code*, int);
void set_create_thunk_fun(Code* code);
......
#ifndef DEBUG_H
#define DEBUG_H
//#define DEBUG
//#define BENCHMARK
#define DEBUG
#define BENCHMARK
#ifndef DEBUG
#define NDEBUG
......
......@@ -574,7 +574,46 @@ IfEntry* parseIf(char **ptr) {
set_create_thunk_fun((Code*) entry);
return entry;
}
LetEntry* parseLet(char **ptr) {
Code* body = parseTerm(ptr);
int nrBindings;
if (!parseInt(ptr, &nrBindings)) return 0;
struct LetEntry* entry = (LetEntry*) alloc_code(sizeof (LetEntry) + sizeof (Code*) * nrBindings);
entry->base.type = CT_LET;
entry->base.nr_bindings = nrBindings;
entry->body = body;
for(int i=0; i<nrBindings; i++)
{
struct LetBindingEntry* binding = (LetBindingEntry*) alloc_code(sizeof (LetBindingEntry));
char typeChar = *(*ptr)++;
switch (typeChar) {
case 'L': // Local var
binding->type = 0;
break;
case 'S': // Strict local var
binding->type = 1;
break;
case 'U': // Strict unboxable var
binding->type = 2;
break;
default:
return 0;
}
binding->body = parseTerm(ptr);
entry->bindings[i] = binding;
}
set_create_thunk_fun((Code*) entry);
return entry;
}
Code* parseTerm(char **ptr) {
// 1. Type char
char type = *(*ptr)++;
......@@ -594,6 +633,8 @@ Code* parseTerm(char **ptr) {
return (Code*) parseSelect(ptr, NULL, 0);
case 'I': // If
return (Code*) parseIf(ptr);
case 'E': // Let
return (Code*) parseLet(ptr);
default:
printf("parseTerm: unhandled term type\n");
exit(-1);
......
......@@ -47,11 +47,8 @@ typeInfo (TypedVar (StrictVar _ _) type) | unBoxableType type
typeInfo _ = Normal
registerArgs vars idx [] = vars
registerArgs vars idx [v:vs] = registerArgs (put (unpackVar v) (Local idx (typeInfo v)) vars) (idx + 1) vs
registerLocals vars idx [] = vars
registerLocals vars idx [v:vs] = registerLocals (put (unpackVar v) (Local idx (typeInfo v)) vars) (idx + 1) vs
registerVars vars idx [] = vars
registerVars vars idx [v:vs] = registerVars (put (unpackVar v) (Local idx (typeInfo v)) vars) (idx + 1) vs
calcStrictness [] _ = 0
calcStrictness [TypedVar (StrictVar _ _) _:vs] idx = (1 << idx) + calcStrictness vs (idx + 1)
......@@ -62,7 +59,7 @@ calcBoxing [TypedVar (StrictVar _ _) type:vs] idx | unBoxableType type = (1 << i
calcBoxing [_:vs] idx = calcBoxing vs (idx + 1)
sFunc ctx (FTFunc name body params) a
# ctx = {ctx & vars = registerArgs ctx.vars 0 params, localcount = length params, inspine = True, currentFun = (unpackVar name)}
# ctx = {ctx & vars = registerVars ctx.vars 0 params, localcount = length params, inspine = True, currentFun = (unpackVar name)}
= a <++ "F" <++ sText (unpackVar name) <++ sNum (length params)
<++ sNum (calcStrictness params 0) <++ sNum (calcBoxing params 0)
<++ sTerm ctx body
......@@ -99,6 +96,9 @@ where
sTermS ctx (SApplication var terms) a = a <++ appType ctx var <++ sList (sTerm {ctx & inspine = False}) terms <++ sVar ctx var
sTermS ctx (SSelect expr cs) a = a <++ "S" <++ sTerm {ctx & inspine = False} expr <++ sList (sSelectCase ctx) (sortBy selectCaseOrder cs)
sTermS ctx (SIf cond texpr fexpr) a = a <++ "I" <++ sTerm {ctx & inspine = False} cond <++ sTerm ctx texpr <++ sTerm ctx fexpr
sTermS ctx (SLet body bindings) a
# ctx = {ctx & vars = registerVars ctx.vars ctx.localcount (map unpackBindVar bindings), localcount = ctx.localcount + length bindings}
= a <++ "E" <++ sTerm ctx body <++ sList (sLetDef {ctx & inspine = False}) bindings
isLocalVar ctx var = member (unpackVar var) ctx.vars
......@@ -106,31 +106,35 @@ appType ctx var | isLocalVar ctx var
= "D"
appType {inspine, currentFun} var = if (inspine && unpackVar var == currentFun) "T" "A" // T: tail recursive
sLetDef ctx (SaplLetDef var binding) a = a <++ sVarFlag ctx (Local 0 (typeInfo var)) <++ sTerm ctx binding
// TODO: find constructor for strictness info
sSelectCase ctx (PCons varName params, expr) a
# ctx = {ctx & vars = registerLocals ctx.vars ctx.localcount (map (\p->TypedVar p NoType) params), localcount = ctx.localcount + length params}
# ctx = {ctx & vars = registerVars ctx.vars ctx.localcount (map (\p->TypedVar p NoType) params), localcount = ctx.localcount + length params}
= a <++ "C" <++ sText varName <++ sTerm ctx expr
sSelectCase ctx (PLit lit, expr) a
= a <++ "L" <++ lit <++ sTerm ctx expr
sSelectCase ctx (PDefault, expr) a
= a <++ "D" <++ sTerm ctx expr
sVarFlag ctx var a
= case var of
(Local i Strict) = a <++ "S"
(Local i UnBoxable) = a <++ "U"
(Local i Normal) = a <++ "L"
sVar ctx var a
= case get varName ctx.vars of
(Just (Local i Strict)) = a <++ "S" <++ sNum i
(Just (Local i UnBoxable)) = a <++ "U" <++ sNum i
(Just (Local i Normal)) = a <++ "L" <++ sNum i
_ = a <++ "F" <++ sText varName
(Just l=:(Local i _)) = a <++ sVarFlag ctx l <++ sNum i
_ = a <++ "F" <++ sText varName
where
varName = unpackVar var
sVarApp ctx var a
= case get varName ctx.vars of
(Just (Local i Strict)) = a <++ "VS" <++ sNum i
(Just (Local i UnBoxable)) = a <++ "VU" <++ sNum i
(Just (Local i Normal)) = a <++ "VL" <++ sNum i
_ = a <++ "A" <++ sList (sTerm ctx) [] <++ sVar ctx var
(Just l=:(Local i _)) = a <++ "V" <++ sVarFlag ctx l <++ sNum i
_ = a <++ "A" <++ sList (sTerm ctx) [] <++ sVar ctx var
where
varName = unpackVar var
......
[13]
\ No newline at end of file
main = lettests.Start
lettests.Start::I = lettests.test1
lettests.test1::I = let x = addI 1 2, y = addI 4 6 in addI x y
[30]
\ No newline at end of file
main = lettests.Start
lettests.Start::I = lettests.test2 2 4
lettests.test2::I !x_0::I !y_1::I = let r = 3, s = 6 in addI (multI r x_0) (multI s y_1)
[30]
\ No newline at end of file
main = lettests.Start
lettests.Start::I = lettests.test3 2 4
lettests.test3::I !x_0::I !y_1::I = let r = multI 3 x_0, s = multI 6 y_1 in addI r s
[438]
\ No newline at end of file
main = lettests.Start
lettests.Start::I = lettests.test4 2 4
lettests.test4::I !x_0::I !y_1::I = let r_1_0 = multI 3 x_0, s_1_1 = multI (multI 6 y_1) r_1_0 in addI (addI r_1_0 s_1_1) (multI 2 s_1_1)
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