[pure-lang-svn] SF.net SVN: pure-lang:[675] pure/trunk
Status: Beta
Brought to you by:
agraef
Menu
▾
▴
[pure-lang-svn] SF.net SVN: pure-lang:[675] pure/trunk
|
From: <ag...@us...> - 2008-09-01 00:53:38
|
Revision: 675
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=675&view=rev
Author: agraef
Date: 2008-09-01 00:53:42 +0000 (Mon, 01 Sep 2008)
Log Message:
-----------
Add basic support for suspended expressions (thunks).
Modified Paths:
--------------
pure/trunk/interpreter.cc
pure/trunk/lib/prelude.pure
pure/trunk/lib/primitives.pure
pure/trunk/printer.cc
pure/trunk/runtime.cc
pure/trunk/runtime.h
pure/trunk/symtable.cc
pure/trunk/symtable.hh
Modified: pure/trunk/interpreter.cc
===================================================================
--- pure/trunk/interpreter.cc 2008-08-31 22:34:35 UTC (rev 674)
+++ pure/trunk/interpreter.cc 2008-09-01 00:53:42 UTC (rev 675)
@@ -1707,8 +1707,13 @@
return x;
// application:
case EXPR::APP:
- if (x.xval1().tag() == EXPR::APP &&
- x.xval1().xval1().tag() == symtab.catch_sym().f) {
+ if (x.xval1().tag() == symtab.amp_sym().f) {
+ if (++idx == 0)
+ throw err("error in expression (too many nested closures)");
+ expr v = subst(vars, x.xval2(), idx);
+ return expr(symtab.amp_sym().x, v);
+ } else if (x.xval1().tag() == EXPR::APP &&
+ x.xval1().xval1().tag() == symtab.catch_sym().f) {
expr u = subst(vars, x.xval1().xval2(), idx);
if (++idx == 0)
throw err("error in expression (too many nested closures)");
@@ -1812,8 +1817,13 @@
return x;
// application:
case EXPR::APP:
- if (x.xval1().tag() == EXPR::APP &&
- x.xval1().xval1().tag() == symtab.catch_sym().f) {
+ if (x.xval1().tag() == symtab.amp_sym().f) {
+ if (++idx == 0)
+ throw err("error in expression (too many nested closures)");
+ expr v = fsubst(funs, x.xval2(), idx);
+ return expr(symtab.amp_sym().x, v);
+ } else if (x.xval1().tag() == EXPR::APP &&
+ x.xval1().xval1().tag() == symtab.catch_sym().f) {
expr u = fsubst(funs, x.xval1().xval2(), idx);
if (++idx == 0)
throw err("error in expression (too many nested closures)");
@@ -1909,8 +1919,11 @@
return x;
// application:
case EXPR::APP:
- if (x.xval1().tag() == EXPR::APP &&
- x.xval1().xval1().tag() == symtab.catch_sym().f) {
+ if (x.xval1().tag() == symtab.amp_sym().f) {
+ expr v = csubst(x.xval2());
+ return expr(symtab.amp_sym().x, v);
+ } else if (x.xval1().tag() == EXPR::APP &&
+ x.xval1().xval1().tag() == symtab.catch_sym().f) {
expr u = csubst(x.xval1().xval2()),
v = csubst(x.xval2());
return expr(symtab.catch_sym().x, u, v);
@@ -2203,8 +2216,13 @@
return y;
// application:
case EXPR::APP:
- if (y.xval1().tag() == EXPR::APP &&
- y.xval1().xval1().tag() == symtab.catch_sym().f) {
+ if (y.xval1().tag() == symtab.amp_sym().f) {
+ if (++idx == 0)
+ throw err("error in expression (too many nested closures)");
+ expr v = macred(x, y.xval2(), idx);
+ return expr(symtab.amp_sym().x, v);
+ } else if (y.xval1().tag() == EXPR::APP &&
+ y.xval1().xval1().tag() == symtab.catch_sym().f) {
expr u = macred(x, y.xval1().xval2(), idx);
if (++idx == 0)
throw err("error in expression (too many nested closures)");
@@ -3005,7 +3023,14 @@
case EXPR::APP: {
expr f; uint32_t n = count_args(x, f);
interpreter& interp = *interpreter::g_interp;
- if (n == 2 && f.tag() == interp.symtab.catch_sym().f) {
+ if (n == 1 && f.tag() == interp.symtab.amp_sym().f) {
+ expr y = x.xval2();
+ push("&");
+ Env* eptr = fmap.act()[-x.hash()] = new Env(0, 0, y, true, true);
+ Env& e = *eptr;
+ e.build_map(y); e.promote_map();
+ pop();
+ } else if (n == 2 && f.tag() == interp.symtab.catch_sym().f) {
expr h = x.xval1().xval2(), y = x.xval2();
push("catch");
Env* eptr = fmap.act()[-x.hash()] = new Env(0, 0, y, true, true);
@@ -4778,6 +4803,19 @@
Value *u = codegen(x.xval1().xval2());
act_builder().CreateCall(module->getFunction("pure_freenew"), u);
return codegen(x.xval2());
+ } else if (n == 1 && f.tag() == symtab.amp_sym().f) {
+ // create a thunk (parameterless anonymous closure)
+ expr y = x.xval2();
+ Env& act = act_env();
+ assert(act.fmap.act().find(-x.hash()) != act.fmap.act().end());
+ Env& e = *act.fmap.act()[-x.hash()];
+ push("&", &e);
+ fun_prolog("anonymous");
+ e.CreateRet(codegen(y));
+ fun_finish();
+ pop(&e);
+ Value *body = fbox(e);
+ return body;
} else if (n == 2 && f.tag() == symtab.catch_sym().f) {
// catch an exception; create a little anonymous closure to be called
// through pure_catch()
Modified: pure/trunk/lib/prelude.pure
===================================================================
--- pure/trunk/lib/prelude.pure 2008-08-31 22:34:35 UTC (rev 674)
+++ pure/trunk/lib/prelude.pure 2008-09-01 00:53:42 UTC (rev 675)
@@ -46,24 +46,25 @@
/* Operators. Note that the parser will automagically give unary minus the
same precedence level as the corresponding binary operator. */
-infixl 0 $$ ; // sequence operator
-infixr 0 $ ; // right-associative application
-infixr 1 , ; // pair (tuple)
-infix 2 => ; // mapsto constructor
-infixr 2 || ; // logical or (short-circuit)
-infixr 3 && ; // logical and (short-circuit)
-prefix 3 not ; // logical negation
-infix 4 < > <= >= == != ; // relations
-infix 4 === !== ; // syntactic equality
-infixr 4 : ; // list cons
-infixl 5 << >> ; // bit shifts
-infixl 6 + - or ; // addition, bitwise or
-infixl 7 * / div mod and ; // multiplication, bitwise and
-prefix 7 ~ ; // bitwise not
-infixr 8 ^ ; // exponentiation
-prefix 8 # ; // size operator
-infixl 9 ! !! ; // indexing, slicing
-infixr 9 . ; // function composition
+infixl 0 $$ ; // sequence operator
+infixr 0 $ ; // right-associative application
+infixr 1 , ; // pair (tuple)
+infix 2 => ; // mapsto constructor
+infixr 2 || ; // logical or (short-circuit)
+infixr 3 && ; // logical and (short-circuit)
+prefix 3 not ; // logical negation
+infix 4 < > <= >= == != ; // relations
+infix 4 === !== ; // syntactic equality
+infixr 4 : ; // list cons
+infixl 5 << >> ; // bit shifts
+infixl 6 + - or ; // addition, bitwise or
+infixl 7 * / div mod and ; // multiplication, bitwise and
+prefix 7 ~ ; // bitwise not
+infixr 8 ^ ; // exponentiation
+prefix 8 # ; // size operator
+infixl 9 ! !! ; // indexing, slicing
+infixr 9 . ; // function composition
+postfix 9 & ; // thunk
/* The truth values. These are just integers in Pure, but sometimes it's
convenient to refer to them using these symbolic constants. */
Modified: pure/trunk/lib/primitives.pure
===================================================================
--- pure/trunk/lib/primitives.pure 2008-08-31 22:34:35 UTC (rev 674)
+++ pure/trunk/lib/primitives.pure 2008-09-01 00:53:42 UTC (rev 675)
@@ -23,6 +23,11 @@
extern void pure_throw(expr*) = throw; // IMPURE!
+/* Force a thunk (x&). This usually happens automagically when the value of a
+ thunk is needed. */
+
+extern expr* pure_force(expr*) = force;
+
/* Syntactic equality. */
extern bool same(expr* x, expr* y);
Modified: pure/trunk/printer.cc
===================================================================
--- pure/trunk/printer.cc 2008-08-31 22:34:35 UTC (rev 674)
+++ pure/trunk/printer.cc 2008-09-01 00:53:42 UTC (rev 675)
@@ -758,8 +758,12 @@
return os << pure_paren(95, u) << " " << pure_paren(100, v);
}
default: {
- if (x->tag == 0)
- return os << "<<closure " << (void*)x << ">>";
+ if (x->data.clos && x->data.clos->xp)
+ return os << x->data.clos->xp;
+ if (x->tag == 0) {
+ const char *s = (x->data.clos && x->data.clos->n==0)?"thunk":"closure";
+ return os << "<<" << s << " " << (void*)x << ">>";
+ }
const symbol& sym = interpreter::g_interp->symtab.sym(x->tag);
if (x->data.clos && x->data.clos->local)
return os << "<<closure " << sym.s << ">>";
Modified: pure/trunk/runtime.cc
===================================================================
--- pure/trunk/runtime.cc 2008-08-31 22:34:35 UTC (rev 674)
+++ pure/trunk/runtime.cc 2008-09-01 00:53:42 UTC (rev 675)
@@ -1196,6 +1196,7 @@
x->data.clos->m = m;
x->data.clos->fp = f;
x->data.clos->ep = e;
+ x->data.clos->xp = 0;
if (e) ((Env*)e)->refc++;
if (m == 0)
x->data.clos->env = 0;
@@ -1322,12 +1323,12 @@
{
char test;
assert(x);
- if (x->tag >= 0 && x->data.clos && x->data.clos->n == 0) {
+ if (x->tag > 0 && x->data.clos && x->data.clos->n == 0) {
void *fp = x->data.clos->fp;
#if DEBUG>1
cerr << "pure_call: calling " << x << " -> " << fp << endl;
#endif
- assert(x->tag > 0 && x->refc > 0 && !x->data.clos->local);
+ assert(x->refc > 0 && !x->data.clos->local);
// parameterless call
checkall(test);
return ((pure_expr*(*)())fp)();
@@ -1343,6 +1344,37 @@
}
}
+extern "C"
+pure_expr *pure_force(pure_expr *x)
+{
+ char test;
+ assert(x);
+ if (x->tag == 0 && x->data.clos && x->data.clos->n == 0) {
+ // parameterless anonymous closure (thunk)
+ if (x->data.clos->xp) return x->data.clos->xp; // memoized value
+ void *fp = x->data.clos->fp;
+#if DEBUG>1
+ cerr << "pure_force: calling " << x << " -> " << fp << endl;
+#endif
+ assert(x->refc > 0);
+ // parameterless call
+ checkall(test);
+ pure_expr *ret = ((pure_expr*(*)())fp)();
+ // memoize the result
+ x->data.clos->xp = pure_new_internal(ret);
+ return ret;
+ } else {
+#if DEBUG>2
+ if (x->tag >= 0 && x->data.clos)
+ cerr << "pure_force: returning " << x << " -> " << x->data.clos->fp
+ << " (" << x->data.clos->n << " args)" << endl;
+ else
+ cerr << "pure_force: returning " << x << endl;
+#endif
+ return x;
+ }
+}
+
static inline void resize_sstk(pure_expr**& sstk, size_t& cap,
size_t sz, size_t n)
{
Modified: pure/trunk/runtime.h
===================================================================
--- pure/trunk/runtime.h 2008-08-31 22:34:35 UTC (rev 674)
+++ pure/trunk/runtime.h 2008-09-01 00:53:42 UTC (rev 675)
@@ -26,6 +26,7 @@
void *ep; // pointer to compile time environment (Env*)
uint32_t n, m; // number of arguments and environment size
struct _pure_expr **env; // captured environment (if m>0, 0 otherwise)
+ struct _pure_expr *xp; // pointer to memoized result
bool local; // local function?
bool thunked; // thunked closure? (kept unevaluated)
} pure_closure;
@@ -353,6 +354,12 @@
pure_expr *pure_call(pure_expr *x);
pure_expr *pure_apply(pure_expr *x, pure_expr *y);
+/* This is like pure_call above, but only executes anonymous parameterless
+ closures (thunks), and returns the result in that case (which is then
+ memoized). */
+
+pure_expr *pure_force(pure_expr *x);
+
/* Exception handling stuff. */
typedef struct { jmp_buf jmp; pure_expr* e; size_t sz; } pure_exception;
Modified: pure/trunk/symtable.cc
===================================================================
--- pure/trunk/symtable.cc 2008-08-31 22:34:35 UTC (rev 674)
+++ pure/trunk/symtable.cc 2008-09-01 00:53:42 UTC (rev 675)
@@ -40,6 +40,7 @@
failed_cond_sym();
signal_sym();
segfault_sym();
+ amp_sym();
}
symbol* symtable::lookup(const string& s, int32_t modno)
@@ -358,3 +359,12 @@
else
return sym("mod", 7, infixl);
}
+
+symbol& symtable::amp_sym()
+{
+ symbol *_sym = lookup("&");
+ if (_sym)
+ return *_sym;
+ else
+ return sym("&", 9, postfix);
+}
Modified: pure/trunk/symtable.hh
===================================================================
--- pure/trunk/symtable.hh 2008-08-31 22:34:35 UTC (rev 674)
+++ pure/trunk/symtable.hh 2008-09-01 00:53:42 UTC (rev 675)
@@ -95,6 +95,7 @@
symbol& failed_cond_sym() { return sym("failed_cond"); }
symbol& signal_sym() { return sym("signal"); }
symbol& segfault_sym() { return sym("stack_fault"); }
+ symbol& amp_sym();
};
#endif // ! SYMTABLE_HH
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
