Skip to content

GitLab

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

update to new SAPL

parent 298ff6ad
Expand all Hide whitespace changes
Inline Side-by-side
interpreter/code.c
View file @ ee8bda56
......@@ -15,6 +15,7 @@
#include "mem.h"
#include "desc.h"
#include "gc.h"
#include "prim.h"
// For compressing the source code a bit
......@@ -58,6 +59,7 @@ void create_thunk_app_static(Code* expr, Thunk** target, int frame_ptr)
assert(thunk->desc->arity == expr->nr_args);
for (int i = 0; i < expr->nr_args; i++) {
assert(((AppEntry*) expr)->args[i]->create_thunk != NULL);
((AppEntry*) expr)->args[i]->create_thunk(((AppEntry*) expr)->args[i], &thunk->_args[i], frame_ptr);
}
}
......@@ -121,6 +123,18 @@ void create_thunk_thunk(Code* expr, Thunk** target, int frame_ptr)
assert(!instackb(*target));
}
void create_thunk_select(Code* expr, Thunk** target, int frame_ptr)
{
Thunk* thunk = (Thunk*) alloc_heap(sizeof(AppEntry) + sizeof(Thunk*) * 2);
*target = thunk;
thunk->desc = (Desc*) selectDesc;
((SelectEntry*) expr)->expr->create_thunk(((SelectEntry*) expr)->expr, &thunk->_args[0], frame_ptr);
thunk->_args[1] = &((SelectEntry*) expr)->idx;
*target = thunk;
}
void set_create_thunk_fun(Code* code)
{
switch(code->type)
......@@ -147,10 +161,13 @@ void set_create_thunk_fun(Code* code)
case CT_THUNK:
code->create_thunk = create_thunk_thunk;
break;
case CT_SELECT_ADT:
case CT_SELECT_LIT:
case CT_SELECT_STR:
case CT_SELECT_REC:
case CT_SELECT:
code->create_thunk = create_thunk_select;
break;
case CT_CASE_ADT:
case CT_CASE_LIT:
case CT_CASE_STR:
case CT_CASE_REC:
case CT_IF:
case CT_LET:
code->create_thunk = NULL;
......@@ -320,7 +337,7 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
case CT_APP_FUN:
{
Desc* slice = ((AppEntry*) expr)->f;
int new_frame_ptr = stack_top_a;
int argmask = 1;
......@@ -421,9 +438,7 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
while(totalArity > baseDesc->arity)
{
// must be an FT_FUN
Desc* d = (*bt)->desc;
int remainingNrArgs = totalArity - baseDesc->arity;
slice = get_slice(baseDesc, baseDesc->arity);
......@@ -709,16 +724,16 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
destroy_stack_frame_b(root_frame_ptr_b);
return;
}
case CT_SELECT_LIT:
case CT_CASE_LIT:
{
placeholder();
exec(((SelectEntry*) expr)->expr, frame_ptr, stack_top_a);
exec(((CaseEntry*) expr)->expr, frame_ptr, stack_top_a);
Thunk* lit = pop_a();
bool handled = false;
for (int i = 0; i < expr->nr_cases; i++) {
SelectLitCaseEntry* caseEntry = &((SelectEntry*) expr)->cases[i];
CaseLitCaseEntry* caseEntry = &((CaseEntry*) expr)->cases[i];
// NULL means "default", we accept it anyway
if(caseEntry->lit != NULL)
......@@ -746,22 +761,44 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
if(handled) continue;
if(((SelectEntry*) expr)->fallback != NULL)
if(((CaseEntry*) expr)->fallback != NULL)
{
stack_top_a -= ((SelectEntry*) expr)->fallback_nrargs;
expr = ((SelectEntry*) expr)->fallback;
stack_top_a -= ((CaseEntry*) expr)->fallback_nrargs;
expr = ((CaseEntry*) expr)->fallback;
continue;
}
abort("no match");
}
case CT_SELECT_STR:
{
SelectEntry* select = (SelectEntry*) expr;
case CT_SELECT:
{
push_a(NULL);
exec(((SelectEntry*) expr)->expr, frame_ptr, stack_top_a);
Thunk* cons = pop_a();
push_a(cons->_args[((SelectEntry*) expr)->idx._int]);
peek_a()->desc->eval();
Thunk* ret = pop_a();
if(get_dst(root_frame_ptr) != NULL && ret->desc->thunk_size <= sizeof(Thunk))
{
memcpy(get_dst(root_frame_ptr), ret, sizeof(Thunk));
}
else
{
forward_thunk(ret, root_frame_ptr);
set_return(root_frame_ptr, ret);
}
destroy_stack_frame(root_frame_ptr);
destroy_stack_frame_b(root_frame_ptr_b);
return;
}
case CT_CASE_STR:
{
push_a(NULL);
exec(select->expr, frame_ptr, stack_top_a);
exec(((CaseEntry*) expr)->expr, frame_ptr, stack_top_a);
Thunk* str = pop_a();
int length;
......@@ -781,7 +818,7 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
bool handled = false;
for (int i = 0; i < expr->nr_cases; i++) {
SelectLitCaseEntry* caseEntry = &((SelectEntry*) expr)->cases[i];
CaseLitCaseEntry* caseEntry = &((CaseEntry*) expr)->cases[i];
// NULL means "default", we accept it anyway
if(caseEntry->lit != NULL)
......@@ -807,30 +844,30 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
if(handled) continue;
if(((SelectEntry*) expr)->fallback != NULL)
if(((CaseEntry*) expr)->fallback != NULL)
{
stack_top_a -= ((SelectEntry*) expr)->fallback_nrargs;
expr = ((SelectEntry*) expr)->fallback;
stack_top_a -= ((CaseEntry*) expr)->fallback_nrargs;
expr = ((CaseEntry*) expr)->fallback;
continue;
}
abort("no match");
}
case CT_SELECT_ADT:
case CT_CASE_ADT:
{
SelectEntry* select = (SelectEntry*) expr;
CaseEntry* caseEntry = (CaseEntry*) expr;
push_a(NULL);
exec(select->expr, frame_ptr, stack_top_a);
exec(caseEntry->expr, frame_ptr, stack_top_a);
Thunk* cons = pop_a();
expr = select->bodies[((ADTEntry*)cons->desc)->idx];
expr = caseEntry->bodies[((ADTEntry*)cons->desc)->idx];
if(expr != NULL)
{
// Skip the arguments in the case of a default
if(!(select->default_map & 1<<((ADTEntry*)cons->desc)->idx))
if(!(caseEntry->default_map & 1<<((ADTEntry*)cons->desc)->idx))
{
for (int i = 0; i < cons->desc->arity; i++) {
push_a(cons->_args[i]);
......@@ -840,25 +877,25 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
continue;
}
if(select->fallback != NULL)
if(caseEntry->fallback != NULL)
{
stack_top_a -= select->fallback_nrargs;
expr = select->fallback;
stack_top_a -= caseEntry->fallback_nrargs;
expr = caseEntry->fallback;
continue;
}
abort("no match");
}
case CT_SELECT_REC:
case CT_CASE_REC:
{
SelectEntry* select = (SelectEntry*) expr;
CaseEntry* caseEntry = (CaseEntry*) expr;
push_a(NULL);
exec(select->expr, frame_ptr, stack_top_a);
exec(caseEntry->expr, frame_ptr, stack_top_a);
Thunk* cons = pop_a();
expr = select->bodies[0];
expr = caseEntry->bodies[0];
if(expr != NULL)
{
......@@ -927,6 +964,7 @@ void eval_hnf()
void eval_fun()
{
Thunk* thunk = peek_a();
int frame_ptr = stack_top_a;
int argmask = 1;
......@@ -942,7 +980,7 @@ void eval_fun()
argmask <<= 1;
}
exec(((FunEntry*) thunk->desc)->body, frame_ptr, frame_ptr);
exec(((FunEntry*) thunk->desc)->body, frame_ptr, frame_ptr);
}
void eval_prim()
......
interpreter/code.h
View file @ ee8bda56
......@@ -15,10 +15,11 @@ enum CodeType {
CT_APP_FUN1,
CT_APP_FUN2,
CT_APP_FUN_TR, // tail recursive
CT_SELECT_ADT,
CT_SELECT_LIT,
CT_SELECT_STR,
CT_SELECT_REC, // Record field selection
CT_SELECT,
CT_CASE_ADT,
CT_CASE_LIT,
CT_CASE_STR,
CT_CASE_REC, // Record field selection
CT_IF,
CT_LET,
CT_THUNK // constant, always fits the B stack
......@@ -53,12 +54,18 @@ struct AppEntry {
struct Code* args[];
};
struct SelectLitCaseEntry {
struct SelectEntry {
struct Code base;
struct Code* expr;
Thunk idx;
};
struct CaseLitCaseEntry {
struct Code* body;
struct ThunkEntry* lit; // NULL -> default
};
struct SelectEntry {
struct CaseEntry {
struct Code base;
struct Code* expr;
......@@ -71,7 +78,7 @@ struct SelectEntry {
union
{
struct SelectLitCaseEntry cases[];
struct CaseLitCaseEntry cases[];
struct Code* bodies[];
};
};
......
interpreter/desc.c
View file @ ee8bda56
......@@ -3,6 +3,7 @@
#include <stdbool.h>
#include <assert.h>
#include "debug.h"
#include "desc.h"
#include "khash.h"
#include "mem.h"
......
interpreter/main.c
View file @ ee8bda56
......@@ -74,7 +74,7 @@ int main ( int argc, char *argv[] )
parse(&line, len);
input = "..\\tests\\static_os.bsapl";
input = "..\\tests\\jurrien.bsapl";
if ( argc == 2 )
{
......
interpreter/parse.c
View file @ ee8bda56
......@@ -511,13 +511,13 @@ Code* parseApp(char **ptr, bool dynamic, bool tr) {
}
}
SelectEntry* parseSelect(char **ptr, Code* fallback, int fallback_nrargs) {
CaseEntry* parseCase(char **ptr, Code* fallback, int fallback_nrargs) {
Code* expr = parseTerm(ptr);
int nrCases;
if (!parseInt(ptr, &nrCases)) return 0;
struct SelectEntry* entry = NULL;
struct CaseEntry* entry = NULL;
char type = **ptr;
......@@ -556,11 +556,11 @@ SelectEntry* parseSelect(char **ptr, Code* fallback, int fallback_nrargs) {
Code* firstBody = (Code*) parseFallbackBody(ptr, child_fallback,
child_fallback_base_nrargs + firstCase->arity);
entry = (SelectEntry*) alloc_code(sizeof (SelectEntry) + sizeof (Code*) * nrConses);
entry = (CaseEntry*) alloc_code(sizeof (CaseEntry) + sizeof (Code*) * nrConses);
if(firstCase->type == FT_ADT)
{
entry->base.type = CT_SELECT_ADT;
entry->base.type = CT_CASE_ADT;
entry->base.nr_cases = nrConses;
entry->default_map = 0xFFFFFFFF;
......@@ -585,15 +585,15 @@ SelectEntry* parseSelect(char **ptr, Code* fallback, int fallback_nrargs) {
}
else
{
entry->base.type = CT_SELECT_REC;
entry->base.type = CT_CASE_REC;
entry->base.nr_cases = 1;
entry->bodies[0] = firstBody;
}
}
else
{
entry = (SelectEntry*) alloc_code(sizeof (SelectEntry) + sizeof (SelectLitCaseEntry) * nrCases);
entry->base.type = CT_SELECT_LIT;
entry = (CaseEntry*) alloc_code(sizeof (CaseEntry) + sizeof (CaseLitCaseEntry) * nrCases);
entry->base.type = CT_CASE_LIT;
entry->base.nr_cases = nrCases;
if(isDefault)
......@@ -610,7 +610,7 @@ SelectEntry* parseSelect(char **ptr, Code* fallback, int fallback_nrargs) {
// String literal is the third case for efficiency reasons
if(i == 0 && entry->cases[i].lit->thunk.desc == (Desc*) __STRING_PTR__)
{
entry->base.type = CT_SELECT_STR;
entry->base.type = CT_CASE_STR;
}
entry->cases[i].body = (Code*) parseFallbackBody(ptr, child_fallback, child_fallback_base_nrargs);
......@@ -640,10 +640,10 @@ Code* parseFallbackBody(char **ptr, Code* fallback, int fallback_nrargs) {
char type = **ptr;
if(type == 'S')
if(type == 'C')
{
(*ptr)++;
return (Code*) parseSelect(ptr, fallback, fallback_nrargs);
return (Code*) parseCase(ptr, fallback, fallback_nrargs);
}
else if(type == 'I')
{
......@@ -656,6 +656,18 @@ Code* parseFallbackBody(char **ptr, Code* fallback, int fallback_nrargs) {
}
}
SelectEntry* parseSelect(char **ptr) {
struct SelectEntry* entry = (SelectEntry*) alloc_code(sizeof (SelectEntry));
entry->expr = parseTerm(ptr);
entry->base.type = CT_SELECT;
entry->idx.desc = (Desc*) __INT__;
if (!parseInt(ptr, &entry->idx._int)) return 0;
set_create_thunk_fun((Code*) entry);
return entry;
}
LetEntry* parseLet(char **ptr) {
Code* body = parseTerm(ptr);
......@@ -713,7 +725,9 @@ Code* parseTerm(char **ptr) {
case 'D': // Dynamic application
return (Code*) parseApp(ptr, true, false);
case 'S': // Select
return (Code*) parseSelect(ptr, NULL, 0);
return (Code*) parseSelect(ptr);
case 'C': // Case
return (Code*) parseCase(ptr, NULL, 0);
case 'I': // If
return (Code*) parseIf(ptr, NULL, 0);
case 'E': // Let
......
interpreter/prim.c
View file @ ee8bda56
......@@ -372,6 +372,7 @@ void __array_select(int dst_idx)
int pos = readI(arg(1));
Thunk* elem = arr->_array._elems[pos];
elem->desc->eval();
if(target != NULL)
{
......@@ -583,55 +584,90 @@ void __string_update_copy(int dst_idx)
void __string_update(int dst_idx)
{
Thunk* target = get_dst(dst_idx);
Thunk* arr = arg(3);
int idx = readI(arg(2));
char elem = readC(arg(1));
arr->_array._chars[idx] = (char) elem;
if(target != NULL)
{
target->desc = (Desc*) __FORWARD_PTR__;
target->_forward_ptr = arr;
}
set_return(dst_idx, arr);
}
void __array_update(int dst_idx)
{
Thunk* target = get_dst(dst_idx);
Thunk* arr = arg(3);
int idx = readI(arg(2));
Thunk* elem = arg(1);
arr->_array._elems[idx] = elem;
if(target != NULL)
{
target->desc = (Desc*) __FORWARD_PTR__;
target->_forward_ptr = arr;
}
set_return(dst_idx, arr);
}
void __array_update_b_i(int dst_idx)
{
Thunk* target = get_dst(dst_idx);
Thunk* arr = arg(3);
int idx = readI(arg(2));
int elem = readI(arg(1));
arr->_array._ints[idx] = elem;
if(target != NULL)
{
target->desc = (Desc*) __FORWARD_PTR__;
target->_forward_ptr = arr;
}
set_return(dst_idx, arr);
}
void __array_update_b_b(int dst_idx)
{
Thunk* target = get_dst(dst_idx);
Thunk* arr = arg(3);
int idx = readI(arg(2));
int elem = readB(arg(1));
arr->_array._bools[idx] = (unsigned char) elem;
if(target != NULL)
{
target->desc = (Desc*) __FORWARD_PTR__;
target->_forward_ptr = arr;
}
set_return(dst_idx, arr);
}
void __array_update_b_r(int dst_idx)
{
Thunk* target = get_dst(dst_idx);
Thunk* arr = arg(3);
int idx = readI(arg(2));
double elem = readR(arg(1));
arr->_array._reals[idx] = elem;
if(target != NULL)
{
target->desc = (Desc*) __FORWARD_PTR__;
target->_forward_ptr = arr;
}
set_return(dst_idx, arr);
}
......@@ -874,7 +910,27 @@ void __abort(int dst_idx)
exit(-1);
}
void add_prim(int arity, int boxingMap, int unboxableReturn, char* name, void (*exec)(int)) {
void __select(int dst_idx)
{
Thunk* target = get_dst(dst_idx);
Thunk* cons = arg(2);
int idx = readI(arg(1));
push_a(cons->_args[idx]);
cons->_args[idx]->desc->eval();
Thunk* ret = pop_a();
if(target != NULL)
{
target->desc = (Desc*) __FORWARD_PTR__;
target->_forward_ptr = ret;
}
set_return(dst_idx, ret);
}
PrimEntry* add_prim(int arity, int boxingMap, int unboxableReturn, char* name, void (*exec)(int)) {
int nameLength = strlen(name);
// before the PrimEntry there are "arity" number of SliceEntries
......@@ -897,6 +953,7 @@ void add_prim(int arity, int boxingMap, int unboxableReturn, char* name, void (
if (arity > 0) gen_slices(entry_base, (Desc*) entry, arity);
add_desc(entry->name, (Desc*) entry);
return entry;
}
void init_prim() {
......@@ -995,4 +1052,9 @@ void init_prim() {
add_prim(1, 0b000, 0, "_trace", &__trace);
add_prim(1, 0b000, 0, "abort", &__abort);
selectDesc = add_prim(2, 0b001, 0, "_select", &__select);
}
// For lazy select
PrimEntry* selectDesc;
interpreter/prim.h
View file @ ee8bda56
#ifndef __PRIM_H
#define __PRIM_H
#include "desc.h"
void init_prim();
extern PrimEntry* selectDesc;
#endif // __PRIM_H
\ No newline at end of file
interpreter/thunk.h
View file @ ee8bda56
#ifndef __THUNK_H
#define __THUNK_H
#include "debug.h"
#include "desc_base.h"
#define max(a,b) \
......
precompiler/precompiler.icl
View file @ ee8bda56
......@@ -3,7 +3,9 @@ module precompiler
import Sapl.SaplParser
import Sapl.SaplTokenizer
import Sapl.Transform.Let
import Sapl.Optimization.StrictnessPropagation
import Sapl.Transform.AddSelectors
import Lifting, Prims
import StdBool, StdList, StdOrdList, StdFile, StdFunc, StdArray, StdDebug
import Text.StringAppender, Text
......@@ -15,6 +17,7 @@ from Text.Unicode.UChar import instance toChar UChar, instance toInt UChar
import System.CommandLine
import System.File
:: TypeInfo = Normal | Strict | UnBoxable
:: VarType = Local Int TypeInfo
......@@ -25,10 +28,10 @@ import System.File
}
// Fusion of function applications for some very basic cases
simplify (SApplication var1 [SApplication var2 args]) | unpackVar var1 == "not" && unpackVar var2 == "eqI"
= SApplication (NormalVar "neqI" 0) args
simplify (SApplication var1 [SApplication var2 args]) | unpackVar var1 == "not" && unpackVar var2 == "ltI"
= SApplication (NormalVar "geI" 0) args
simplify (SApplication (SVar var1) [SApplication (SVar var2) args]) | unpackVar var1 == "not" && unpackVar var2 == "eqI"
= SApplication (SVar (NormalVar "neqI" 0)) args
simplify (SApplication (SVar var1) [SApplication (SVar var2) args]) | unpackVar var1 == "not" && unpackVar var2 == "ltI"
= SApplication (SVar (NormalVar "geI" 0)) args
simplify x = x
unBoxableType (Type "I") = True
......@@ -63,7 +66,7 @@ sFunc ctx (FTFunc name body params) a
# 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
<++ sTerm ctx (addSelectors body)
sFunc ctx (FTCAF name body) a
# ctx = {ctx & inspine = False, currentFun = (unpackVar name)}
......@@ -94,9 +97,13 @@ sTerm ctx t a = sTermS ctx (simplify t) a
where
sTermS ctx (SLit lit) a = a <++ "L" <++ lit
sTermS ctx (SVar var) a = a <++ sVarApp ctx var
sTermS ctx (SApplication var terms) a = a <++ appType ctx var <++ sNum (length terms) <++ sVar ctx var <++ sList0 (sTerm {ctx & inspine = False}) terms
sTermS ctx (SSelect expr cs) a = a <++ "S" <++ sTerm {ctx & inspine = False