Skip to content
GitLab
Commit e0cbd1f8 authored by Laszlo Domoszlai's avatar Laszlo Domoszlai
Browse files

+ faster way to check strictness 

+ faster way to check if thunk can be overwritten
+ check in the last two cases if arg is strict before evaluation
parent 47bcd535
Hide whitespace changes
Inline Side-by-side
interpreter/code.c
View file @ e0cbd1f8
......@@ -21,8 +21,9 @@ struct Thunk* create_thunk(Code* expr, int frame_ptr)
if (var->base.local_type == VAR_LOCAL)
{
Thunk* basethunk = eval(local(frame_ptr, var->index));
Thunk* basethunk = local(frame_ptr, var->index);
if(!var->base.strict) basethunk = eval(basethunk);
Desc* slice =
get_slice(basethunk->desc->type == FT_SLICE ?
((SliceEntry*) basethunk->desc)->forward_ptr : basethunk->desc, basethunk->desc->arity + expr->nr_args);
......@@ -83,8 +84,9 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
if (var->base.local_type == VAR_LOCAL)
{
Thunk* basethunk = eval(local(frame_ptr, var->index));
Thunk* basethunk = local(frame_ptr, var->index);
if(!var->base.strict) basethunk = eval(basethunk);
Desc* slice =
get_slice(basethunk->desc->type == FT_SLICE ?
((SliceEntry*) basethunk->desc)->forward_ptr : basethunk->desc, basethunk->desc->arity + expr->nr_args);
......@@ -107,10 +109,11 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
else if(slice->type == FT_FUN)
{
int new_frame_ptr = stack_top_a;
int argmask = 1;
for (int i = 0; i < basethunk->desc->arity; i++) {
if(is_strict_fun_arg((FunEntry*) slice, i))
if(((FunEntry*) slice)->strictness & argmask)
{
push_a(eval(basethunk->_args[i]));
}
......@@ -118,11 +121,13 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
{
push_a(basethunk->_args[i]);
}
argmask <<= 1;
}
for (int i = 0; i < expr->nr_args; i++) {
if(is_strict_fun_arg((FunEntry*) slice, basethunk->desc->arity + i))
if(((FunEntry*) slice)->strictness & argmask)
{
push_a(NULL);
exec(((AppEntry*) expr)->args[i], frame_ptr, stack_top_a);
......@@ -131,6 +136,8 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
{
push_a(create_thunk(((AppEntry*) expr)->args[i], frame_ptr));
}
argmask <<= 1;
}
expr = ((FunEntry*) slice)->body;
......@@ -176,10 +183,11 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
else if (slice->type == FT_FUN) {
int new_frame_ptr = stack_top_a;
int argmask = 1;
for (int i = 0; i < expr->nr_args; i++) {
if(is_strict_fun_arg((FunEntry*) slice, i))
if(((FunEntry*) slice)->strictness & argmask)
{
push_a(NULL);
exec(((AppEntry*) expr)->args[i], frame_ptr, stack_top_a);
......@@ -188,6 +196,8 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
{
push_a(create_thunk(((AppEntry*) expr)->args[i], frame_ptr));
}
argmask <<= 1;
}
expr = ((FunEntry*) slice)->body;
......@@ -239,9 +249,11 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
frame_ptr = stack_top_a;
// Here frame_ptr == root_frame_ptr
int argmask = 1;
for (int i = 0; i < thunk->desc->arity; i++) {
if(is_strict_fun_arg((FunEntry*) thunk->desc, i))
if(((FunEntry*) thunk->desc)->strictness & argmask)
{
push_a(eval(thunk->_args[i]));
}
......@@ -249,6 +261,8 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
{
push_a(thunk->_args[i]);
}
argmask <<= 1;
}
expr = ((FunEntry*) thunk->desc)->body;
......
interpreter/debug.h
View file @ e0cbd1f8
......@@ -2,7 +2,7 @@
#define DEBUG_H
//#define DEBUG
//#define BENCHMARK
#define BENCHMARK
#ifndef DEBUG
#define NDEBUG
......
interpreter/desc.c
View file @ e0cbd1f8
......@@ -39,11 +39,6 @@ Desc* get_slice(Desc* f, int nrargs) {
return &(((SliceEntry*) f)[-(f->arity - nrargs)].base);
}
bool is_strict_fun_arg(FunEntry* f, int nr_arg)
{
return (f->strictness & 1 << (f->base.arity - nr_arg - 1)) > 0;
}
FunEntry* alloc_prim(char* name) {
int len = strlen(name);
FunEntry* entry = (FunEntry*) alloc_desc(sizeof (FunEntry) + len + 1);
......
interpreter/desc.h
View file @ e0cbd1f8
......@@ -63,8 +63,6 @@ Desc* find_desc(char* fn);
Desc* get_slice(Desc* f, int nrargs);
bool is_strict_fun_arg(FunEntry* f, int nr_arg);
int printDesc(Desc* f);
extern struct FunEntry* __FORWARD_PTR__;
......
interpreter/thunk.c
View file @ e0cbd1f8
......@@ -19,17 +19,6 @@ Thunk* forward_to(Thunk* target, Thunk* thunk) {
return thunk;
}
int thunk_size(Thunk* thunk) {
assert(thunk != NULL);
if (thunk->desc == (Desc*) __STRING__ || thunk->desc == (Desc*) __ARRAY__) {
printf("thunk_size: unhandled literal type\n");
exit(-1);
}
return thunk->desc->thunk_size;
}
#ifdef DEBUG
int readI(Thunk* thunk) {
assert(thunk != NULL);
......@@ -91,7 +80,7 @@ struct Thunk* updateF(Thunk* target, Desc* f) {
if (thunk == NULL) {
thunk = (Thunk*) alloc_heap(newsize);
} else {
if (thunk_size(target) < newsize) {
if (target->desc->thunk_size < newsize) {
thunk = (Thunk*) alloc_heap(newsize);
target->desc = (Desc*) __FORWARD_PTR__;
target->_forward_ptr = thunk;
......@@ -133,9 +122,10 @@ struct Thunk* eval(Thunk* thunk) {
if (thunk->desc->type == FT_FUN) {
push_a(thunk);
int frame_ptr = stack_top_a;
int argmask = 1;
for (int i = 0; i < thunk->desc->arity; i++) {
if(is_strict_fun_arg((FunEntry*) thunk->desc, i))
if(((FunEntry*) thunk->desc)->strictness & argmask)
{
push_a(eval(thunk->_args[i]));
}
......@@ -143,6 +133,7 @@ struct Thunk* eval(Thunk* thunk) {
{
push_a(thunk->_args[i]);
}
argmask <<= 1;
}
exec(((FunEntry*) thunk->desc)->body, frame_ptr, frame_ptr);
thunk = pop_a();
......
precompiler/precompiler.icl
View file @ e0cbd1f8
......@@ -28,25 +28,25 @@ registerArgs vars idx [v:vs] = registerArgs (put (unpackVar v) (Local idx (isStr
registerLocals vars idx [] = vars
registerLocals vars idx [v:vs] = registerLocals (put (unpackVar v) (Local idx (isStrictVar v)) vars) (idx + 1) vs
calcStrictness [] = 0
calcStrictness [StrictVar _ _:vs] = (1 << (length vs)) + calcStrictness vs
calcStrictness [NormalVar _ _:vs] = calcStrictness vs
calcStrictness [] _ = 0
calcStrictness [StrictVar _ _:vs] idx = (1 << idx) + calcStrictness vs (idx + 1)
calcStrictness [NormalVar _ _:vs] idx = calcStrictness vs (idx + 1)
sFunc ctx (FTFunc name body params) a
# ctx = {ctx & vars = registerArgs ctx.vars 0 params, localcount = length params}
= a <++ "F" <++ sText (unpackVar name) <++ sNum (length params) <++ sNum (calcStrictness params) <++ sTerm ctx body
= a <++ "F" <++ sText (unpackVar name) <++ sNum (length params) <++ sNum (calcStrictness params 0) <++ sTerm ctx body
sFunc ctx (FTCAF name body) a
= a <++ "C" <++ sText (unpackVar name) <++ sTerm ctx body
sFunc ctx (FTRecord name fields) a
= a <++ "R" <++ sText (unpackVar name) <++ sNum (length fields) <++ sNum (calcStrictness fields) <++ sList0 sText (map unpackVar fields)
= a <++ "R" <++ sText (unpackVar name) <++ sNum (length fields) <++ sNum (calcStrictness fields 0) <++ sList0 sText (map unpackVar fields)
sFunc ctx (FTADT typeName cs) a
= a <++ "A" <++ sList sCon cs
where
sCon (SaplConstructor name _ params) a
= a <++ sText (unpackVar name) <++ sNum (length params) <++ sNum (calcStrictness params)
= a <++ sText (unpackVar name) <++ sNum (length params) <++ sNum (calcStrictness params 0)
sList f es a = a <++ sNum (length es) <++ sList0 f es
sList0 f [e] a = a <++ f e
......
Supports Markdown
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