[pure-lang-svn] SF.net SVN: pure-lang:[679] pure/trunk

[<ag...@us...>]

Revision: 679
          http://pure-lang.svn.sourceforge.net/pure-lang/?rev=679&view=rev
Author:   agraef
Date:     2008-09-01 15:01:13 +0000 (Mon, 01 Sep 2008)

Log Message:
-----------
Automatic forcing of thunks in pattern matching, syntactic identity checks and C calls.

Modified Paths:
--------------
    pure/trunk/interpreter.cc
    pure/trunk/runtime.cc
    pure/trunk/runtime.h

Modified: pure/trunk/interpreter.cc
===================================================================
--- pure/trunk/interpreter.cc	2008-09-01 14:37:04 UTC (rev 678)
+++ pure/trunk/interpreter.cc	2008-09-01 15:01:13 UTC (rev 679)
@@ -220,6 +220,8 @@
 		                                 "void*", "void*", "int");
   declare_extern((void*)pure_call,
 		 "pure_call",       "expr*",  1, "expr*");
+  declare_extern((void*)pure_force,
+		 "pure_force",      "expr*",  1, "expr*");
   declare_extern((void*)pure_const,
 		 "pure_const",      "expr*",  1, "int");
   declare_extern((void*)pure_int,
@@ -3545,6 +3547,26 @@
   bool temps = false;
   for (size_t i = 0; i < n; i++) {
     Value *x = args[i];
+    // check for thunks which must be forced
+    {
+#if 1
+      // do a quick check on the tag value
+      Value *idx[2] = { Zero, Zero };
+      Value *tagv = b.CreateLoad(b.CreateGEP(x, idx, idx+2), "tag");
+      Value *checkv = b.CreateICmpEQ(tagv, Zero, "check");
+      BasicBlock *forcebb = BasicBlock::Create("force");
+      BasicBlock *skipbb = BasicBlock::Create("skip");
+      b.CreateCondBr(checkv, forcebb, skipbb);
+      f->getBasicBlockList().push_back(forcebb);
+      b.SetInsertPoint(forcebb);
+      b.CreateCall(module->getFunction("pure_force"), x);
+      b.CreateBr(skipbb);
+      f->getBasicBlockList().push_back(skipbb);
+      b.SetInsertPoint(skipbb);
+#else
+      b.CreateCall(module->getFunction("pure_force"), x);
+#endif
+    }
     if (argt[i] == Type::Int1Ty) {
       BasicBlock *okbb = BasicBlock::Create("ok");
       Value *idx[2] = { Zero, Zero };
@@ -5815,6 +5837,25 @@
     msg << "simple match " << f.name;
     debug(msg.str().c_str()); }
 #endif
+  if (t.tag != EXPR::VAR || t.ttag != 0) {
+    // check for thunks which must be forced
+#if 1
+    // do a quick check on the tag value
+    Value *tagv = f.CreateLoadGEP(x, Zero, Zero, "tag");
+    Value *checkv = f.builder.CreateICmpEQ(tagv, Zero, "check");
+    BasicBlock *forcebb = BasicBlock::Create("force");
+    BasicBlock *skipbb = BasicBlock::Create("skip");
+    f.builder.CreateCondBr(checkv, forcebb, skipbb);
+    f.f->getBasicBlockList().push_back(forcebb);
+    f.builder.SetInsertPoint(forcebb);
+    call("pure_force", x);
+    f.builder.CreateBr(skipbb);
+    f.f->getBasicBlockList().push_back(skipbb);
+    f.builder.SetInsertPoint(skipbb);
+#else
+    call("pure_force", x);
+#endif
+  }
   // match the current symbol
   switch (t.tag) {
   case EXPR::VAR:
@@ -6036,7 +6077,31 @@
   // first check for a literal match
   size_t i, n = s->tr.size(), m = 0;
   transl::iterator t0 = s->tr.begin();
-  while (t0 != s->tr.end() && t0->tag == EXPR::VAR) t0++, m++;
+  bool must_force = false;
+  while (t0 != s->tr.end() && t0->tag == EXPR::VAR) {
+    if (t0->ttag != 0) must_force = true;
+    t0++; m++;
+  }
+  must_force = must_force || t0 != s->tr.end();
+  if (must_force) {
+    // check for thunks which must be forced
+#if 1
+    // do a quick check on the tag value
+    Value *tagv = f.CreateLoadGEP(x, Zero, Zero, "tag");
+    Value *checkv = f.builder.CreateICmpEQ(tagv, Zero, "check");
+    BasicBlock *forcebb = BasicBlock::Create("force");
+    BasicBlock *skipbb = BasicBlock::Create("skip");
+    f.builder.CreateCondBr(checkv, forcebb, skipbb);
+    f.f->getBasicBlockList().push_back(forcebb);
+    f.builder.SetInsertPoint(forcebb);
+    call("pure_force", x);
+    f.builder.CreateBr(skipbb);
+    f.f->getBasicBlockList().push_back(skipbb);
+    f.builder.SetInsertPoint(skipbb);
+#else
+    call("pure_force", x);
+#endif
+  }
   if (t0 != s->tr.end()) {
     assert(n > m);
     // get the tag value

Modified: pure/trunk/runtime.cc
===================================================================
--- pure/trunk/runtime.cc	2008-09-01 14:37:04 UTC (rev 678)
+++ pure/trunk/runtime.cc	2008-09-01 15:01:13 UTC (rev 679)
@@ -2619,12 +2619,16 @@
 }
 
 extern "C"
-bool same(const pure_expr *x, const pure_expr *y)
+bool same(pure_expr *x, pure_expr *y)
 {
   char test;
   if (x == y)
     return 1;
-  else if (x->tag != y->tag)
+  if (x->tag == 0 && x->data.clos && x->data.clos->n == 0)
+    pure_force(x);
+  if (y->tag == 0 && y->data.clos && y->data.clos->n == 0)
+    pure_force(y);
+  if (x->tag != y->tag)
     return 0;
   else if (x->tag >= 0 && y->tag >= 0)
     if (x->data.clos && y->data.clos)

Modified: pure/trunk/runtime.h
===================================================================
--- pure/trunk/runtime.h	2008-09-01 14:37:04 UTC (rev 678)
+++ pure/trunk/runtime.h	2008-09-01 15:01:13 UTC (rev 679)
@@ -549,7 +549,7 @@
 
 /* Check whether two objects are the "same" (syntactically). */
 
-bool same(const pure_expr *x, const pure_expr *y);
+bool same(pure_expr *x, pure_expr *y);
 
 /* Check whether an object is a named function (closure), an anonymous
    function (lambda), or a global variable, respectively. */


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.