conservatory
/
picrin
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

optimize var implementation

This commit is contained in:
Yuichi Nishiwaki 2015-06-08 22:28:17 +09:00
parent 5def1df320
commit 53a9e72413
10 changed files with 116 additions and 96 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
contrib/03.callcc/callcc.c
View File

@ -21,6 +21,8 @@ struct pic_fullcont {
pic_code *ip;
pic_value ptable;
struct pic_object **arena;
size_t arena_size;
int arena_idx;
@ -83,6 +85,9 @@ cont_mark(pic_state *pic, void *data, void (*mark)(pic_state *, pic_value))
mark(pic, pic_obj_value(cont->arena[i]));
}
/* parameter table */
mark(pic, cont->ptable);
/* result values */
mark(pic, cont->results);
}
@ -144,6 +149,8 @@ save_cont(pic_state *pic, struct pic_fullcont **c)
cont->ip = pic->ip;
cont->ptable = pic->ptable;
cont->arena_idx = pic->arena_idx;
cont->arena_size = pic->arena_size;
cont->arena = pic_malloc(pic, sizeof(struct pic_object *) * pic->arena_size);
@ -195,6 +202,8 @@ restore_cont(pic_state *pic, struct pic_fullcont *cont)
pic->ip = cont->ip;
pic->ptable = cont->ptable;
pic->arena = pic_realloc(pic, pic->arena, sizeof(struct pic_object *) * cont->arena_size);
memcpy(pic->arena, cont->arena, sizeof(struct pic_object *) * cont->arena_size);
pic->arena_size = cont->arena_size;

56
extlib/benz/boot.c
View File

@ -306,30 +306,15 @@ my $src = <<'EOL';
`(,(r 'begin) ,@(cdr clause)))
,(loop (cdr clauses)))))))))))
(define (dynamic-bind parameters values body)
(let* ((old-bindings
(current-dynamic-environment))
(binding
(map (lambda (parameter value)
(cons parameter (parameter value #f)))
parameters
values))
(new-bindings
(cons binding old-bindings)))
(dynamic-wind
(lambda () (current-dynamic-environment new-bindings))
body
(lambda () (current-dynamic-environment old-bindings)))))
(define-syntax parameterize
(er-macro-transformer
(lambda (form r compare)
(let ((formal (cadr form))
(body (cddr form)))
`(,(r 'dynamic-bind)
(list ,@(map car formal))
(list ,@(map cadr formal))
(,(r 'lambda) () ,@body))))))
`(,(r 'with-parameter)
(lambda ()
,@formal
,@body))))))
(define-syntax letrec-syntax
(er-macro-transformer
@ -538,26 +523,19 @@ const char pic_boot[][80] = {
" (car clause))))\n ,(if (compare (r '=>) (list-ref cla",
"use 1))\n `(,(list-ref clause 2) ,(r 'key))\n ",
" `(,(r 'begin) ,@(cdr clause)))\n ,(loop (",
"cdr clauses)))))))))))\n\n (define (dynamic-bind parameters values body)\n (let",
"* ((old-bindings\n (current-dynamic-environment))\n (binding\n",
" (map (lambda (parameter value)\n (cons parameter (p",
"arameter value #f)))\n parameters\n values))\n ",
" (new-bindings\n (cons binding old-bindings)))\n (dynamic-win",
"d\n (lambda () (current-dynamic-environment new-bindings))\n bod",
"y\n (lambda () (current-dynamic-environment old-bindings)))))\n\n (define",
"-syntax parameterize\n (er-macro-transformer\n (lambda (form r compare)\n ",
" (let ((formal (cadr form))\n (body (cddr form)))\n `(,(r '",
"dynamic-bind)\n (list ,@(map car formal))\n (list ,@(map cadr ",
"formal))\n (,(r 'lambda) () ,@body))))))\n\n (define-syntax letrec-synta",
"x\n (er-macro-transformer\n (lambda (form r c)\n (let ((formal (car (c",
"dr form)))\n (body (cdr (cdr form))))\n `(let ()\n ",
" ,@(map (lambda (x)\n `(,(r 'define-syntax) ,(car x) ,(cadr x",
")))\n formal)\n ,@body)))))\n\n (define-syntax let-syn",
"tax\n (er-macro-transformer\n (lambda (form r c)\n `(,(r 'letrec-synta",
"x) ,@(cdr form)))))\n\n (export let let* letrec letrec*\n let-values let*",
"-values define-values\n quasiquote unquote unquote-splicing\n an",
"d or\n cond case else =>\n do when unless\n parameterize",
"\n let-syntax letrec-syntax\n syntax-error))\n\n",
"cdr clauses)))))))))))\n\n (define-syntax parameterize\n (er-macro-transformer\n",
" (lambda (form r compare)\n (let ((formal (cadr form))\n (bo",
"dy (cddr form)))\n `(,(r 'with-parameter)\n (lambda ()\n ",
" ,@formal\n ,@body))))))\n\n (define-syntax letrec-syntax\n (er-m",
"acro-transformer\n (lambda (form r c)\n (let ((formal (car (cdr form)))\n",
" (body (cdr (cdr form))))\n `(let ()\n ,@(map (la",
"mbda (x)\n `(,(r 'define-syntax) ,(car x) ,(cadr x)))\n ",
" formal)\n ,@body)))))\n\n (define-syntax let-syntax\n (er",
"-macro-transformer\n (lambda (form r c)\n `(,(r 'letrec-syntax) ,@(cdr f",
"orm)))))\n\n (export let let* letrec letrec*\n let-values let*-values def",
"ine-values\n quasiquote unquote unquote-splicing\n and or\n ",
" cond case else =>\n do when unless\n parameterize\n ",
"let-syntax letrec-syntax\n syntax-error))\n\n",
"",
""
};

2
extlib/benz/cont.c
View File

@ -61,6 +61,7 @@ pic_save_point(pic_state *pic, struct pic_cont *cont)
cont->xp_offset = pic->xp - pic->xpbase;
cont->arena_idx = pic->arena_idx;
cont->ip = pic->ip;
cont->ptable = pic->ptable;
cont->results = pic_undef_value();
}
@ -88,6 +89,7 @@ pic_load_point(pic_state *pic, struct pic_cont *cont)
pic->xp = pic->xpbase + cont->xp_offset;
pic->arena_idx = cont->arena_idx;
pic->ip = cont->ip;
pic->ptable = cont->ptable;
}
static pic_value

3
extlib/benz/gc.c
View File

@ -598,6 +598,9 @@ gc_mark_phase(pic_state *pic)
gc_mark_object(pic, (struct pic_object *)pic->xSTDERR);
}
/* parameter table */
gc_mark(pic, pic->ptable);
/* attributes */
do {
j = 0;

3
extlib/benz/include/picrin.h
View File

@ -130,6 +130,9 @@ typedef struct {
pic_value libs;
xhash attrs;
pic_value ptable;
size_t pnum;
struct pic_reader *reader;
bool gc_enable;

2
extlib/benz/include/picrin/cont.h
View File

@ -21,6 +21,8 @@ struct pic_cont {
pic_code *ip;
pic_value ptable;
pic_value results;
};

1
extlib/benz/include/picrin/proc.h
View File

@ -50,6 +50,7 @@ struct pic_proc *pic_make_proc_irep(pic_state *, struct pic_irep *, struct pic_c
pic_sym *pic_proc_name(struct pic_proc *);
struct pic_dict *pic_proc_env(pic_state *, struct pic_proc *);
bool pic_proc_env_has(pic_state *, struct pic_proc *, const char *);
pic_value pic_proc_env_ref(pic_state *, struct pic_proc *, const char *);
void pic_proc_env_set(pic_state *, struct pic_proc *, const char *, pic_value);

6
extlib/benz/proc.c
View File

@ -57,6 +57,12 @@ pic_proc_env(pic_state *pic, struct pic_proc *proc)
return proc->u.f.env;
}
bool
pic_proc_env_has(pic_state *pic, struct pic_proc *proc, const char *key)
{
return pic_dict_has(pic, pic_proc_env(pic, proc), pic_intern_cstr(pic, key));
}
pic_value
pic_proc_env_ref(pic_state *pic, struct pic_proc *proc, const char *key)
{

7
extlib/benz/state.c
View File

@ -230,6 +230,10 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf)
pic->xSTDOUT = NULL;
pic->xSTDERR = NULL;
/* parameter table */
pic->ptable = pic_nil_value();
pic->pnum = 0;
/* native stack marker */
pic->native_stack_start = &t;
@ -342,6 +346,9 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf)
pic->xSTDOUT = pic_make_standard_port(pic, xstdout, PIC_PORT_OUT);
pic->xSTDERR = pic_make_standard_port(pic, xstderr, PIC_PORT_OUT);
/* parameter table */
pic->ptable = pic_cons(pic, pic_obj_value(pic_make_dict(pic)), pic->ptable);
/* standard libraries */
pic->PICRIN_BASE = pic_make_library(pic, pic_read_cstr(pic, "(picrin base)"));
pic->PICRIN_USER = pic_make_library(pic, pic_read_cstr(pic, "(picrin user)"));

123
extlib/benz/var.c
View File

@ -5,84 +5,79 @@
#include "picrin.h"
static pic_value
var_lookup(pic_state *pic, struct pic_proc *var)
var_conv(pic_state *pic, struct pic_proc *var, pic_value val)
{
pic_value val, env, binding;
pic_value key = pic_obj_value(var);
val = pic_ref(pic, pic->PICRIN_BASE, "current-dynamic-environment");
if (pic_eq_p(val, key)) {
return pic_false_value();
if (pic_proc_env_has(pic, var, "conv") != 0) {
return pic_apply1(pic, pic_proc_ptr(pic_proc_env_ref(pic, var, "conv")), val);
}
return val;
}
env = pic_apply0(pic, pic_proc_ptr(val));
while (! pic_nil_p(env)) {
binding = pic_car(pic, env);
static pic_value
var_get(pic_state *pic, struct pic_proc *var)
{
pic_value elem, it;
pic_sym *id;
struct pic_dict *dict;
while (! pic_nil_p(binding)) {
if (pic_eq_p(pic_caar(pic, binding), key)) {
return pic_car(pic, binding);
}
binding = pic_cdr(pic, binding);
id = pic_sym_ptr(pic_proc_env_ref(pic, var, "id"));
pic_for_each (elem, pic->ptable, it) {
dict = pic_dict_ptr(elem);
if (pic_dict_has(pic, dict, id)) {
return pic_dict_ref(pic, dict, id);
}
env = pic_cdr(pic, env);
}
pic_panic(pic, "logic flaw");
}
return pic_false_value();
static pic_value
var_set(pic_state *pic, struct pic_proc *var, pic_value val)
{
pic_sym *id;
struct pic_dict *dict;
id = pic_sym_ptr(pic_proc_env_ref(pic, var, "id"));
dict = pic_dict_ptr(pic_car(pic, pic->ptable));
pic_dict_set(pic, dict, id, var_conv(pic, var, val));
return pic_none_value();
}
static pic_value
var_call(pic_state *pic)
{
struct pic_proc *self = pic_get_proc(pic);
pic_value val, tmp, box, conv;
pic_value val;
int n;
n = pic_get_args(pic, "|oo", &val, &tmp);
n = pic_get_args(pic, "|o", &val);
box = var_lookup(pic, self);
if (! pic_test(box)) {
box = pic_proc_env_ref(pic, self, "box");
if (n == 0) {
return var_get(pic, self);
} else {
return var_set(pic, self, val);
}
switch (n) {
case 0:
return pic_cdr(pic, box);
case 1:
conv = pic_proc_env_ref(pic, self, "conv");
if (pic_test(conv)) {
pic_assert_type(pic, conv, proc);
val = pic_apply1(pic, pic_proc_ptr(conv), val);
}
pic_set_cdr(pic, box, val);
return pic_none_value();
case 2:
assert(pic_false_p(tmp));
conv = pic_proc_env_ref(pic, self, "conv");
if (pic_test(conv)) {
pic_assert_type(pic, conv, proc);
return pic_apply1(pic, pic_proc_ptr(conv), val);
} else {
return val;
}
}
PIC_UNREACHABLE();
}
struct pic_proc *
pic_make_var(pic_state *pic, pic_value init, struct pic_proc *conv)
{
struct pic_proc *var;
pic_value converter = conv ? pic_obj_value(conv) : pic_false_value();
pic_sym *id;
var = pic_make_proc(pic, var_call, "<var-call>");
pic_proc_env_set(pic, var, "box", pic_cons(pic, pic_false_value(), init));
pic_proc_env_set(pic, var, "conv", conv ? pic_obj_value(conv) : pic_false_value());
if (conv != NULL) {
pic_proc_env_set(pic, var, "conv", converter);
}
id = pic_intern(pic, pic_format(pic, "%d", pic->pnum++));
pic_proc_env_set(pic, var, "id", pic_obj_value(id));
pic_apply1(pic, var, init);
return var;
}
@ -98,12 +93,26 @@ pic_var_make_parameter(pic_state *pic)
return pic_obj_value(pic_make_var(pic, init, conv));
}
static pic_value
pic_var_with_parameter(pic_state *pic)
{
struct pic_proc *body;
pic_value val;
pic_get_args(pic, "l", &body);
pic->ptable = pic_cons(pic, pic_obj_value(pic_make_dict(pic)), pic->ptable);
val = pic_apply0(pic, body);
pic->ptable = pic_cdr(pic, pic->ptable);
return val;
}
void
pic_init_var(pic_state *pic)
{
pic_define_noexport(pic, "current-dynamic-environment", pic_false_value());
pic_defun(pic, "make-parameter", pic_var_make_parameter);
pic_set(pic, pic->PICRIN_BASE, "current-dynamic-environment", pic_obj_value(pic_make_var(pic, pic_nil_value(), NULL)));
pic_defun(pic, "with-parameter", pic_var_with_parameter);
}