From 69148a9150dda25061e58b0e4f1d24b570939b06 Mon Sep 17 00:00:00 2001 From: Omar Rizwan Date: Thu, 5 Oct 2023 21:20:11 -0400 Subject: process: Allow running multiple On process blocks on process Turn off share wishes/claims default for subprocesses, so you (for now) have to explicitly specify sharing if you want any to happen. On process now only spawns process if it doesn't exist but always runs the code block (which now happens through a statement instead of directly on init). --- lib/process.tcl | 24 ++++++++++++++++++------ 1 file changed, 18 insertions(+), 6 deletions(-) (limited to 'lib') diff --git a/lib/process.tcl b/lib/process.tcl index 059c0b89..b5d2952b 100644 --- a/lib/process.tcl +++ b/lib/process.tcl @@ -57,21 +57,32 @@ namespace eval ::Zygote { } proc On-process {name body} { + if {[namespace exists ::Peers::$name]} { + uplevel [list Wish program code $body runs on $name] + return + } + set this [uplevel {expr {[info exists this] ? $this : ""}}] - set processCode [list apply {{__parentProcess __name __body} { + set processCode [list apply {{__parentProcess __name} { set ::thisProcess $__name - Assert wishes $::thisProcess shares all wishes - Assert wishes $::thisProcess shares all claims - ::peer $__parentProcess true + Assert wishes $::thisProcess shares statements like \ + [list /someone/ claims $::thisProcess has pid /something/] + Assert wishes $::thisProcess receives statements like \ + [list /someone/ wishes program code /code/ runs on $::thisProcess] + Assert wishes $::thisProcess shares statements like \ + [list /someone/ wishes $::thisProcess receives statements like /pattern/] + Assert claims $::thisProcess has pid [pid] - Assert when $::thisProcess has pid /something/ [list {} $__body] + Assert when /someone/ wishes program code /__code/ runs on $::thisProcess {{__code} { + eval $__code + }} while true { Step } - }} $::thisProcess $name $body] + }} $::thisProcess $name] ::peer $name false @@ -107,4 +118,5 @@ proc On-process {name body} { after 5000 [list dict unset ::peersBlacklist $name] } }} $this $name + uplevel [list Wish program code $body runs on $name] } -- cgit v1.2.3 From f4356b98d2041d8188ae61d1025a98db7becdee0 Mon Sep 17 00:00:00 2001 From: Omar Rizwan Date: Fri, 6 Oct 2023 17:41:15 -0400 Subject: display: WIP: Refactor into files; use wishes, not Display:: Expose shader stuff to user programs for the first time. Mostly works, but display thread and main thread run much slower (28fps display, 70fps main). Also introduce dict getwithdefault (helpful for rest options). --- lib/language.tcl | 29 +++++++++++++++++++++++++++++ lib/process.tcl | 24 +++++++++++++----------- 2 files changed, 42 insertions(+), 11 deletions(-) (limited to 'lib') diff --git a/lib/language.tcl b/lib/language.tcl index ae3e4ae7..03000c31 100644 --- a/lib/language.tcl +++ b/lib/language.tcl @@ -77,6 +77,35 @@ proc lenumerate {l} { set ret } + +proc extend {cmd subcmd subspec body} { + namespace eval [uplevel 1 [list namespace which $cmd]] [string map [ + list %subcmd [list $subcmd] %subspec [list $subspec] %body [list $body]] { + if {[namespace which [namespace tail [namespace current]]] ne "[ + string trimright [namespace current] :]::[ + namespace tail [namespace current]]"} { + + ::rename [::namespace current] [::namespace current]::[ + ::namespace tail [::namespace current]] + ::namespace export * + ::namespace ensemble create -unknown [list ::apply [list {ns subc args} { + ::return [::list ${ns}::[::namespace tail $ns] $subc] + } [namespace current]]] + } + # puts [list creating %subcmd in [namespace current]] + ::proc %subcmd %subspec %body + }] +} +# Create `dict getdef` / `dict getwithdefault` +# Backported from https://core.tcl-lang.org/tips/doc/trunk/tip/342.md +foreach subcmd {getdef getwithdefault} { extend dict $subcmd {D args} { + if {[dict exists $D {*}[lrange $args 0 end-1]]} then { + dict get $D {*}[lrange $args 0 end-1] + } else { + lindex $args end + } +} } + proc python3 {args} { exec python3 << [undent [join $args " "]] } diff --git a/lib/process.tcl b/lib/process.tcl index b5d2952b..faaa5e84 100644 --- a/lib/process.tcl +++ b/lib/process.tcl @@ -56,14 +56,14 @@ namespace eval ::Zygote { } } -proc On-process {name body} { +proc Start-process {name body} { if {[namespace exists ::Peers::$name]} { - uplevel [list Wish program code $body runs on $name] + error "Process $name already exists" return } set this [uplevel {expr {[info exists this] ? $this : ""}}] - set processCode [list apply {{__parentProcess __name} { + set processCode [list apply {{__parentProcess __name __body} { set ::thisProcess $__name ::peer $__parentProcess true @@ -76,13 +76,16 @@ proc On-process {name body} { [list /someone/ wishes $::thisProcess receives statements like /pattern/] Assert claims $::thisProcess has pid [pid] - Assert when /someone/ wishes program code /__code/ runs on $::thisProcess {{__code} { - eval $__code - }} - while true { - Step - } - }} $::thisProcess $name] + # Run __body one Step before running any other program code. + Assert when $::thisProcess has pid /something/ [list {__body} { + When /someone/ wishes program code /__code/ runs on $::thisProcess { + eval $__code + } + eval $__body + }] with environment [list $__body] + + while true { Step } + }} $::thisProcess $name $body] ::peer $name false @@ -118,5 +121,4 @@ proc On-process {name body} { after 5000 [list dict unset ::peersBlacklist $name] } }} $this $name - uplevel [list Wish program code $body runs on $name] } -- cgit v1.2.3 From e91f7c12cb45b7430b08a860993ab5dbbf599b81 Mon Sep 17 00:00:00 2001 From: Omar Rizwan Date: Fri, 6 Oct 2023 17:59:03 -0400 Subject: dict getdef -> dict_getdef. Much, much faster --- lib/language.tcl | 23 ++--------------------- 1 file changed, 2 insertions(+), 21 deletions(-) (limited to 'lib') diff --git a/lib/language.tcl b/lib/language.tcl index 03000c31..2977933d 100644 --- a/lib/language.tcl +++ b/lib/language.tcl @@ -77,34 +77,15 @@ proc lenumerate {l} { set ret } - -proc extend {cmd subcmd subspec body} { - namespace eval [uplevel 1 [list namespace which $cmd]] [string map [ - list %subcmd [list $subcmd] %subspec [list $subspec] %body [list $body]] { - if {[namespace which [namespace tail [namespace current]]] ne "[ - string trimright [namespace current] :]::[ - namespace tail [namespace current]]"} { - - ::rename [::namespace current] [::namespace current]::[ - ::namespace tail [::namespace current]] - ::namespace export * - ::namespace ensemble create -unknown [list ::apply [list {ns subc args} { - ::return [::list ${ns}::[::namespace tail $ns] $subc] - } [namespace current]]] - } - # puts [list creating %subcmd in [namespace current]] - ::proc %subcmd %subspec %body - }] -} # Create `dict getdef` / `dict getwithdefault` # Backported from https://core.tcl-lang.org/tips/doc/trunk/tip/342.md -foreach subcmd {getdef getwithdefault} { extend dict $subcmd {D args} { +proc dict_getdef {D args} { if {[dict exists $D {*}[lrange $args 0 end-1]]} then { dict get $D {*}[lrange $args 0 end-1] } else { lindex $args end } -} } +} proc python3 {args} { exec python3 << [undent [join $args " "]] -- cgit v1.2.3 From ff4786a94e9e4ef9c08a012105bb0c214f537ad4 Mon Sep 17 00:00:00 2001 From: Omar Rizwan Date: Mon, 23 Oct 2023 17:15:51 -0400 Subject: evaluator: Don't claimize patterns with verbs Suppresses one weird overeager unification error with sprites vs. shapes drawing (it was doing `/someone/ claims /anyone/ wishes` and all the wildcards lined up with the other statement in a bad way) --- lib/evaluator.tcl | 47 ++++++++++++++++++++++++++++++++++------------- 1 file changed, 34 insertions(+), 13 deletions(-) (limited to 'lib') diff --git a/lib/evaluator.tcl b/lib/evaluator.tcl index 8eae0ca6..bbcb9257 100644 --- a/lib/evaluator.tcl +++ b/lib/evaluator.tcl @@ -218,9 +218,11 @@ namespace eval statement { } # Converts a pattern from base form like `the time is /t/` to - # claimized form, `/someone/ claims the time is /t/`. The returned - # pattern is a new heap-allocated Tcl_Obj and should be freed by - # the caller. + # claimized form, `/someone/ claims the time is /t/`. Returns NULL + # if the pattern already has a verb like `claims` or `wishes` in + # second position and shouldn't be claimized. The returned pattern + # is a new heap-allocated Tcl_Obj and should be freed by the + # caller. $cc proc claimizePattern {Tcl_Obj* pattern} Tcl_Obj* { static Tcl_Obj* someoneClaims[2] = {0}; if (someoneClaims[0] == NULL) { @@ -230,6 +232,15 @@ namespace eval statement { Tcl_IncrRefCount(someoneClaims[1]); } + Tcl_Obj* secondWord; + if (Tcl_ListObjIndex(NULL, pattern, 1, &secondWord) == TCL_OK) { + if (secondWord != NULL && + (strcmp(Tcl_GetString(secondWord), "claims") == 0 || + strcmp(Tcl_GetString(secondWord), "wishes") == 0)) { + return NULL; + } + } + // the time is /t/ -> /someone/ claims the time is /t/ Tcl_Obj* ret = Tcl_DuplicateObj(pattern); Tcl_ListObjReplace(NULL, ret, 0, 0, 2, someoneClaims); @@ -655,10 +666,13 @@ namespace eval Statements { ;# singleton Statement store int resultsForFirstPatternCount = searchByPattern(substitutedFirstPattern, maxResultsCount, resultsForFirstPattern); Tcl_Obj* claimizedSubstitutedFirstPattern = claimizePattern(substitutedFirstPattern); - resultsForFirstPatternCount += searchByPattern(claimizedSubstitutedFirstPattern, - maxResultsCount - resultsForFirstPatternCount, &resultsForFirstPattern[resultsForFirstPatternCount]); Tcl_DecrRefCount(substitutedFirstPattern); - Tcl_DecrRefCount(claimizedSubstitutedFirstPattern); + if (claimizedSubstitutedFirstPattern != NULL) { + resultsForFirstPatternCount += searchByPattern(claimizedSubstitutedFirstPattern, + maxResultsCount - resultsForFirstPatternCount, + &resultsForFirstPattern[resultsForFirstPatternCount]); + Tcl_DecrRefCount(claimizedSubstitutedFirstPattern); + } for (int i = 0; i < resultsForFirstPatternCount; i++) { environment_t* result = resultsForFirstPattern[i]; if (env != NULL) { @@ -954,7 +968,10 @@ namespace eval Evaluator { for (int i = 0; i < subpatternsCount; i++) { Tcl_Obj* subpattern = subpatterns[i]; addReaction(subpattern, id, reactToStatementAdditionThatMatchesCollect); - addReaction(claimizePattern(subpattern), id, reactToStatementAdditionThatMatchesCollect); + Tcl_Obj* claimizedSubpattern = claimizePattern(subpattern); + if (claimizedSubpattern != NULL) { + addReaction(claimizedSubpattern, id, reactToStatementAdditionThatMatchesCollect); + } } get(id)->collectNeedsRecollect = true; @@ -967,7 +984,9 @@ namespace eval Evaluator { Tcl_ListObjReplace(interp, pattern, 0, 1, 0, NULL); addReaction(pattern, id, reactToStatementAdditionThatMatchesWhen); Tcl_Obj* claimizedPattern = claimizePattern(pattern); - addReaction(claimizedPattern, id, reactToStatementAdditionThatMatchesWhen); + if (claimizedPattern != NULL) { + addReaction(claimizedPattern, id, reactToStatementAdditionThatMatchesWhen); + } // Scan the existing statement set for any // already-existing matching statements. @@ -978,11 +997,13 @@ namespace eval Evaluator { statement_handle_t alreadyMatchingStatementId = *(statement_handle_t *)&alreadyMatchingStatementIds[i]; reactToStatementAdditionThatMatchesWhen(interp, id, pattern, alreadyMatchingStatementId); } - alreadyMatchingStatementIdsCount = trieLookup(interp, alreadyMatchingStatementIds, 1000, - statementClauseToId, claimizedPattern); - for (int i = 0; i < alreadyMatchingStatementIdsCount; i++) { - statement_handle_t alreadyMatchingStatementId = *(statement_handle_t *)&alreadyMatchingStatementIds[i]; - reactToStatementAdditionThatMatchesWhen(interp, id, claimizedPattern, alreadyMatchingStatementId); + if (claimizedPattern != NULL) { + alreadyMatchingStatementIdsCount = trieLookup(interp, alreadyMatchingStatementIds, 1000, + statementClauseToId, claimizedPattern); + for (int i = 0; i < alreadyMatchingStatementIdsCount; i++) { + statement_handle_t alreadyMatchingStatementId = *(statement_handle_t *)&alreadyMatchingStatementIds[i]; + reactToStatementAdditionThatMatchesWhen(interp, id, claimizedPattern, alreadyMatchingStatementId); + } } } -- cgit v1.2.3 From 0a7fce535e65c87269baa0a7f53fe3158ec2f185 Mon Sep 17 00:00:00 2001 From: Omar Rizwan Date: Wed, 25 Oct 2023 16:30:45 -0400 Subject: c: Allow passing direct structs as pointer args (cheap) --- lib/c.tcl | 12 ++++++++++++ 1 file changed, 12 insertions(+) (limited to 'lib') diff --git a/lib/c.tcl b/lib/c.tcl index 5117840f..1b78cf40 100644 --- a/lib/c.tcl +++ b/lib/c.tcl @@ -309,6 +309,18 @@ namespace eval c { \$argtype \$argname; \$argname = *(($type *)\$obj->internalRep.ptrAndLongRep.ptr); }] + argtype $type* [csubst { + \$argtype \$argname; + if (\$obj->bytes != NULL && \$obj->bytes[0] == '(') { + // If it has a string repr and starts with (. + __ENSURE(sscanf(Tcl_GetString(\$obj), "(\$argtype) 0x%p", &\$argname) == 1); + + } else { + // Otherwise, try to coerce from struct. + __ENSURE_OK(Tcl_ConvertToType(interp, \$obj, &$[set type]_ObjType)); + \$argname = ($type *)\$obj->internalRep.ptrAndLongRep.ptr; + } + }] rtype $type { $robj = Tcl_NewObj(); -- cgit v1.2.3