Author: Remi Meier <[email protected]>
Branch: c8-private-pages
Changeset: r1549:81b95867774a
Date: 2015-01-19 16:07 +0100
http://bitbucket.org/pypy/stmgc/changeset/81b95867774a/
Log: add c8 version of duhton
diff too long, truncating to 2000 out of 3255 lines
diff --git a/duhton-c8/Makefile b/duhton-c8/Makefile
new file mode 100644
--- /dev/null
+++ b/duhton-c8/Makefile
@@ -0,0 +1,23 @@
+
+C8SOURCES = ../c8/stmgc.c ../c8/stm/*.c
+
+C8HEADERS = ../c8/stmgc.h ../c8/stm/*.h
+
+COMMON = -pthread -lrt -g -Wall
+
+
+all: duhton_debug duhton duhton_release
+
+duhton: *.c *.h $(C8SOURCES) $(C8HEADERS)
+ clang $(COMMON) -O2 -o duhton *.c ../c8/stmgc.c
+
+duhton_release: *.c *.h $(C8SOURCES) $(C8HEADERS)
+ clang $(COMMON) -DNDEBUG -O2 -o duhton_release *.c ../c8/stmgc.c
+
+
+duhton_debug: *.c *.h $(C8SOURCES) $(C8HEADERS)
+ clang -DSTM_DEBUGPRINT $(COMMON) -DDu_DEBUG -o duhton_debug *.c
../c8/stmgc.c
+
+
+clean:
+ rm -f duhton duhton_debug duhton_release
diff --git a/duhton-c8/ceval.c b/duhton-c8/ceval.c
new file mode 100644
--- /dev/null
+++ b/duhton-c8/ceval.c
@@ -0,0 +1,13 @@
+#include "duhton.h"
+
+
+DuObject *Du_Eval(DuObject *ob, DuObject *locals)
+{
+ eval_fn fn = Du_TYPE(ob)->dt_eval;
+ if (fn) {
+ return fn(ob, locals);
+ }
+ else {
+ return ob;
+ }
+}
diff --git a/duhton-c8/compile.c b/duhton-c8/compile.c
new file mode 100644
--- /dev/null
+++ b/duhton-c8/compile.c
@@ -0,0 +1,114 @@
+#include <stdio.h>
+#include <string.h>
+#include <ctype.h>
+#include "duhton.h"
+
+
+DuObject *_Du_Parse(FILE *f, int level, int stop_after_newline)
+{
+ DuObject *cons, *list;
+ int c, i;
+
+ list = DuList_New();
+ if (level == 0) {
+ _du_save1(list);
+ DuObject *item = DuSymbol_FromString("progn");
+ _du_restore1(list);
+ _du_save1(list);
+ DuList_Append(list, item);
+ _du_restore1(list);
+ }
+ c = fgetc(f);
+ while (1) {
+ DuObject *item;
+
+ switch (c) {
+
+ case EOF:
+ if (level > 0)
+ Du_FatalError("more '(' than ')'");
+ if (stop_after_newline) {
+ return NULL;
+ }
+ goto done;
+
+ case '(':
+ _du_save1(list);
+ item = _Du_Parse(f, level + 1, 0);
+ _du_restore1(list);
+ c = fgetc(f);
+ break;
+
+ case ')':
+ if (level == 0)
+ Du_FatalError("more ')' than '('");
+ goto done;
+
+ case '\n':
+ if (stop_after_newline)
+ goto done;
+ c = fgetc(f);
+ continue;
+
+ case ';':
+ while (c != '\n' && c != EOF)
+ c = fgetc(f);
+ continue;
+
+ default:
+ if (isspace(c)) {
+ c = fgetc(f);
+ continue;
+ }
+ else {
+ char token[201];
+ char *p = token;
+ char *end;
+ int number;
+ do {
+ *p++ = c;
+ c = fgetc(f);
+ } while (!(isspace(c) || c == '(' || c == ')' || c == EOF));
+ *p = '\0';
+ number = strtol(token, &end, 0);
+ _du_save1(list);
+ if (*end == '\0') {
+ item = DuInt_FromInt(number);
+ }
+ else {
+ item = DuSymbol_FromString(token);
+ }
+ _du_restore1(list);
+ break;
+ }
+ }
+ _du_save1(list);
+ DuList_Append(list, item);
+ _du_restore1(list);
+ }
+
+ done:
+ cons = Du_None;
+ for (i = DuList_Size(list) - 1; i >= 0; i--) {
+ DuObject *item = DuList_GetItem(list, i);
+ _du_save1(list);
+ cons = DuCons_New(item, cons);
+ _du_restore1(list);
+ }
+ return cons;
+}
+
+
+DuObject *Du_Compile(char *filename, int stop_after_newline)
+{
+ FILE *f;
+ if (strcmp(filename, "-") == 0)
+ f = stdin;
+ else
+ f = fopen(filename, "r");
+ if (!f) Du_FatalError("cannot open '%s'", filename);
+ DuObject *cons = _Du_Parse(f, 0, stop_after_newline);
+ if (f != stdin)
+ fclose(f);
+ return cons;
+}
diff --git a/duhton-c8/consobject.c b/duhton-c8/consobject.c
new file mode 100644
--- /dev/null
+++ b/duhton-c8/consobject.c
@@ -0,0 +1,93 @@
+#include "duhton.h"
+
+
+void cons_trace(struct DuConsObject_s *ob, void visit(object_t **))
+{
+ visit((object_t **)&ob->car);
+ visit((object_t **)&ob->cdr);
+}
+
+void cons_print(DuConsObject *ob)
+{
+ DuObject *p;
+ printf("( ");
+ while (1) {
+ /* _du_read1(ob); IMMUTABLE */
+ _du_save1(ob);
+ Du_Print(ob->car, 0);
+ _du_restore1(ob);
+ p = ob->cdr;
+ if (!DuCons_Check(p))
+ break;
+ ob = (DuConsObject *)p;
+ printf(" ");
+ }
+ if (p != Du_None) {
+ printf(" . ");
+ Du_Print(p, 0);
+ }
+ printf(" )");
+}
+
+
+
+DuObject *cons_eval(DuConsObject *ob, DuObject *locals)
+{
+ /* _du_read1(ob); IMMUTABLE */
+ return _DuFrame_EvalCall(locals, ob->car, ob->cdr, 1);
+}
+
+DuType DuCons_Type = {
+ "cons",
+ DUTYPE_CONS,
+ sizeof(DuConsObject),
+ (trace_fn)cons_trace,
+ (print_fn)cons_print,
+ (eval_fn)cons_eval,
+};
+
+DuObject *DuCons_New(DuObject *car, DuObject *cdr)
+{
+ _du_save2(car, cdr);
+ DuConsObject *ob = (DuConsObject *)DuObject_New(&DuCons_Type);
+ _du_restore2(car, cdr);
+ ob->car = car;
+ ob->cdr = cdr;
+ return (DuObject *)ob;
+}
+
+DuObject *DuCons_Car(DuObject *cons)
+{
+ DuCons_Ensure("DuCons_Car", cons);
+ /* _du_read1(cons); IMMUTABLE */
+ return ((DuConsObject *)cons)->car;
+}
+
+DuObject *DuCons_Cdr(DuObject *cons)
+{
+ DuCons_Ensure("DuCons_Cdr", cons);
+ /* _du_read1(cons); IMMUTABLE */
+ return ((DuConsObject *)cons)->cdr;
+}
+
+DuObject *_DuCons_CAR(DuObject *cons)
+{
+ assert(DuCons_Check(cons));
+ return ((DuConsObject *)cons)->car;
+}
+
+DuObject *_DuCons_NEXT(DuObject *cons)
+{
+ assert(DuCons_Check(cons));
+ DuObject *result = ((DuConsObject *)cons)->cdr;
+ if (result != Du_None && !DuCons_Check(cons))
+ Du_FatalError("_DuCons_NEXT: not a well-formed cons list");
+ return result;
+}
+
+void DuCons_Ensure(char *where, DuObject *ob)
+{
+ if (!DuCons_Check(ob))
+ Du_FatalError("%s: expected 'cons' argument, got '%s'",
+ where, Du_TYPE(ob)->dt_name);
+}
diff --git a/duhton-c8/containerobject.c b/duhton-c8/containerobject.c
new file mode 100644
--- /dev/null
+++ b/duhton-c8/containerobject.c
@@ -0,0 +1,61 @@
+#include "duhton.h"
+
+typedef TLPREFIX struct DuContainerObject_s {
+ DuOBJECT_HEAD1
+ DuObject *ob_reference;
+} DuContainerObject;
+
+
+void container_trace(struct DuContainerObject_s *ob, void visit(object_t **))
+{
+ visit((object_t **)&ob->ob_reference);
+}
+
+void container_print(DuContainerObject *ob)
+{
+ printf("<container ");
+ Du_Print(ob->ob_reference, 0);
+ printf(">");
+}
+
+DuObject *DuContainer_GetRef(DuObject *ob)
+{
+ DuContainer_Ensure("DuContainer_GetRef", ob);
+
+ _du_read1(ob);
+ return ((DuContainerObject *)ob)->ob_reference;
+}
+
+void DuContainer_SetRef(DuObject *ob, DuObject *x)
+{
+ DuContainer_Ensure("DuContainer_SetRef", ob);
+
+ _du_write1(ob);
+ ((DuContainerObject *)ob)->ob_reference = x;
+}
+
+DuType DuContainer_Type = {
+ "container",
+ DUTYPE_CONTAINER,
+ sizeof(DuContainerObject),
+ (trace_fn)container_trace,
+ (print_fn)container_print,
+};
+
+DuObject *DuContainer_New(DuObject *x)
+{
+ _du_save1(x);
+ DuContainerObject *ob = \
+ (DuContainerObject *)DuObject_New(&DuContainer_Type);
+ _du_restore1(x);
+
+ ob->ob_reference = x;
+ return (DuObject *)ob;
+}
+
+void DuContainer_Ensure(char *where, DuObject *ob)
+{
+ if (!DuContainer_Check(ob))
+ Du_FatalError("%s: expected 'container' argument, got '%s'",
+ where, Du_TYPE(ob)->dt_name);
+}
diff --git a/duhton-c8/demo/container_transaction.duh
b/duhton-c8/demo/container_transaction.duh
new file mode 100644
--- /dev/null
+++ b/duhton-c8/demo/container_transaction.duh
@@ -0,0 +1,20 @@
+
+(setq c (container 0))
+
+(defun g (thread n)
+ (set c (+ (get c) 1))
+ (if (> (get c) 20000)
+ (print (quote overflow) (get c))
+ (if (< n 10000)
+ (transaction f thread (+ n 1))
+ (if (< (get c) 20000)
+ (print (quote not-enough))
+ (print (quote ok))))))
+
+(defun f (thread n)
+ (print (quote <) thread n (quote >))
+ (g thread n))
+
+(transaction f (quote t1) 1)
+(transaction f (quote t2) 1)
+(transaction f (quote t3) 1)
diff --git a/duhton-c8/demo/list_transaction.duh
b/duhton-c8/demo/list_transaction.duh
new file mode 100644
--- /dev/null
+++ b/duhton-c8/demo/list_transaction.duh
@@ -0,0 +1,17 @@
+
+(setq lst (list 0))
+(defun g (n)
+ (set lst 0 (+ (get lst 0) 1))
+ (if (< n 10)
+ (transaction f (+ n 1))
+ (sleepms 20)
+ (if (< (get lst 0) 20)
+ (print (quote not-enough))
+ (print (quote ok)))))
+(defun f (n)
+ (if (defined? marker)
+ (print (quote marker-already-defined)))
+ (setq marker 0)
+ (g n))
+(transaction f 1)
+(transaction f 1)
diff --git a/duhton-c8/demo/many_square_roots.duh
b/duhton-c8/demo/many_square_roots.duh
new file mode 100644
--- /dev/null
+++ b/duhton-c8/demo/many_square_roots.duh
@@ -0,0 +1,17 @@
+
+
+(defun square-root (n)
+ (setq i 0)
+ (while (< (* i i) n)
+ (setq i (+ i 1)))
+ i)
+
+(defun show-square-root (n)
+ (setq s (square-root n))
+ (print (quote square-root-of) n (quote is) s))
+
+
+(setq n 0)
+(while (< n 200)
+ (transaction show-square-root (+ 1000000000 (* n 100000)))
+ (setq n (+ n 1)))
diff --git a/duhton-c8/demo/micro_transactions.duh
b/duhton-c8/demo/micro_transactions.duh
new file mode 100644
--- /dev/null
+++ b/duhton-c8/demo/micro_transactions.duh
@@ -0,0 +1,27 @@
+
+
+
+;;(setq c (container 0))
+
+
+(defun increment ()
+ )
+
+
+(defun big_transactions ()
+ (setq n 0)
+ (while (< n 20000)
+ (transaction increment)
+ (setq n (+ n 1))
+ )
+ )
+
+(setq n 0)
+(while (< n 800)
+ (transaction big_transactions)
+ (setq n (+ n 1))
+ )
+
+(setq timer (time))
+(run-transactions)
+(print (quote TIME_IN_PARALLEL:) (- (time) timer))
diff --git a/duhton-c8/demo/minimal.duh b/duhton-c8/demo/minimal.duh
new file mode 100644
--- /dev/null
+++ b/duhton-c8/demo/minimal.duh
@@ -0,0 +1,3 @@
+
+(print (+ 40 2))
+(print (- 45 3))
diff --git a/duhton-c8/demo/nqueens.duh b/duhton-c8/demo/nqueens.duh
new file mode 100644
--- /dev/null
+++ b/duhton-c8/demo/nqueens.duh
@@ -0,0 +1,148 @@
+
+
+
+
+
+
+(defun abs (i)
+ (if (<= 0 i)
+ i
+ (- 0 i)))
+
+(defun clean_list (n)
+ (setq i n)
+ (setq res (list))
+ (while (> i 0)
+ (append res 0)
+ (setq i (- i 1))
+ )
+ res
+ )
+
+(defun copy_list (xs)
+ (setq res (list))
+ (setq idx 0)
+ (while (< idx (len xs))
+ (append res (get xs idx))
+ (setq idx (+ idx 1))
+ )
+ res
+ )
+
+
+(defun attacks (hist col i j)
+ (|| (== (get hist j) i)
+ (== (abs (- (get hist j) i))
+ (- col j)))
+ )
+
+(defun print_solution (hist n)
+ (print (quote solution) n)
+ (setq i 0)
+ (while (< i n)
+ (setq line (list))
+ (setq j 0)
+ (while (< j n)
+ (if (== j (get hist i))
+ (append line (quote Q))
+ (if (== 0 (% (+ i j) 2))
+ (append line (quote .))
+ (append line (quote ,))
+ )
+ )
+ (setq j (+ j 1))
+ )
+
+ (print line)
+ (setq i (+ i 1))
+ )
+ )
+
+(defun solve (n col hist count)
+ (if (== col n)
+ (progn
+ (set count (+ (get count) 1))
+ ;; (print_solution hist n)
+ )
+
+ ;; else
+ (setq i 0)
+ (while (< i n)
+ (setq j 0)
+ (while (&& (< j col)
+ (not (attacks hist col i j)))
+ (setq j (+ j 1))
+ )
+
+ (if (>= j col)
+ (progn
+ (set hist col i)
+ (solve n (+ col 1) hist count)
+ ))
+
+ (setq i (+ i 1))
+ )
+ )
+ )
+
+
+(defun solve_parallel (n col hist count)
+ (if (== col n)
+ (progn
+ (set count (+ (get count) 1))
+ ;; (print_solution hist n)
+ )
+
+ ;; else
+ (setq i 0)
+ (setq transaction-limit 1)
+ (if (== col transaction-limit)
+ (setq counts (list)))
+
+ (while (< i n)
+ (setq j 0)
+ (while (&& (< j col)
+ (not (attacks hist col i j)))
+ (setq j (+ j 1))
+ )
+
+ (if (>= j col)
+ (progn
+ (set hist col i)
+ (if (== col transaction-limit)
+ (progn
+ (setq new_cont (container 0))
+ (append counts new_cont)
+ (transaction solve n (+ col 1) (copy_list hist) new_cont)
+ )
+ (solve_parallel n (+ col 1) hist count)
+ )
+ )
+ )
+ ;; iterator
+ (setq i (+ i 1))
+ )
+
+ (if (== col transaction-limit)
+ (progn
+ (run-transactions)
+ (setq i 0)
+ (while (< i (len counts))
+ (set count (+ (get count) (get (get counts i))))
+ (setq i (+ i 1))
+ )
+ )
+ )
+ )
+ )
+
+
+
+
+
+(setq count (container 0))
+
+(setq n 11)
+(solve_parallel n 0 (clean_list n) count)
+(print (quote solutions:) (get count))
+
diff --git a/duhton-c8/demo/run_transactions.duh
b/duhton-c8/demo/run_transactions.duh
new file mode 100644
--- /dev/null
+++ b/duhton-c8/demo/run_transactions.duh
@@ -0,0 +1,25 @@
+
+(setq c (container 0))
+
+(defun g (n)
+ (setq i n)
+ (while (< 0 i)
+ (set c (+ (get c) 1))
+ (setq i (- i 1))
+ )
+ )
+
+(defun f (thread n)
+ (g n)
+ )
+
+(transaction f (quote t1) 10000)
+(transaction f (quote t2) 20000)
+(transaction f (quote t3) 10002)
+(run-transactions)
+(transaction f (quote t1) 15)
+(transaction f (quote t2) 15)
+(run-transactions)
+(print (quote result) (get c))
+(print (quote finished))
+
diff --git a/duhton-c8/demo/simple_transaction.duh
b/duhton-c8/demo/simple_transaction.duh
new file mode 100644
--- /dev/null
+++ b/duhton-c8/demo/simple_transaction.duh
@@ -0,0 +1,10 @@
+
+
+(defun do_stuff (i)
+ (if (> (* i i) 10)
+ (print i)))
+
+(setq i 0)
+(while (< i 10)
+ (transaction do_stuff i)
+ (setq i (+ i 1)))
diff --git a/duhton-c8/demo/sort.duh b/duhton-c8/demo/sort.duh
new file mode 100644
--- /dev/null
+++ b/duhton-c8/demo/sort.duh
@@ -0,0 +1,197 @@
+
+
+
+
+(setq c (container (list 1 2 3 4)))
+
+
+(setq _rand (container (list 133542157 362436069 521288629 88675123)))
+(defun xor128 ()
+ (setq lst (get _rand))
+ (setq x (get lst 0))
+ (setq y (get lst 1))
+ (setq z (get lst 2))
+ (setq w (get lst 3))
+
+ (setq t (^ x (<< x 11)))
+ (setq x y)
+ (setq y z)
+ (setq z w)
+
+ (setq w (^ w (^ (>> w 19) (^ t (>> t 8)))))
+ (set lst 0 x)
+ (set lst 1 y)
+ (set lst 2 z)
+ (set lst 3 w)
+ w
+ )
+
+
+(defun random_list (n)
+ (setq i n)
+ (setq res (list))
+ (while (> i 0)
+ (append res (% (xor128) 10))
+ (setq i (- i 1))
+ )
+ res
+ )
+
+
+
+(defun merge_lists (as bs)
+ ;; merges the two lists and returns a new one
+ (setq res (list))
+ (setq idxa 0)
+ (setq idxb 0)
+ (while (&& (< idxa (len as))
+ (< idxb (len bs)))
+ (if (> (get as idxa) (get bs idxb))
+ (progn
+ (append res (get bs idxb))
+ (setq idxb (+ idxb 1))
+ )
+ (append res (get as idxa))
+ (setq idxa (+ idxa 1))
+ )
+ )
+
+ (if (< idxa (len as))
+ (progn
+ (setq xs as)
+ (setq idxx idxa)
+ )
+ (setq xs bs)
+ (setq idxx idxb))
+
+ (while (< idxx (len xs))
+ (append res (get xs idxx))
+ (setq idxx (+ idxx 1)))
+
+ res
+ )
+
+
+(defun split_list (xs)
+ ;; empties xs and fills 2 new lists to be returned
+ (setq half_len (/ (len xs) 2))
+ (setq first (list))
+ (setq second (list))
+ (setq xidx 0)
+
+ (while (< xidx (len xs))
+ (if (< xidx half_len)
+ (append first (get xs xidx))
+ (append second (get xs xidx))
+ )
+ (setq xidx (+ xidx 1))
+ )
+
+ (list first second)
+ )
+
+
+
+(defun merge_sort (xs)
+ (if (<= (len xs) 1) ; 1 elem
+ xs
+ (progn ; many elems
+ (setq lists (split_list xs))
+
+ (setq left (merge_sort (get lists 0)))
+ (setq right (merge_sort (get lists 1)))
+ ;; (print left right)
+ (merge_lists left right)
+ )
+ )
+ )
+
+(defun merge_sort_transaction (xs res-cont)
+ (set res-cont (merge_sort xs))
+ )
+
+(defun merge_sort_parallel (xs)
+ (if (<= (len xs) 1) ; 1 elem
+ xs
+ (progn ; many elems
+ (setq lists (split_list xs))
+ (setq left-c (container None))
+ (setq right-c (container None))
+
+ (transaction merge_sort_transaction
+ (get lists 0) left-c)
+ (transaction merge_sort_transaction
+ (get lists 1) right-c)
+
+ (setq current (time))
+ (print (quote before-parallel))
+ (run-transactions)
+ (print (quote time-parallel:) (- (time) current))
+
+ (setq left (get left-c))
+ (setq right (get right-c))
+ (assert (<= (len left) (+ (len right) 2)))
+ (assert (<= (len right) (+ (len left) 2)))
+ ;; (print left right)
+ (merge_lists left right)
+ )
+ )
+ )
+
+
+(defun copy_list (xs)
+ (setq res (list))
+ (setq idx 0)
+ (while (< idx (len xs))
+ (append res (get xs idx))
+ (setq idx (+ idx 1))
+ )
+ res
+ )
+
+(defun print_list (xs)
+ (print (quote len:) (len xs) (quote ->) xs)
+ )
+
+(defun is_sorted (xs)
+ (setq idx 0)
+ (while (< idx (- (len xs) 1))
+ (assert (<=
+ (get xs idx)
+ (get xs (+ idx 1))))
+ (setq idx (+ idx 1))
+ )
+ (quote true)
+ )
+
+
+;; (setq as (random_list 20))
+;; (setq bs (random_list 20))
+;; (print as)
+;; (print bs)
+;; (print (split_list as))
+
+(setq current (time))
+(print (quote before-random))
+(setq cs (random_list 300000))
+(print (quote time-random:) (- (time) current))
+
+;; (print_list cs)
+
+;; (setq res (container None))
+;; (transaction merge_sort_transaction cs res)
+;; (run-transactions)
+;; (print (is_sorted (get res)))
+
+(setq current (time))
+(print (quote before-sorting))
+(setq sorted (merge_sort_parallel cs))
+(print (quote time-sorting:) (- (time) current))
+
+
+(setq current (time))
+(print (quote before-check))
+(print (quote sorted:) (is_sorted sorted))
+(print (quote time-check:) (- (time) current))
+
+
diff --git a/duhton-c8/demo/square_root.duh b/duhton-c8/demo/square_root.duh
new file mode 100644
--- /dev/null
+++ b/duhton-c8/demo/square_root.duh
@@ -0,0 +1,9 @@
+
+
+(defun square_root (n)
+ (setq i 0)
+ (while (< (* i i) n)
+ (setq i (+ i 1)))
+ i)
+
+(print (square_root 1000000000))
diff --git a/duhton-c8/demo/synth.duh b/duhton-c8/demo/synth.duh
new file mode 100644
--- /dev/null
+++ b/duhton-c8/demo/synth.duh
@@ -0,0 +1,98 @@
+
+
+
+(defun clean_list (n)
+ (setq i n)
+ (setq res (list))
+ (while (> i 0)
+ (append res 0)
+ (setq i (- i 1))
+ )
+ res
+ )
+
+
+(setq _rand (container (list 133542157 362436069 521288629 88675123)))
+(defun xor128 ()
+ (setq lst (get _rand))
+ (setq x (get lst 0))
+ (setq y (get lst 1))
+ (setq z (get lst 2))
+ (setq w (get lst 3))
+
+ (setq t (^ x (<< x 11)))
+ (setq x y)
+ (setq y z)
+ (setq z w)
+
+ (setq w (^ w (^ (>> w 19) (^ t (>> t 8)))))
+ (set lst 0 x)
+ (set lst 1 y)
+ (set lst 2 z)
+ (set lst 3 w)
+ w
+ )
+
+
+(defun random_list (n max)
+ (setq i n)
+ (setq res (list))
+ (while (> i 0)
+ (append res (% (xor128) max))
+ (setq i (- i 1))
+ )
+ res
+ )
+
+
+
+
+(defun worker (shared private)
+ (setq i 1)
+ (while (< i 10000)
+ ;; every 200th modification is on 'shared'
+ (if (== (% i 200) 0)
+ (set shared (+ (get shared) 1))
+ (set private (+ (get private) 1))
+ )
+
+ (setq i (+ i 1))
+ )
+ )
+
+
+
+(setq N 1000)
+;; CONFL_IF_BELOW / RAND_MAX == ratio of conflicting transactions
+;; to non conflicting ones
+(setq RAND_MAX 8)
+(setq CONFL_IF_BELOW 1)
+
+(print (quote N:) N)
+(print (quote RAND_MAX:) RAND_MAX)
+(print (quote CONFL_IF_BELOW:) CONFL_IF_BELOW)
+
+(setq timer (time))
+(print (quote setup-transactions:) timer)
+
+(setq shared (container 0))
+(setq rand-list (random_list N RAND_MAX))
+(setq i 0)
+(while (< i N)
+ (setq private (container 0))
+ (if (< (get rand-list i) CONFL_IF_BELOW)
+ ;; conflicting transaction
+ (transaction worker shared private)
+ ;; else non-conflicting
+ (transaction worker private private)
+ )
+
+ (setq i (+ i 1))
+ )
+
+(print (quote setup-time-diff:) (- (time) timer))
+(setq timer (time))
+(run-transactions)
+(print (quote run-time-diff:) (- (time) timer))
+(print (quote shared) (get shared))
+
diff --git a/duhton-c8/demo/trees.duh b/duhton-c8/demo/trees.duh
new file mode 100644
--- /dev/null
+++ b/duhton-c8/demo/trees.duh
@@ -0,0 +1,18 @@
+
+(defun create-tree (n)
+ (if (== n 0) 1 (cons (create-tree (- n 1)) (create-tree (- n 1))))
+)
+
+(defun walk-tree (tree)
+ (if (pair? tree)
+ (+ (walk-tree (car tree)) (walk-tree (cdr tree)))
+ 1
+ )
+)
+
+(setq tree (create-tree 10))
+(print (walk-tree tree))
+(setq n 0)
+(while (< n 1000)
+ (transaction walk-tree tree)
+ (setq n (+ n 1)))
diff --git a/duhton-c8/demo/trees2.duh b/duhton-c8/demo/trees2.duh
new file mode 100644
--- /dev/null
+++ b/duhton-c8/demo/trees2.duh
@@ -0,0 +1,21 @@
+
+
+(defun create-tree (n)
+ (if (== n 0) 1 (cons (create-tree (- n 1)) (create-tree (- n 1))))
+)
+
+(defun walk-tree (tree)
+ (if (pair? tree)
+ (+ (walk-tree (car tree)) (walk-tree (cdr tree)))
+ 1
+ )
+)
+
+(defun lookup-tree ()
+ (walk-tree (create-tree 10))
+)
+
+(setq n 0)
+(while (< n 1000)
+ (transaction lookup-tree)
+ (setq n (+ n 1)))
diff --git a/duhton-c8/duhton.c b/duhton-c8/duhton.c
new file mode 100644
--- /dev/null
+++ b/duhton-c8/duhton.c
@@ -0,0 +1,70 @@
+#include <string.h>
+#include "duhton.h"
+
+
+int main(int argc, char **argv)
+{
+ char *filename = NULL;
+ int interactive = 1;
+ int i;
+ int num_threads = STM_NB_SEGMENTS;
+
+ for (i = 1; i < argc; ++i) {
+ if (strcmp(argv[i], "--help") == 0) {
+ printf("Duhton: a simple lisp-like language with STM
support\n\n");
+ printf("Usage: duhton [--help] [--num-threads no]
[filename]\n");
+ printf(" --help: this help\n");
+ printf(" --num-threads <number>: number of threads
(default 4)\n\n");
+ exit(0);
+ } else if (strcmp(argv[i], "--num-threads") == 0) {
+ if (i == argc - 1) {
+ printf("ERROR: --num-threads requires a
parameter\n");
+ exit(1);
+ }
+ num_threads = atoi(argv[i + 1]);
+ i++;
+ } else if (strncmp(argv[i], "--", 2) == 0) {
+ printf("ERROR: unrecognized parameter %s\n", argv[i]);
+ } else {
+ filename = argv[i];
+ interactive = 0;
+ }
+ }
+ if (!filename) {
+ filename = "-"; /* stdin */
+ }
+
+ Du_Initialize(num_threads);
+
+ while (1) {
+ if (interactive) {
+ printf("))) ");
+ fflush(stdout);
+ }
+ stm_start_inevitable_transaction(&stm_thread_local);
+ DuObject *code = Du_Compile(filename, interactive);
+
+ if (code == NULL) {
+ printf("\n");
+ break;
+ }
+
+ DuObject *res = Du_Eval(code, Du_Globals);
+ if (interactive) {
+ Du_Print(res, 1);
+ }
+
+ //_du_save1(stm_thread_local_obj);
+ //stm_collect(0); /* hack... */
+ //_du_restore1(stm_thread_local_obj);
+
+ stm_commit_transaction();
+
+ Du_TransactionRun();
+ if (!interactive)
+ break;
+ }
+
+ Du_Finalize();
+ return 0;
+}
diff --git a/duhton-c8/duhton.h b/duhton-c8/duhton.h
new file mode 100644
--- /dev/null
+++ b/duhton-c8/duhton.h
@@ -0,0 +1,213 @@
+#ifndef _DUHTON_H_
+#define _DUHTON_H_
+
+/* #undef USE_GIL */ /* forces "gil-c7" instead of "c7" */
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <assert.h>
+
+#include "../c8/stmgc.h"
+
+
+
+extern __thread stm_thread_local_t stm_thread_local;
+
+struct DuObject_s {
+ struct object_s header;
+ uint32_t type_id;
+};
+typedef TLPREFIX struct DuObject_s DuObject;
+
+
+#define DuOBJECT_HEAD1 struct DuObject_s ob_base;
+
+
+#ifdef __GNUC__
+# define NORETURN __attribute__((noreturn))
+#else
+# define NORETURN /* nothing */
+#endif
+
+
+typedef void(*trace_fn)(struct DuObject_s *, void visit(object_t **));
+typedef size_t(*bytesize_fn)(struct DuObject_s *);
+typedef void(*print_fn)(DuObject *);
+typedef DuObject *(*eval_fn)(DuObject *, DuObject *);
+typedef int(*len_fn)(DuObject *);
+
+typedef struct {
+ const char *dt_name;
+ int dt_typeindex;
+ int dt_size;
+ trace_fn dt_trace;
+ print_fn dt_print;
+ eval_fn dt_eval;
+ len_fn dt_is_true;
+ len_fn dt_length;
+ bytesize_fn dt_bytesize;
+} DuType;
+
+/* keep this list in sync with object.c's Du_Types[] */
+#define DUTYPE_INVALID 0
+#define DUTYPE_NONE 1
+#define DUTYPE_INT 2
+#define DUTYPE_SYMBOL 3
+#define DUTYPE_CONS 4
+#define DUTYPE_LIST 5
+#define DUTYPE_TUPLE 6
+#define DUTYPE_FRAME 7
+#define DUTYPE_FRAMENODE 8
+#define DUTYPE_CONTAINER 9
+#define _DUTYPE_TOTAL 10
+
+extern DuType DuNone_Type;
+extern DuType DuInt_Type;
+extern DuType DuSymbol_Type;
+extern DuType DuCons_Type;
+extern DuType DuList_Type;
+extern DuType DuTuple_Type;
+extern DuType DuFrame_Type;
+extern DuType DuFrameNode_Type;
+extern DuType DuContainer_Type;
+
+extern DuType *Du_Types[_DUTYPE_TOTAL];
+
+#define ROUND_UP(size) ((size) < 16 ? 16 : ((size) + 7) & ~7)
+
+
+DuObject *DuObject_New(DuType *tp);
+int DuObject_IsTrue(DuObject *ob);
+int DuObject_Length(DuObject *ob);
+
+
+extern DuObject *Du_None;
+
+#define _DuObject_TypeNum(ob) (((DuObject*)(ob))->type_id)
+#define Du_TYPE(ob) (Du_Types[_DuObject_TypeNum(ob)])
+#define DuInt_Check(ob) (_DuObject_TypeNum(ob) == DUTYPE_INT)
+#define DuSymbol_Check(ob) (_DuObject_TypeNum(ob) == DUTYPE_SYMBOL)
+#define DuCons_Check(ob) (_DuObject_TypeNum(ob) == DUTYPE_CONS)
+#define DuList_Check(ob) (_DuObject_TypeNum(ob) == DUTYPE_LIST)
+#define DuFrame_Check(ob) (_DuObject_TypeNum(ob) == DUTYPE_FRAME)
+#define DuContainer_Check(ob) (_DuObject_TypeNum(ob) == DUTYPE_CONTAINER)
+
+void DuType_Ensure(char *where, DuObject *ob);
+void DuInt_Ensure(char *where, DuObject *ob);
+void DuList_Ensure(char *where, DuObject *ob);
+void DuContainer_Ensure(char *where, DuObject *ob);
+void DuCons_Ensure(char *where, DuObject *ob);
+void DuSymbol_Ensure(char *where, DuObject *ob);
+void DuFrame_Ensure(char *where, DuObject *ob);
+
+DuObject *DuInt_FromInt(int value);
+int DuInt_AsInt(DuObject *ob);
+
+DuObject *DuList_New(void);
+void DuList_Append(DuObject *list, DuObject *item);
+int DuList_Size(DuObject *list);
+DuObject *DuList_GetItem(DuObject *list, int index);
+void DuList_SetItem(DuObject *list, int index, DuObject *newobj);
+DuObject *DuList_Pop(DuObject *list, int index);
+
+DuObject *DuContainer_New(DuObject *obj);
+DuObject *DuContainer_GetRef(DuObject *container);
+void DuContainer_SetRef(DuObject *container, DuObject *newobj);
+
+DuObject *DuSymbol_FromString(const char *name);
+char *DuSymbol_AsString(DuObject *ob);
+int DuSymbol_Id(DuObject *ob);
+
+typedef TLPREFIX struct DuConsObject_s {
+ DuOBJECT_HEAD1
+ DuObject *car, *cdr;
+} DuConsObject;
+
+DuObject *DuCons_New(DuObject *car, DuObject *cdr);
+DuObject *DuCons_Car(DuObject *cons);
+DuObject *DuCons_Cdr(DuObject *cons);
+DuObject *_DuCons_CAR(DuObject *cons);
+DuObject *_DuCons_NEXT(DuObject *cons);
+
+void Du_FatalError(char *msg, ...) NORETURN;
+DuObject *Du_Compile(char *filename, int stop_after_newline);
+void Du_Print(DuObject *ob, int newline);
+
+DuObject *Du_Eval(DuObject *ob, DuObject *locals);
+DuObject *Du_Progn(DuObject *cons, DuObject *locals);
+
+DuObject *DuFrame_New();
+DuObject *DuFrame_Copy(DuObject *frame);
+DuObject *DuFrame_GetSymbol(DuObject *frame, DuObject *symbol);
+void DuFrame_SetSymbol(DuObject *frame, DuObject *symbol, DuObject *value);
+void DuFrame_SetSymbolStr(DuObject *frame, char *name, DuObject *value);
+void DuFrame_SetBuiltinMacro(DuObject *frame, char *name, eval_fn func);
+void DuFrame_SetUserFunction(DuObject *frame, DuObject *symbol,
+ DuObject *arglist, DuObject *progn);
+DuObject *_DuFrame_EvalCall(DuObject *frame, DuObject *symbol,
+ DuObject *rest, int execute_now);
+
+void Du_Initialize(int);
+void Du_Finalize(void);
+extern DuObject *Du_Globals;
+
+void Du_TransactionAdd(DuObject *code, DuObject *frame);
+void Du_TransactionRun(void);
+
+
+#define _du_save1(p1) (_push_root((DuObject *)(p1)))
+#define _du_save2(p1,p2) (_push_root((DuObject *)(p1)), \
+ _push_root((DuObject *)(p2)))
+#define _du_save3(p1,p2,p3) (_push_root((DuObject *)(p1)), \
+ _push_root((DuObject *)(p2)), \
+ _push_root((DuObject *)(p3)))
+#define _du_save4(p1,p2,p3,p4) (_push_root((DuObject *)(p1)), \
+ _push_root((DuObject *)(p2)), \
+ _push_root((DuObject *)(p3)), \
+ _push_root((DuObject *)(p4)))
+
+
+#define _du_restore1(p1) (p1 = (typeof(p1))_pop_root())
+#define _du_restore2(p1,p2) (p2 = (typeof(p2))_pop_root(), \
+ p1 = (typeof(p1))_pop_root())
+#define _du_restore3(p1,p2,p3) (p3 = (typeof(p3))_pop_root(), \
+ p2 = (typeof(p2))_pop_root(), \
+ p1 = (typeof(p1))_pop_root())
+#define _du_restore4(p1,p2,p3,p4)(p4 = (typeof(p4))_pop_root(), \
+ p3 = (typeof(p3))_pop_root(), \
+ p2 = (typeof(p2))_pop_root(), \
+ p1 = (typeof(p1))_pop_root())
+
+
+#define _du_read1(p1) stm_read((object_t *)(p1))
+#define _du_write1(p1) stm_write((object_t *)(p1))
+
+#define INIT_PREBUILT(p) ((typeof(p))stm_setup_prebuilt((object_t *)(p)))
+
+
+#ifndef NDEBUG
+# define _check_not_free(ob) \
+ assert(_DuObject_TypeNum(ob) > DUTYPE_INVALID && \
+ _DuObject_TypeNum(ob) < _DUTYPE_TOTAL)
+#endif
+
+static inline void _push_root(DuObject *ob) {
+ #ifndef NDEBUG
+ if (ob) _check_not_free(ob);
+ #endif
+ STM_PUSH_ROOT(stm_thread_local, ob);
+}
+static inline object_t *_pop_root(void) {
+ object_t *ob;
+ STM_POP_ROOT(stm_thread_local, ob);
+ #ifndef NDEBUG
+ if (ob) _check_not_free(ob);
+ #endif
+ return ob;
+}
+
+extern pthread_t *all_threads;
+extern int all_threads_count;
+
+//extern __thread DuObject *stm_thread_local_obj; /* XXX temp */
+#endif /* _DUHTON_H_ */
diff --git a/duhton-c8/frame.c b/duhton-c8/frame.c
new file mode 100644
--- /dev/null
+++ b/duhton-c8/frame.c
@@ -0,0 +1,366 @@
+#include "duhton.h"
+#include <string.h>
+#include <stdint.h>
+
+typedef TLPREFIX struct dictentry_s {
+ int symbol_id;
+ DuObject *symbol;
+ DuObject *value;
+ eval_fn builtin_macro;
+ DuObject *func_arglist;
+ DuObject *func_progn;
+} dictentry_t;
+
+typedef TLPREFIX struct DuFrameNodeObject_s {
+ DuOBJECT_HEAD1
+ int ob_count;
+ struct dictentry_s ob_items[1];
+} DuFrameNodeObject;
+
+
+void framenode_trace(struct DuFrameNodeObject_s *ob, void visit(object_t **))
+{
+ int i;
+ for (i=ob->ob_count-1; i>=0; i--) {
+ struct dictentry_s *e = &ob->ob_items[i];
+ visit((object_t **)&e->symbol);
+ visit((object_t **)&e->value);
+ visit((object_t **)&e->func_arglist);
+ visit((object_t **)&e->func_progn);
+ }
+}
+
+size_t framenode_bytesize(struct DuFrameNodeObject_s *ob)
+{
+ return (sizeof(DuFrameNodeObject) +
+ (ob->ob_count - 1) * sizeof(struct dictentry_s));
+}
+
+
+typedef TLPREFIX struct DuFrameObject_s {
+ DuOBJECT_HEAD1
+ DuFrameNodeObject *ob_nodes;
+} DuFrameObject;
+
+DuObject *Du_Globals;
+static DuFrameNodeObject *du_empty_framenode;
+
+void init_prebuilt_frame_objects(void)
+{
+ static DuFrameNodeObject empty_framenode = { {.type_id=DUTYPE_FRAMENODE} };
+ static DuFrameObject g = { {.type_id=DUTYPE_FRAME},
+ .ob_nodes=&empty_framenode };
+
+ du_empty_framenode = INIT_PREBUILT(&empty_framenode);
+ Du_Globals = (DuObject *)INIT_PREBUILT(&g);
+}
+
+DuObject *DuFrame_New()
+{
+ DuFrameObject *ob = (DuFrameObject *)DuObject_New(&DuFrame_Type);
+ ob->ob_nodes = du_empty_framenode;
+ return (DuObject *)ob;
+}
+
+#if 0
+DuObject *DuFrame_Copy(DuObject *frame)
+{
+ XXX fix or kill
+ DuFrame_Ensure("DuFrame_Copy", frame);
+ int i;
+ DuFrameObject *src = (DuFrameObject *)frame;
+ DuFrameObject *dst = (DuFrameObject *)DuFrame_New();
+ dst->entry_count = src->entry_count;
+ dst->entries = malloc(sizeof(struct dictentry) * src->entry_count);
+ assert(dst->entries);
+ for (i=0; i<src->entry_count; i++) {
+ struct dictentry *e = &src->entries[i];
+ Du_INCREF(e->symbol);
+ if (e->value != NULL) Du_INCREF(e->value );
+ if (e->func_arglist != NULL) Du_INCREF(e->func_arglist);
+ if (e->func_progn != NULL) Du_INCREF(e->func_progn );
+ dst->entries[i] = *e;
+ }
+ return (DuObject *)dst;
+}
+#endif
+
+void frame_trace(struct DuFrameObject_s *ob, void visit(object_t **))
+{
+ visit((object_t **)&ob->ob_nodes);
+}
+
+void frame_print(DuFrameObject *ob)
+{
+ printf("<frame>");
+}
+
+static void _copy(dictentry_t *dst, dictentry_t *src)
+{
+ /* workaround for a bug in clang-3.4: cannot do "*dst = *src;" */
+ memcpy(_stm_real_address((object_t *)dst),
+ _stm_real_address((object_t *)src),
+ sizeof(dictentry_t));
+}
+
+static void _clear(dictentry_t *dst)
+{
+ /* workaround for a bug in clang-3.4: many "dst->field = NULL;"
+ turn into a single memset() call */
+ memset(_stm_real_address((object_t *)dst), 0,
+ sizeof(dictentry_t));
+}
+
+static dictentry_t *
+find_entry(DuFrameObject *frame, DuObject *symbol, int write_mode)
+{
+ /* only allocates if write_mode = 1 */
+ _du_read1(frame);
+ DuFrameNodeObject *ob = frame->ob_nodes;
+
+ _du_read1(ob);
+ int left = 0;
+ int right = ob->ob_count;
+ dictentry_t *entries = ob->ob_items;
+ int search_id = DuSymbol_Id(symbol);
+
+#if 0
+#ifdef _GC_DEBUG
+ int j;
+ for (j = 0; j < right; j++) {
+ dprintf(("\t%d\n", entries[j].symbol_id));
+ }
+#endif
+#endif
+
+ while (right > left) {
+ int middle = (left + right) / 2;
+ int found_id = entries[middle].symbol_id;
+ if (search_id < found_id)
+ right = middle;
+ else if (search_id == found_id) {
+ if (write_mode) {
+ _du_write1(ob);
+ entries = ob->ob_items;
+ }
+ return entries + middle;
+ }
+ else
+ left = middle + 1;
+ }
+
+ if (!write_mode) {
+ return NULL;
+ }
+ else {
+ int i;
+ size_t size = (sizeof(DuFrameNodeObject) +
+ (ob->ob_count + 1 - 1)*sizeof(dictentry_t));
+ DuFrameNodeObject *newob;
+
+ _du_save3(ob, symbol, frame);
+ newob = (DuFrameNodeObject *)stm_allocate(size);
+ newob->ob_base.type_id = DUTYPE_FRAMENODE;
+ _du_restore3(ob, symbol, frame);
+
+ newob->ob_count = ob->ob_count + 1;
+ dictentry_t *newentries = newob->ob_items;
+ entries = ob->ob_items;
+
+ for (i=0; i<left; i++)
+ _copy(&newentries[i], &entries[i]);
+
+ DuSymbol_Ensure("find_entry", symbol);
+#ifdef _GC_DEBUG
+ dprintf(("NEW ENTRY ADDED WITH search_id = %d\n", search_id));
+#endif
+ _clear(&newentries[left]);
+ newentries[left].symbol_id = search_id;
+ newentries[left].symbol = symbol;
+
+ for (i=left+1; i<newob->ob_count; i++)
+ _copy(&newentries[i], &entries[i-1]);
+
+ _du_write1(frame);
+ frame->ob_nodes = newob;
+
+ return newentries + left;
+ }
+}
+
+void DuFrame_SetBuiltinMacro(DuObject *frame, char *name, eval_fn func)
+{
+ DuFrame_Ensure("DuFrame_SetBuiltinMacro", frame);
+
+ _du_save1(frame);
+ DuObject *sym = DuSymbol_FromString(name);
+ _du_restore1(frame);
+
+ _du_save1(frame);
+ dictentry_t *e = find_entry((DuFrameObject *)frame, sym, 1);
+ _du_restore1(frame);
+
+ _du_write1(frame); /* e is part of frame or a new object */
+ e->builtin_macro = func;
+}
+
+static void
+_parse_arguments(DuObject *symbol, DuObject *arguments,
+ DuObject *formallist, DuObject *caller, DuObject *callee)
+{
+ while (DuCons_Check(formallist)) {
+ if (!DuCons_Check(arguments))
+ Du_FatalError("call to '%s': not enough arguments",
+ DuSymbol_AsString(symbol));
+
+ /* _du_read1(arguments); IMMUTABLE */
+ DuObject *arg = _DuCons_CAR(arguments);
+ DuObject *argumentsnext = _DuCons_NEXT(arguments);
+
+ _du_save3(symbol, argumentsnext, caller);
+ _du_save2(formallist, callee);
+ DuObject *obj = Du_Eval(arg, caller);
+ _du_restore2(formallist, callee);
+
+ /* _du_read1(formallist); IMMUTABLE */
+ DuObject *sym = _DuCons_CAR(formallist);
+ DuObject *formallistnext = _DuCons_NEXT(formallist);
+
+ _du_save2(formallistnext, callee);
+ DuFrame_SetSymbol(callee, sym, obj);
+ _du_restore2(formallistnext, callee);
+ _du_restore3(symbol, argumentsnext, caller);
+
+ formallist = formallistnext;
+ arguments = argumentsnext;
+ }
+ if (arguments != Du_None)
+ Du_FatalError("call to '%s': too many arguments",
+ DuSymbol_AsString(symbol));
+}
+
+DuObject *_DuFrame_EvalCall(DuObject *frame, DuObject *symbol,
+ DuObject *rest, int execute_now)
+{
+ dictentry_t *e;
+ DuFrame_Ensure("_DuFrame_EvalCall", frame);
+
+ /* find_entry not in write_mode will not collect */
+ e = find_entry((DuFrameObject *)frame, symbol, 0);
+ if (!e) {
+ e = find_entry((DuFrameObject *)Du_Globals, symbol, 0);
+ if (!e) {
+ if (!DuSymbol_Check(symbol)) {
+ printf("_DuFrame_EvalCall: ");
+ Du_Print(symbol, 1);
+ Du_FatalError("expected a symbol to execute");
+ }
+ else
+ goto not_defined;
+ }
+ }
+ if (e->func_progn) {
+ DuObject *func = e->func_progn;
+ DuObject *func_arglist = e->func_arglist;
+ _du_save1(func);
+ _du_save4(frame, symbol, rest, func_arglist);
+ DuObject *callee_frame = DuFrame_New();
+ _du_restore4(frame, symbol, rest, func_arglist);
+
+ _du_save1(callee_frame);
+ _parse_arguments(symbol, rest, func_arglist, frame, callee_frame);
+ _du_restore1(callee_frame);
+ _du_restore1(func);
+
+ if (execute_now) {
+ return Du_Progn(func, callee_frame);
+ }
+ else {
+ Du_TransactionAdd(func, callee_frame);
+ return NULL;
+ }
+ }
+ if (e->builtin_macro) {
+ if (!execute_now)
+ Du_FatalError("symbol refers to a macro: '%s'",
+ DuSymbol_AsString(symbol));
+ return e->builtin_macro(rest, frame);
+ }
+ not_defined:
+ Du_FatalError("symbol not defined as a function: '%s'",
+ DuSymbol_AsString(symbol));
+}
+
+DuObject *DuFrame_GetSymbol(DuObject *frame, DuObject *symbol)
+{
+ dictentry_t *e;
+ DuFrame_Ensure("DuFrame_GetSymbol", frame);
+
+ e = find_entry((DuFrameObject *)frame, symbol, 0);
+ /* find_entry does the read_barrier */
+ return e ? e->value : NULL;
+}
+
+void DuFrame_SetSymbol(DuObject *frame, DuObject *symbol, DuObject *value)
+{
+ dictentry_t *e;
+ DuFrame_Ensure("DuFrame_SetSymbol", frame);
+
+ _du_save2(value, frame);
+ e = find_entry((DuFrameObject *)frame, symbol, 1);
+ _du_restore2(value, frame);
+
+ _du_write1(frame); /* e is new or part of frame */
+ e->value = value;
+}
+
+void DuFrame_SetSymbolStr(DuObject *frame, char *name, DuObject *value)
+{
+ _du_save2(frame, value);
+ DuObject *sym = DuSymbol_FromString(name);
+ _du_restore2(frame, value);
+
+ DuFrame_SetSymbol(frame, sym, value);
+}
+
+void DuFrame_SetUserFunction(DuObject *frame, DuObject *symbol,
+ DuObject *arglist, DuObject *progn)
+{
+ dictentry_t *e;
+ DuFrame_Ensure("DuFrame_SetUserFunction", frame);
+
+ _du_save3(arglist, progn, frame);
+ e = find_entry((DuFrameObject *)frame, symbol, 1);
+ _du_restore3(arglist, progn, frame);
+
+ _du_write1(frame); /* e is part of frame or new */
+ e->func_arglist = arglist;
+ e->func_progn = progn;
+}
+
+void DuFrame_Ensure(char *where, DuObject *ob)
+{
+ if (!DuFrame_Check(ob))
+ Du_FatalError("%s: expected 'frame' argument, got '%s'",
+ where, Du_TYPE(ob)->dt_name);
+}
+
+DuType DuFrameNode_Type = { /* internal type */
+ "framenode",
+ DUTYPE_FRAMENODE,
+ 0, /* dt_size */
+ (trace_fn)framenode_trace,
+ (print_fn)NULL,
+ (eval_fn)NULL,
+ (len_fn)NULL,
+ (len_fn)NULL,
+ (bytesize_fn)framenode_bytesize,
+};
+
+DuType DuFrame_Type = {
+ "frame",
+ DUTYPE_FRAME,
+ sizeof(DuFrameObject),
+ (trace_fn)frame_trace,
+ (print_fn)frame_print,
+};
diff --git a/duhton-c8/glob.c b/duhton-c8/glob.c
new file mode 100644
--- /dev/null
+++ b/duhton-c8/glob.c
@@ -0,0 +1,867 @@
+#include "duhton.h"
+#include <sys/select.h>
+#include <sys/time.h>
+
+pthread_t *all_threads;
+int all_threads_count;
+
+static void _du_getargs1(const char *name, DuObject *cons, DuObject *locals,
+ DuObject **a)
+{
+ DuObject *expr1, *obj1;
+
+ if (cons == Du_None) goto error;
+
+ /* _du_read1(cons); IMMUTABLE */
+ expr1 = _DuCons_CAR(cons);
+ cons = _DuCons_NEXT(cons);
+ if (cons != Du_None) goto error;
+
+ obj1 = Du_Eval(expr1, locals);
+ *a = obj1;
+ return;
+
+ error:
+ Du_FatalError("%s: expected one argument", name);
+}
+
+static void _du_getargs2(const char *name, DuObject *cons, DuObject *locals,
+ DuObject **a, DuObject **b)
+{
+ DuObject *expr1, *expr2, *obj1, *obj2;
+
+ if (cons == Du_None) goto error;
+
+ /* _du_read1(cons); IMMUTABLE */
+ expr1 = _DuCons_CAR(cons);
+ cons = _DuCons_NEXT(cons);
+ if (cons == Du_None) goto error;
+
+ /* _du_read1(cons); IMMUTABLE */
+ expr2 = _DuCons_CAR(cons);
+ cons = _DuCons_NEXT(cons);
+ if (cons != Du_None) goto error;
+
+ _du_save2(expr2, locals);
+ obj1 = Du_Eval(expr1, locals);
+ _du_restore2(expr2, locals);
+
+ _du_save1(obj1);
+ obj2 = Du_Eval(expr2, locals);
+ _du_restore1(obj1);
+
+ *a = obj1;
+ *b = obj2;
+ return;
+
+ error:
+ Du_FatalError("%s: expected two arguments", name);
+}
+
+/************************************************************/
+
+
+DuObject *Du_Progn(DuObject *cons, DuObject *locals)
+{
+ DuObject *result = Du_None;
+ while (cons != Du_None) {
+ /* _du_read1(cons); IMMUTABLE */
+ DuObject *expr = _DuCons_CAR(cons);
+ DuObject *next = _DuCons_NEXT(cons);
+ _du_save2(next, locals);
+ result = Du_Eval(expr, locals);
+ _du_restore2(next, locals);
+ cons = next;
+ }
+ return result;
+}
+
+DuObject *du_setq(DuObject *cons, DuObject *locals)
+{
+ DuObject *result = Du_None;
+ while (cons != Du_None) {
+ /* _du_read1(cons); IMMUTABLE */
+ DuObject *symbol = _DuCons_CAR(cons);
+ cons = _DuCons_NEXT(cons);
+ if (cons == Du_None)
+ Du_FatalError("setq: number of arguments is odd");
+ /* _du_read1(cons); IMMUTABLE */
+ DuObject *expr = _DuCons_CAR(cons);
+ DuObject *next = _DuCons_NEXT(cons);
+
+ _du_save3(symbol, next, locals);
+ DuObject *obj = Du_Eval(expr, locals);
+ _du_restore3(symbol, next, locals);
+
+ _du_save3(next, locals, obj);
+ DuFrame_SetSymbol(locals, symbol, obj);
+ _du_restore3(next, locals, obj);
+
+ result = obj;
+ cons = next;
+ }
+ return result;
+}
+
+DuObject *du_print(DuObject *cons, DuObject *locals)
+{
+ _du_save2(cons, locals);
+ DuObject *lst = DuList_New();
+ _du_restore2(cons, locals);
+
+ while (cons != Du_None) {
+ /* _du_read1(cons); IMMUTABLE */
+ DuObject *expr = _DuCons_CAR(cons);
+ DuObject *next = _DuCons_NEXT(cons);
+
+ _du_save3(lst, next, locals);
+ DuObject *obj = Du_Eval(expr, locals);
+ _du_restore3(lst, next, locals);
+
+ _du_save3(lst, next, locals);
+ DuList_Append(lst, obj);
+ _du_restore3(lst, next, locals);
+
+ cons = next;
+ }
+
+ _du_save1(lst);
+ stm_become_inevitable(&stm_thread_local, "print");
+ _du_restore1(lst);
+
+ int i;
+ for (i=0; i<DuList_Size(lst); i++) {
+ if (i > 0) printf(" ");
+ _du_save1(lst);
+ Du_Print(DuList_GetItem(lst, i), 0);
+ _du_restore1(lst);
+ }
+
+ printf("\n");
+ return Du_None;
+}
+
+DuObject *du_xor(DuObject *cons, DuObject *locals)
+{
+ int result = 0;
+ while (cons != Du_None) {
+ /* _du_read1(cons); IMMUTABLE */
+ DuObject *expr = _DuCons_CAR(cons);
+ DuObject *next = _DuCons_NEXT(cons);
+
+ _du_save2(next, locals);
+ DuObject *obj = Du_Eval(expr, locals);
+ result ^= DuInt_AsInt(obj);
+ _du_restore2(next, locals);
+
+ cons = next;
+ }
+
+ return DuInt_FromInt(result);
+}
+
+DuObject *du_lshift(DuObject *cons, DuObject *locals)
+{
+ int result = 0;
+ /* _du_read1(cons); IMMUTABLE */
+ DuObject *expr = _DuCons_CAR(cons);
+ DuObject *next = _DuCons_NEXT(cons);
+
+ _du_save2(next, locals);
+ DuObject *obj = Du_Eval(expr, locals);
+ result = DuInt_AsInt(obj);
+ _du_restore2(next, locals);
+
+ cons = next;
+
+ while (cons != Du_None) {
+ /* _du_read1(cons); IMMUTABLE */
+ expr = _DuCons_CAR(cons);
+ next = _DuCons_NEXT(cons);
+
+ _du_save2(next, locals);
+ obj = Du_Eval(expr, locals);
+ result <<= DuInt_AsInt(obj);
+ _du_restore2(next, locals);
+
+ cons = next;
+ }
+
+ return DuInt_FromInt(result);
+}
+
+DuObject *du_rshift(DuObject *cons, DuObject *locals)
+{
+ int result = 0;
+ /* _du_read1(cons); IMMUTABLE */
+ DuObject *expr = _DuCons_CAR(cons);
+ DuObject *next = _DuCons_NEXT(cons);
+
+ _du_save2(next, locals);
+ DuObject *obj = Du_Eval(expr, locals);
+ result = DuInt_AsInt(obj);
+ _du_restore2(next, locals);
+
+ cons = next;
+
+ while (cons != Du_None) {
+ /* _du_read1(cons); IMMUTABLE */
+ expr = _DuCons_CAR(cons);
+ next = _DuCons_NEXT(cons);
+
+ _du_save2(next, locals);
+ obj = Du_Eval(expr, locals);
+ result >>= DuInt_AsInt(obj);
+ _du_restore2(next, locals);
+
+ cons = next;
+ }
+
+ return DuInt_FromInt(result);
+}
+
+DuObject *du_add(DuObject *cons, DuObject *locals)
+{
+ int result = 0;
+ while (cons != Du_None) {
+ /* _du_read1(cons); IMMUTABLE */
+ DuObject *expr = _DuCons_CAR(cons);
+ DuObject *next = _DuCons_NEXT(cons);
+
+ _du_save2(next, locals);
+ DuObject *obj = Du_Eval(expr, locals);
+ result += DuInt_AsInt(obj);
+ _du_restore2(next, locals);
+
+ cons = next;
+ }
+ return DuInt_FromInt(result);
+}
+
+DuObject *du_sub(DuObject *cons, DuObject *locals)
+{
+ int result = 0;
+ int sign = 1;
+ while (cons != Du_None) {
+ /* _du_read1(cons); IMMUTABLE */
+ DuObject *expr = _DuCons_CAR(cons);
+ DuObject *next = _DuCons_NEXT(cons);
+
+ _du_save2(next, locals);
+ DuObject *obj = Du_Eval(expr, locals);
+ result += sign * DuInt_AsInt(obj);
+ _du_restore2(next, locals);
+
+ sign = -1;
+ cons = next;
+ }
+ return DuInt_FromInt(result);
+}
+
+DuObject *du_mul(DuObject *cons, DuObject *locals)
+{
+ int result = 1;
+ while (cons != Du_None) {
+ /* _du_read1(cons); IMMUTABLE */
+ DuObject *expr = _DuCons_CAR(cons);
+ DuObject *next = _DuCons_NEXT(cons);
+
+ _du_save2(next, locals);
+ DuObject *obj = Du_Eval(expr, locals);
+ result *= DuInt_AsInt(obj);
+ _du_restore2(next, locals);
+
+ cons = next;
+ }
+ return DuInt_FromInt(result);
+}
+
+DuObject *du_div(DuObject *cons, DuObject *locals)
+{
+ int result = 0;
+ int first = 1;
+
+ while (cons != Du_None) {
+ /* _du_read1(cons); IMMUTABLE */
+ DuObject *expr = _DuCons_CAR(cons);
+ DuObject *next = _DuCons_NEXT(cons);
+
+ _du_save2(next, locals);
+ DuObject *obj = Du_Eval(expr, locals);
+ if (first) {
+ result = DuInt_AsInt(obj);
+ first = 0;
+ } else {
+ result /= DuInt_AsInt(obj);
+ }
+ _du_restore2(next, locals);
+
+ cons = next;
+ }
+ return DuInt_FromInt(result);
+}
+
+DuObject *du_mod(DuObject *cons, DuObject *locals)
+{
+ int result = 0;
+ int first = 1;
+
+ while (cons != Du_None) {
+ /* _du_read1(cons); IMMUTABLE */
+ DuObject *expr = _DuCons_CAR(cons);
+ DuObject *next = _DuCons_NEXT(cons);
+
+ _du_save2(next, locals);
+ DuObject *obj = Du_Eval(expr, locals);
+ if (first) {
+ result = DuInt_AsInt(obj);
+ first = 0;
+ } else {
+ result %= DuInt_AsInt(obj);
+ }
+ _du_restore2(next, locals);
+
+ cons = next;
+ }
+ return DuInt_FromInt(result);
+}
_______________________________________________
pypy-commit mailing list
[email protected]
https://mail.python.org/mailman/listinfo/pypy-commit
