Merge pull request #65 from FolkComputer/osnr/incremental-tag-detection

Shared memory peering + incremental tag detection + better incremental Collect + use non-sync Display

4 files changed, 53 insertions, 66 deletions

diff --git a/lib/c.tcl b/lib/c.tcl
index 165ab723..82b1cfce 100644
--- a/lib/c.tcl
+++ b/lib/c.tcl
@@ -45,7 +45,7 @@ namespace eval c {
                 #include <stdbool.h>
 
                 #define __ENSURE(EXPR) if (!(EXPR)) { Tcl_SetResult(interp, "failed to convert argument from Tcl to C in: " #EXPR, NULL); return TCL_ERROR; }
-                #define __ENSURE_OK(EXPR) if ((EXPR) != TCL_OK) { Tcl_SetResult(interp, "failed to convert argument from Tcl to C in: " #EXPR, NULL); return TCL_ERROR; }
+                #define __ENSURE_OK(EXPR) if ((EXPR) != TCL_OK) { return TCL_ERROR; }
             }
             variable code [list]
             variable objtypes [list]
diff --git a/lib/evaluator.tcl b/lib/evaluator.tcl
index 0554c189..73c6a353 100644
--- a/lib/evaluator.tcl
+++ b/lib/evaluator.tcl
@@ -757,6 +757,15 @@ namespace eval Statements { ;# singleton Statement store
         }
         return "digraph { rankdir=LR; [join $dot "\n"] }"
     }
+    proc saveDotToPdf {filename} {
+        exec dot -Tpdf >$filename <<[Statements::dot]
+    }
+
+    proc print {} {
+        dict for {id stmt} [Statements::all] {
+            puts [statement short $stmt]
+        }
+    }
 
     # these are kind of arbitrary/temporary bridge
     $cc proc matchRemoveFirstDestructor {match_handle_t matchId} void {
@@ -883,6 +892,7 @@ namespace eval Evaluator {
             }
         }
         static void LogWriteRecollect(statement_handle_t collectId);
+        static void LogWriteUnmatch(match_handle_t matchId);
         void reactToStatementAdditionThatMatchesCollect(Tcl_Interp* interp,
                                                         statement_handle_t collectId,
                                                         Tcl_Obj* collectPattern,
@@ -1008,8 +1018,7 @@ namespace eval Evaluator {
                 match_handle_t matchId = edge->match;
                 if (!matchExists(matchId)) continue; // if was removed earlier
 
-                reactToMatchRemoval(interp, matchId);
-                matchRemove(matchId);
+                LogWriteUnmatch(matchId);
             }
         }
     }
@@ -1022,6 +1031,7 @@ namespace eval Evaluator {
                 if (unmatch->edges[j].type == PARENT) {
                     statement_handle_t unmatchWhenId = unmatch->edges[j].statement;
                     statement_t* unmatchWhen = get(unmatchWhenId);
+                    if (unmatchWhen == NULL) continue;
                     for (int k = 0; k < unmatchWhen->n_edges; k++) {
                         if (unmatchWhen->edges[k].type == PARENT) {
                             unmatchId = unmatchWhen->edges[k].match;
@@ -1101,8 +1111,7 @@ namespace eval Evaluator {
                 if (edge->type == CHILD && !matchHandleIsEqual(edge->match, matchId)) {
                     match_handle_t childMatchId = edge->match;
                     matchGet(childMatchId)->recollectOnDestruction = false;
-                    reactToMatchRemoval(interp, childMatchId);
-                    matchRemove(childMatchId);
+                    LogWriteUnmatch(childMatchId);
                     break;
                 }
             }
@@ -1111,7 +1120,7 @@ namespace eval Evaluator {
 
     $cc code {
         typedef enum {
-            NONE, ASSERT, RETRACT, SAY, RECOLLECT
+            NONE, ASSERT, RETRACT, SAY, UNMATCH, RECOLLECT
         } log_entry_op_t;
         typedef struct log_entry_t {
             log_entry_op_t op;
@@ -1122,21 +1131,24 @@ namespace eval Evaluator {
                     match_handle_t parentMatchId;
                     Tcl_Obj* clause;
                 } say;
+                struct { match_handle_t matchId; } unmatch;
                 struct { statement_handle_t collectId; } recollect;
             };
         } log_entry_t;
 
-        log_entry_t evaluatorLog[1024] = {0};
+        log_entry_t evaluatorLog[4096] = {0};
         #define EVALUATOR_LOG_CAPACITY (sizeof(evaluatorLog)/sizeof(evaluatorLog[1]))
         int evaluatorLogReadIndex = EVALUATOR_LOG_CAPACITY - 1;
         int evaluatorLogWriteIndex = 0;
     }
     $cc proc Evaluate {Tcl_Interp* interp} void {
+        /* printf("Evaluate==========\n"); */
         while (evaluatorLogReadIndex != evaluatorLogWriteIndex) {
             log_entry_t entry = evaluatorLog[evaluatorLogReadIndex];
             evaluatorLogReadIndex = (evaluatorLogReadIndex + 1) % EVALUATOR_LOG_CAPACITY;
 
             if (entry.op == ASSERT) {
+                /* printf("Assert (%s)\n", Tcl_GetString(entry.assert.clause)); */
                 statement_handle_t id; bool isNewStatement;
                 addImpl(interp, entry.assert.clause, 0, NULL,
                         &id, &isNewStatement);
@@ -1146,6 +1158,7 @@ namespace eval Evaluator {
                 Tcl_DecrRefCount(entry.assert.clause);
 
             } else if (entry.op == RETRACT) {
+                /* printf("Retract (%s)\n", Tcl_GetString(entry.retract.pattern)); */
                 environment_t* results[1000];
                 int resultsCount = searchByPattern(entry.retract.pattern,
                                                    1000, results);
@@ -1158,6 +1171,7 @@ namespace eval Evaluator {
                 Tcl_DecrRefCount(entry.retract.pattern);
 
             } else if (entry.op == SAY) {
+                /* printf("Say (%s)\n", Tcl_GetString(entry.say.clause)); */
                 if (matchExists(entry.say.parentMatchId)) {
                     statement_handle_t id; bool isNewStatement;
                     addImpl(interp, entry.say.clause, 1, &entry.say.parentMatchId,
@@ -1168,7 +1182,15 @@ namespace eval Evaluator {
                 }
                 Tcl_DecrRefCount(entry.say.clause);
 
+            } else if (entry.op == UNMATCH) {
+                /* printf("Unmatch (m%d:%d)\n", entry.unmatch.matchId.idx, entry.unmatch.matchId.gen); */
+                if (matchExists(entry.unmatch.matchId)) {
+                    reactToMatchRemoval(interp, entry.unmatch.matchId);
+                    matchRemove(entry.unmatch.matchId);
+                }
+
             } else if (entry.op == RECOLLECT) {
+                /* printf("Recollect (s%d:%d)\n", entry.recollect.collectId.idx, entry.recollect.collectId.gen); */
                 if (exists(entry.recollect.collectId)) {
                     recollect(interp, entry.recollect.collectId);
                 }
@@ -1199,8 +1221,11 @@ namespace eval Evaluator {
         Tcl_IncrRefCount(clause);
         LogWriteFront((log_entry_t) { .op = SAY, .say = {.parentMatchId=parentMatchId, .clause=clause} });
     }
+    $cc proc LogWriteUnmatch {match_handle_t matchId} void {
+        LogWriteBack((log_entry_t) { .op = UNMATCH, .unmatch = {.matchId=matchId} });
+    }
     $cc proc LogWriteRecollect {statement_handle_t collectId} void {
-        LogWriteBack((log_entry_t) { .op = RECOLLECT, .recollect = {.collectId=collectId} });
+        LogWriteFront((log_entry_t) { .op = RECOLLECT, .recollect = {.collectId=collectId} });
     }
     $cc proc LogIsEmpty {} bool {
         return evaluatorLogReadIndex == evaluatorLogWriteIndex;
diff --git a/lib/peer.tcl b/lib/peer.tcl
index 274f9f07..0a1aef0d 100644
--- a/lib/peer.tcl
+++ b/lib/peer.tcl
@@ -25,72 +25,31 @@ namespace eval ::Peers {}
 set ::peersBlacklist [dict create]
 
 proc ::peer {process {dieOnDisconnect false}} {
-    package require websocket
     namespace eval ::Peers::$process {
-        variable connected false
+        variable connected true
 
         proc log {s} {
             variable process
             puts "$::thisProcess -> $process: $s"
         }
-        proc setupSock {} {
-            variable process
-            log "Trying to connect to: ws://$process:4273/ws"
-            variable chan [::websocket::open "ws://$process:4273/ws" [namespace code handleWs]]
-        }
-        proc handleWs {chan type msg} {
-            if {$type eq "connect"} {
-                log "Connected"
-                variable connected true
-
-                # Establish a peering on their end, in the reverse
-                # direction, so they can send stuff back to us.
-                # It'll implicitly run in a ::Peers::X namespace on their end
-                # (because of how `run` is implemented below)
-                run {
-                    set name [namespace tail [namespace current]]
-                    variable chan [uplevel {set chan}]
-
-                    # First, check if this side has us blacklisted.
-                    if {[dict exists $::peersBlacklist $name]} {
-                        ::websocket::close $chan
-                        return
-                    }
-
-                    variable connected true
-                    proc run {msg} {
-                        variable chan
-                        ::websocket::send $chan text $msg
-                    }
-                }
-            } elseif {$type eq "disconnect"} {
-                log "Disconnected"
 
-                variable dieOnDisconnect
-                if {$dieOnDisconnect} { exit 0 }
+        # TODO: Handle die on disconnect (?)
 
-                variable connected false
-                after 2000 [namespace code setupSock]
-            } elseif {$type eq "error"} {
-                log "WebSocket error: $type $msg"
-                after 2000 [namespace code setupSock]
-            } elseif {$type eq "text"} {
-                eval $msg
-            } elseif {$type eq "ping" || $type eq "pong"} {
-            } else {
-                error "Unknown WebSocket event: $type $msg"
-            }
+        proc share {statements} {
+            variable process
+            Mailbox::share $::thisProcess $process $statements
         }
-
-        proc run {msg} {
-            variable chan
-            ::websocket::send $chan text [list namespace eval ::Peers::$::thisProcess $msg]
+        proc receive {} {
+            variable process
+            Mailbox::receive $process $::thisProcess
         }
 
         proc init {n shouldDieOnDisconnect} {
-            variable process $n; setupSock
+            variable process $n
             variable dieOnDisconnect $shouldDieOnDisconnect
-            vwait ::Peers::${n}::connected
+
+            Mailbox::create $::thisProcess $process
+            Mailbox::create $process $::thisProcess
         }
         init
     } $process $dieOnDisconnect
diff --git a/lib/process.tcl b/lib/process.tcl
index a4b8ed48..059c0b89 100644
--- a/lib/process.tcl
+++ b/lib/process.tcl
@@ -58,19 +58,22 @@ namespace eval ::Zygote {
 
 proc On-process {name body} {
     set this [uplevel {expr {[info exists this] ? $this : "<unknown>"}}]
-    set processCode [list apply {{__name __body} {
+    set processCode [list apply {{__parentProcess __name __body} {
         set ::thisProcess $__name
 
         Assert <lib/process.tcl> wishes $::thisProcess shares all wishes
         Assert <lib/process.tcl> wishes $::thisProcess shares all claims
 
-        ::peer "localhost" true
+        ::peer $__parentProcess true
 
         Assert <lib/process.tcl> claims $::thisProcess has pid [pid]
         Assert when $::thisProcess has pid /something/ [list {} $__body]
-        Step
-        vwait forever
-    }} $name $body]
+        while true {
+            Step
+        }
+    }} $::thisProcess $name $body]
+
+    ::peer $name false
 
     Zygote::spawn [list apply {{processCode} {
         # A supervisor that wraps the subprocess.