From 59b0a49139241e2963b91b15a46cdb5fd56e4ba0 Mon Sep 17 00:00:00 2001 From: Omar Rizwan Date: Thu, 25 May 2023 12:19:34 -0400 Subject: Start moving camera to virtual program --- pi/Camera.tcl | 424 +++++++++++++++++++++---------------------- pi/pi.tcl | 47 ----- virtual-programs/camera.folk | 33 ++++ 3 files changed, 245 insertions(+), 259 deletions(-) create mode 100644 virtual-programs/camera.folk diff --git a/pi/Camera.tcl b/pi/Camera.tcl index 9c77570e..ead8152b 100644 --- a/pi/Camera.tcl +++ b/pi/Camera.tcl @@ -1,244 +1,244 @@ source "lib/c.tcl" source "pi/cUtils.tcl" -rename [c create] camc - -camc include -camc include +namespace eval Camera { + rename [c create] camc -camc include -camc include -camc include -camc include -camc include -camc include + camc include + camc include -camc include -camc include + camc include + camc include + camc include + camc include + camc include + camc include -camc include + camc include + camc include -camc struct buffer_t { - uint8_t* start; - size_t length; -} -camc struct camera_t { - int fd; - uint32_t width; - uint32_t height; - size_t buffer_count; - buffer_t* buffers; - buffer_t head; -} + camc include -camc code { - void quit(const char* msg) { - fprintf(stderr, "[%s] %d: %s\n", msg, errno, strerror(errno)); - exit(1); + camc struct buffer_t { + uint8_t* start; + size_t length; + } + camc struct camera_t { + int fd; + uint32_t width; + uint32_t height; + size_t buffer_count; + buffer_t* buffers; + buffer_t head; } - int xioctl(int fd, int request, void* arg) { - for (int i = 0; i < 100; i++) { - int r = ioctl(fd, request, arg); - if (r != -1 || errno != EINTR) return r; - printf("[%x][%d] %s\n", request, i, strerror(errno)); + camc code { + void quit(const char* msg) { + fprintf(stderr, "[%s] %d: %s\n", msg, errno, strerror(errno)); + exit(1); + } + + int xioctl(int fd, int request, void* arg) { + for (int i = 0; i < 100; i++) { + int r = ioctl(fd, request, arg); + if (r != -1 || errno != EINTR) return r; + printf("[%x][%d] %s\n", request, i, strerror(errno)); + } + return -1; } - return -1; } -} -defineImageType camc - -camc proc cameraOpen {char* device int width int height} camera_t* { - printf("device [%s]\n", device); - int fd = open(device, O_RDWR | O_NONBLOCK, 0); - if (fd == -1) quit("open"); - camera_t* camera = malloc(sizeof (camera_t)); - camera->fd = fd; - camera->width = width; - camera->height = height; - camera->buffer_count = 0; - camera->buffers = NULL; - camera->head.length = 0; - camera->head.start = NULL; - return camera; -} + defineImageType camc + + camc proc cameraOpen {char* device int width int height} camera_t* { + printf("device [%s]\n", device); + int fd = open(device, O_RDWR | O_NONBLOCK, 0); + if (fd == -1) quit("open"); + camera_t* camera = malloc(sizeof (camera_t)); + camera->fd = fd; + camera->width = width; + camera->height = height; + camera->buffer_count = 0; + camera->buffers = NULL; + camera->head.length = 0; + camera->head.start = NULL; + return camera; + } -camc proc cameraInit {camera_t* camera} void { - struct v4l2_capability cap; - if (xioctl(camera->fd, VIDIOC_QUERYCAP, &cap) == -1) quit("VIDIOC_QUERYCAP"); - if (!(cap.capabilities & V4L2_CAP_VIDEO_CAPTURE)) quit("no capture"); - if (!(cap.capabilities & V4L2_CAP_STREAMING)) quit("no streaming"); - - struct v4l2_format format; - memset(&format, 0, sizeof format); - format.type = V4L2_BUF_TYPE_VIDEO_CAPTURE; - format.fmt.pix.width = camera->width; - format.fmt.pix.height = camera->height; - format.fmt.pix.pixelformat = V4L2_PIX_FMT_MJPEG; - format.fmt.pix.field = V4L2_FIELD_NONE; - if (xioctl(camera->fd, VIDIOC_S_FMT, &format) == -1) quit("VIDIOC_S_FMT"); - - struct v4l2_requestbuffers req; - memset(&req, 0, sizeof req); - req.count = 4; - req.type = V4L2_BUF_TYPE_VIDEO_CAPTURE; - req.memory = V4L2_MEMORY_MMAP; - if (xioctl(camera->fd, VIDIOC_REQBUFS, &req) == -1) quit("VIDIOC_REQBUFS"); - camera->buffer_count = req.count; - camera->buffers = calloc(req.count, sizeof (buffer_t)); - - size_t buf_max = 0; - for (size_t i = 0; i < camera->buffer_count; i++) { - struct v4l2_buffer buf; - memset(&buf, 0, sizeof buf); - buf.type = V4L2_BUF_TYPE_VIDEO_CAPTURE; - buf.memory = V4L2_MEMORY_MMAP; - buf.index = i; - if (xioctl(camera->fd, VIDIOC_QUERYBUF, &buf) == -1) + camc proc cameraInit {camera_t* camera} void { + struct v4l2_capability cap; + if (xioctl(camera->fd, VIDIOC_QUERYCAP, &cap) == -1) quit("VIDIOC_QUERYCAP"); + if (!(cap.capabilities & V4L2_CAP_VIDEO_CAPTURE)) quit("no capture"); + if (!(cap.capabilities & V4L2_CAP_STREAMING)) quit("no streaming"); + + struct v4l2_format format; + memset(&format, 0, sizeof format); + format.type = V4L2_BUF_TYPE_VIDEO_CAPTURE; + format.fmt.pix.width = camera->width; + format.fmt.pix.height = camera->height; + format.fmt.pix.pixelformat = V4L2_PIX_FMT_MJPEG; + format.fmt.pix.field = V4L2_FIELD_NONE; + if (xioctl(camera->fd, VIDIOC_S_FMT, &format) == -1) quit("VIDIOC_S_FMT"); + + struct v4l2_requestbuffers req; + memset(&req, 0, sizeof req); + req.count = 4; + req.type = V4L2_BUF_TYPE_VIDEO_CAPTURE; + req.memory = V4L2_MEMORY_MMAP; + if (xioctl(camera->fd, VIDIOC_REQBUFS, &req) == -1) quit("VIDIOC_REQBUFS"); + camera->buffer_count = req.count; + camera->buffers = calloc(req.count, sizeof (buffer_t)); + + size_t buf_max = 0; + for (size_t i = 0; i < camera->buffer_count; i++) { + struct v4l2_buffer buf; + memset(&buf, 0, sizeof buf); + buf.type = V4L2_BUF_TYPE_VIDEO_CAPTURE; + buf.memory = V4L2_MEMORY_MMAP; + buf.index = i; + if (xioctl(camera->fd, VIDIOC_QUERYBUF, &buf) == -1) quit("VIDIOC_QUERYBUF"); - if (buf.length > buf_max) buf_max = buf.length; - camera->buffers[i].length = buf.length; - camera->buffers[i].start = + if (buf.length > buf_max) buf_max = buf.length; + camera->buffers[i].length = buf.length; + camera->buffers[i].start = mmap(NULL, buf.length, PROT_READ | PROT_WRITE, MAP_SHARED, camera->fd, buf.m.offset); - if (camera->buffers[i].start == MAP_FAILED) quit("mmap"); - } - camera->head.start = malloc(buf_max); - - printf("camera %d; bufcount %zu\n", camera->fd, camera->buffer_count); -} + if (camera->buffers[i].start == MAP_FAILED) quit("mmap"); + } + camera->head.start = malloc(buf_max); -camc proc cameraStart {camera_t* camera} void { - for (size_t i = 0; i < camera->buffer_count; i++) { - struct v4l2_buffer buf; - memset(&buf, 0, sizeof buf); - buf.type = V4L2_BUF_TYPE_VIDEO_CAPTURE; - buf.memory = V4L2_MEMORY_MMAP; - buf.index = i; - if (xioctl(camera->fd, VIDIOC_QBUF, &buf) == -1) quit("VIDIOC_QBUF"); - printf("camera_start(%zu): %s\n", i, strerror(errno)); + printf("camera %d; bufcount %zu\n", camera->fd, camera->buffer_count); } - enum v4l2_buf_type type = V4L2_BUF_TYPE_VIDEO_CAPTURE; - if (xioctl(camera->fd, VIDIOC_STREAMON, &type) == -1) + camc proc cameraStart {camera_t* camera} void { + for (size_t i = 0; i < camera->buffer_count; i++) { + struct v4l2_buffer buf; + memset(&buf, 0, sizeof buf); + buf.type = V4L2_BUF_TYPE_VIDEO_CAPTURE; + buf.memory = V4L2_MEMORY_MMAP; + buf.index = i; + if (xioctl(camera->fd, VIDIOC_QBUF, &buf) == -1) quit("VIDIOC_QBUF"); + printf("camera_start(%zu): %s\n", i, strerror(errno)); + } + + enum v4l2_buf_type type = V4L2_BUF_TYPE_VIDEO_CAPTURE; + if (xioctl(camera->fd, VIDIOC_STREAMON, &type) == -1) quit("VIDIOC_STREAMON"); -} + } -camc code { -int camera_capture(camera_t* camera) { - struct v4l2_buffer buf; - memset(&buf, 0, sizeof buf); - buf.type = V4L2_BUF_TYPE_VIDEO_CAPTURE; - buf.memory = V4L2_MEMORY_MMAP; - if (xioctl(camera->fd, VIDIOC_DQBUF, &buf) == -1) { - fprintf(stderr, "camera_capture: VIDIOC_DQBUF failed: %d: %s\n", errno, strerror(errno)); - return 0; + camc code { + int camera_capture(camera_t* camera) { + struct v4l2_buffer buf; + memset(&buf, 0, sizeof buf); + buf.type = V4L2_BUF_TYPE_VIDEO_CAPTURE; + buf.memory = V4L2_MEMORY_MMAP; + if (xioctl(camera->fd, VIDIOC_DQBUF, &buf) == -1) { + fprintf(stderr, "camera_capture: VIDIOC_DQBUF failed: %d: %s\n", errno, strerror(errno)); + return 0; + } + memcpy(camera->head.start, camera->buffers[buf.index].start, buf.bytesused); + camera->head.length = buf.bytesused; + if (xioctl(camera->fd, VIDIOC_QBUF, &buf) == -1) { + fprintf(stderr, "camera_capture: VIDIOC_QBUF failed: %d: %s\n", errno, strerror(errno)); + return 0; + } + return 1; + } } - memcpy(camera->head.start, camera->buffers[buf.index].start, buf.bytesused); - camera->head.length = buf.bytesused; - if (xioctl(camera->fd, VIDIOC_QBUF, &buf) == -1) { - fprintf(stderr, "camera_capture: VIDIOC_QBUF failed: %d: %s\n", errno, strerror(errno)); - return 0; + + camc proc cameraFrame {camera_t* camera} int { + struct timeval timeout; + timeout.tv_sec = 1; + timeout.tv_usec = 0; + + fd_set fds; + FD_ZERO(&fds); + FD_SET(camera->fd, &fds); + int r = select(camera->fd + 1, &fds, 0, 0, &timeout); + // printf("r: %d\n", r); + if (r == -1) quit("select"); + if (r == 0) { + printf("selection failed of fd %d\n", camera->fd); + return 0; + } + return camera_capture(camera); } - return 1; -} -} -camc proc cameraFrame {camera_t* camera} int { - struct timeval timeout; - timeout.tv_sec = 1; - timeout.tv_usec = 0; - - fd_set fds; - FD_ZERO(&fds); - FD_SET(camera->fd, &fds); - int r = select(camera->fd + 1, &fds, 0, 0, &timeout); - // printf("r: %d\n", r); - if (r == -1) quit("select"); - if (r == 0) { - printf("selection failed of fd %d\n", camera->fd); - return 0; + camc proc cameraDecompressRgb {camera_t* camera image_t dest} void { + struct jpeg_decompress_struct cinfo; + struct jpeg_error_mgr jerr; + cinfo.err = jpeg_std_error(&jerr); + jpeg_create_decompress(&cinfo); + jpeg_mem_src(&cinfo, camera->head.start, camera->head.length); + if (jpeg_read_header(&cinfo, TRUE) != 1) { + printf("Fail\n"); + exit(1); + } + jpeg_start_decompress(&cinfo); + + while (cinfo.output_scanline < cinfo.output_height) { + unsigned char *buffer_array[1]; + buffer_array[0] = dest.data + (cinfo.output_scanline) * dest.width * cinfo.output_components; + jpeg_read_scanlines(&cinfo, buffer_array, 1); + } + jpeg_finish_decompress(&cinfo); + jpeg_destroy_decompress(&cinfo); } - return camera_capture(camera); -} + camc proc cameraDecompressGray {camera_t* camera image_t dest} void { + struct jpeg_decompress_struct cinfo; + struct jpeg_error_mgr jerr; + cinfo.err = jpeg_std_error(&jerr); + jpeg_create_decompress(&cinfo); + jpeg_mem_src(&cinfo, camera->head.start, camera->head.length); + if (jpeg_read_header(&cinfo, TRUE) != 1) { + printf("Fail\n"); + exit(1); + } + cinfo.out_color_space = JCS_GRAYSCALE; + jpeg_start_decompress(&cinfo); -camc proc cameraDecompressRgb {camera_t* camera image_t dest} void { - struct jpeg_decompress_struct cinfo; - struct jpeg_error_mgr jerr; - cinfo.err = jpeg_std_error(&jerr); - jpeg_create_decompress(&cinfo); - jpeg_mem_src(&cinfo, camera->head.start, camera->head.length); - if (jpeg_read_header(&cinfo, TRUE) != 1) { - printf("Fail\n"); - exit(1); - } - jpeg_start_decompress(&cinfo); - - while (cinfo.output_scanline < cinfo.output_height) { - unsigned char *buffer_array[1]; - buffer_array[0] = dest.data + (cinfo.output_scanline) * dest.width * cinfo.output_components; - jpeg_read_scanlines(&cinfo, buffer_array, 1); - } - jpeg_finish_decompress(&cinfo); - jpeg_destroy_decompress(&cinfo); -} -camc proc cameraDecompressGray {camera_t* camera image_t dest} void { - struct jpeg_decompress_struct cinfo; - struct jpeg_error_mgr jerr; - cinfo.err = jpeg_std_error(&jerr); - jpeg_create_decompress(&cinfo); - jpeg_mem_src(&cinfo, camera->head.start, camera->head.length); - if (jpeg_read_header(&cinfo, TRUE) != 1) { - printf("Fail\n"); - exit(1); - } - cinfo.out_color_space = JCS_GRAYSCALE; - jpeg_start_decompress(&cinfo); - - while (cinfo.output_scanline < cinfo.output_height) { - unsigned char *buffer_array[1]; - buffer_array[0] = dest.data + (cinfo.output_scanline) * dest.width * cinfo.output_components; - jpeg_read_scanlines(&cinfo, buffer_array, 1); - } - jpeg_finish_decompress(&cinfo); - jpeg_destroy_decompress(&cinfo); -} -camc proc rgbToGray {image_t rgb} image_t { - uint8_t* gray = calloc(rgb.width * rgb.height, sizeof (uint8_t)); - for (int y = 0; y < rgb.height; y++) { - for (int x = 0; x < rgb.width; x++) { - // we're spending 10-20% of camera time here on Pi ... ?? - - int i = (y * rgb.width + x) * 3; - uint32_t r = rgb.data[i]; - uint32_t g = rgb.data[i + 1]; - uint32_t b = rgb.data[i + 2]; - // from https://mina86.com/2021/rgb-to-greyscale/ - uint32_t yy = 3567664 * r + 11998547 * g + 1211005 * b; - gray[y * rgb.width + x] = ((yy + (1 << 23)) >> 24); + while (cinfo.output_scanline < cinfo.output_height) { + unsigned char *buffer_array[1]; + buffer_array[0] = dest.data + (cinfo.output_scanline) * dest.width * cinfo.output_components; + jpeg_read_scanlines(&cinfo, buffer_array, 1); } + jpeg_finish_decompress(&cinfo); + jpeg_destroy_decompress(&cinfo); + } + camc proc rgbToGray {image_t rgb} image_t { + uint8_t* gray = calloc(rgb.width * rgb.height, sizeof (uint8_t)); + for (int y = 0; y < rgb.height; y++) { + for (int x = 0; x < rgb.width; x++) { + // we're spending 10-20% of camera time here on Pi ... ?? + + int i = (y * rgb.width + x) * 3; + uint32_t r = rgb.data[i]; + uint32_t g = rgb.data[i + 1]; + uint32_t b = rgb.data[i + 2]; + // from https://mina86.com/2021/rgb-to-greyscale/ + uint32_t yy = 3567664 * r + 11998547 * g + 1211005 * b; + gray[y * rgb.width + x] = ((yy + (1 << 23)) >> 24); + } + } + return (image_t) { + .width = rgb.width, .height = rgb.height, + .bytesPerRow = rgb.width, + .data = gray + }; + } + camc proc freeUint8Buffer {uint8_t* buf} void { + free(buf); } - return (image_t) { - .width = rgb.width, .height = rgb.height, - .bytesPerRow = rgb.width, - .data = gray - }; -} -camc proc freeUint8Buffer {uint8_t* buf} void { - free(buf); -} -camc proc newImage {int width int height int components} image_t { - return (image_t) { width, height, components, width*components, malloc(width*height*components) }; -} -camc proc freeImage {image_t image} void { - free(image.data); -} + camc proc newImage {int width int height int components} image_t { + return (image_t) { width, height, components, width*components, malloc(width*height*components) }; + } + camc proc freeImage {image_t image} void { + free(image.data); + } -c loadlib [expr {$tcl_platform(os) eq "Darwin" ? "/opt/homebrew/lib/libjpeg.dylib" : [lindex [exec /usr/sbin/ldconfig -p | grep libjpeg] end]}] -camc compile + c loadlib [expr {$tcl_platform(os) eq "Darwin" ? "/opt/homebrew/lib/libjpeg.dylib" : [lindex [exec /usr/sbin/ldconfig -p | grep libjpeg] end]}] + camc compile -namespace eval Camera { variable camera variable WIDTH @@ -249,7 +249,8 @@ namespace eval Camera { variable HEIGHT set WIDTH $width set HEIGHT $height - + + variable camera set camera [cameraOpen "/dev/video0" $WIDTH $HEIGHT] cameraInit $camera cameraStart $camera @@ -258,7 +259,6 @@ namespace eval Camera { for {set i 0} {$i < 5} {incr i} { cameraFrame $camera } - set Camera::camera $camera } proc frame {} { diff --git a/pi/pi.tcl b/pi/pi.tcl index 8d073a28..685543cf 100644 --- a/pi/pi.tcl +++ b/pi/pi.tcl @@ -69,53 +69,6 @@ namespace eval Display { } } -# Camera thread -namespace eval Camera { - variable WIDTH 1280 - variable HEIGHT 720 - variable statements [list] - - variable cameraThread [thread::create [format { - source pi/Camera.tcl - Camera::init %d %d - AprilTags::init - puts "Camera tid: [getTid]" - - set grayFrames [list] - while true { - # Hack: we free old images. Really this should be done on - # the main thread when it's actually done with them. - if {[llength $grayFrames] > 10} { - freeImage [lindex $grayFrames 0] - set grayFrames [lreplace $grayFrames 0 0] - } - set cameraTime [time { - set grayFrame [Camera::grayFrame] - set tags [AprilTags::detect $grayFrame] - lappend grayFrames $grayFrame - }] - set statements [list] - lappend statements [list camera claims the camera time is $cameraTime] - lappend statements [list camera claims the camera frame is $grayFrame] - foreach tag $tags { - lappend statements [list camera claims tag [dict get $tag id] has center [dict get $tag center] size [dict get $tag size]] - lappend statements [list camera claims tag [dict get $tag id] has corners [dict get $tag corners]] - } - - # send this script back to the main Folk thread - # puts "\n\nCommands\n-----\n[join $commands \"\n\"]" - thread::send -async "%s" [list set Camera::statements $statements] - } - } $WIDTH $HEIGHT [thread::id]]] - puts "Camera thread id: $cameraThread" - - Assert when $::nodename has step count /c/ { - foreach stmt $Camera::statements { - Say {*}$stmt - } - } -} - try { set keyboardThread [thread::create [format { source "pi/Keyboard.tcl" diff --git a/virtual-programs/camera.folk b/virtual-programs/camera.folk new file mode 100644 index 00000000..40950eb9 --- /dev/null +++ b/virtual-programs/camera.folk @@ -0,0 +1,33 @@ +if {$::isLaptop} return + +On process { + source pi/Camera.tcl + # FIXME: do these in outer scope + Camera::init 1280 720 + puts "Camera tid: [getTid]" + + set grayFrames [list] + while true { + # Hack: we free old images. Really this should be done on + # the main thread when it's actually done with them. + if {[llength $grayFrames] > 10} { + Camera::freeImage [lindex $grayFrames 0] + set grayFrames [lreplace $grayFrames 0 0] + } + set cameraTime [time { set grayFrame [Camera::grayFrame] }] + lappend grayFrames $grayFrame + + Commit camera { + Claim the camera time is $cameraTime + Claim the camera frame is $grayFrame + } + Step + } +} + +# AprilTags::init + # foreach tag $tags { + # Claim tag [dict get $tag id] has center [dict get $tag center] size [dict get $tag size] + # Claim tag [dict get $tag id] has corners [dict get $tag corners] + # } + -- cgit v1.2.3 From 1e002774e3724f21aebfea0d9e64f7dc8bd6c9a0 Mon Sep 17 00:00:00 2001 From: Omar Rizwan Date: Thu, 25 May 2023 12:59:36 -0400 Subject: Allow bare When/Claim in subprocess --- lib/process.tcl | 5 ++++- main.tcl | 6 ------ test/process.tcl | 21 ++++++++++++++++++--- 3 files changed, 22 insertions(+), 10 deletions(-) diff --git a/lib/process.tcl b/lib/process.tcl index 71dadcf8..d91e4485 100644 --- a/lib/process.tcl +++ b/lib/process.tcl @@ -19,7 +19,10 @@ proc On-process {name body} { set ::Processes::${name}::this [uplevel {expr {[info exists this] ? $this : ""}}] namespace eval ::Processes::$name { variable tclfd [file tempfile tclfile tclfile.tcl] - set body [list Evaluator::runInSerializedEnvironment $body [list]] + set body [format { + Assert claims has program code {%s} + Step + } $body] puts $tclfd [join [list $::processPrelude $body] "\n"]; close $tclfd # TODO: send it the serialized environment diff --git a/main.tcl b/main.tcl index 727f9b0c..83b35c00 100644 --- a/main.tcl +++ b/main.tcl @@ -671,12 +671,6 @@ proc Step {} { foreach peer [namespace children Peers] { namespace eval $peer { - if {[info exists shareStatements]} { - variable prevShareStatements $shareStatements - } else { - variable prevShareStatements [list] - } - variable shareStatements [list] if {[llength [Statements::findMatches [list /someone/ wishes $::nodename shares all statements]]] > 0} { dict for {_ stmt} $Statements::statements { diff --git a/test/process.tcl b/test/process.tcl index 3a58a0b9..4e76b7de 100644 --- a/test/process.tcl +++ b/test/process.tcl @@ -17,7 +17,7 @@ Assert when we are running { } } Step -vwait good +vwait ::good Assert when we are running { puts "Core: $::nodename" @@ -27,14 +27,29 @@ Assert when we are running { incr n Commit { Claim the counter is $n } Step + if {$n > 10} { break } } } When the counter is /n/ { if {$n > 5} { - set ::done true + set ::ok true } } } Step -vwait done +vwait ::ok + +Assert when we are running { + On process { + Claim I am in a process + When I am in a process { + Commit { Claim we were in a process } + } + When we were in a process { + set ::wereinaprocess true + } + } +} +Step +vwait ::wereinaprocess -- cgit v1.2.3 From 82f797cbb37432755bbf6a07241e843e90282f1e Mon Sep 17 00:00:00 2001 From: Omar Rizwan Date: Thu, 25 May 2023 14:49:07 -0400 Subject: Implement bidirectional peering & receive statements --- lib/peer.tcl | 13 +++++++++++- lib/process.tcl | 6 ++++-- main.tcl | 60 +++++++++++++++++++++++++++++--------------------------- test/process.tcl | 18 +++++++++++++++++ web.tcl | 7 ++++--- 5 files changed, 69 insertions(+), 35 deletions(-) diff --git a/lib/peer.tcl b/lib/peer.tcl index e79bad5f..1156f42d 100644 --- a/lib/peer.tcl +++ b/lib/peer.tcl @@ -30,7 +30,18 @@ proc ::peer {node} { ::websocket::send $sock text $msg } - proc init {n} { variable node $n; setupSock } + proc init {n} { + variable node $n; setupSock + vwait Peers::${n}::connected + + run [format { + namespace eval Peers::%s [format { + proc run {msg} { + ::websocket::send %%s text $msg + } + } $chan] + } $::nodename] + } init } $node } diff --git a/lib/process.tcl b/lib/process.tcl index d91e4485..ade9a93f 100644 --- a/lib/process.tcl +++ b/lib/process.tcl @@ -6,10 +6,11 @@ set ::processPrelude { } Assert $::nodename wishes $::nodename shares all claims + Assert $::nodename wishes $::nodename shares statements like \ + [list /someone/ wishes $::nodename receives statements like /pattern/] source "lib/peer.tcl" - peer "localhost" - vwait Peers::localhost::connected + ::peer "localhost" } proc On-process {name body} { @@ -22,6 +23,7 @@ proc On-process {name body} { set body [format { Assert claims has program code {%s} Step + vwait forever } $body] puts $tclfd [join [list $::processPrelude $body] "\n"]; close $tclfd diff --git a/main.tcl b/main.tcl index 83b35c00..b9a69038 100644 --- a/main.tcl +++ b/main.tcl @@ -670,37 +670,39 @@ proc Step {} { } foreach peer [namespace children Peers] { - namespace eval $peer { - variable shareStatements [list] - if {[llength [Statements::findMatches [list /someone/ wishes $::nodename shares all statements]]] > 0} { - dict for {_ stmt} $Statements::statements { + set peer [namespace tail $peer] + + variable shareStatements [list] + if {[llength [Statements::findMatches [list /someone/ wishes $::nodename shares all statements]]] > 0} { + dict for {_ stmt} $Statements::statements { + lappend shareStatements [statement clause $stmt] + } + } elseif {[llength [Statements::findMatches [list /someone/ wishes $::nodename shares all claims]]] > 0} { + dict for {_ stmt} $Statements::statements { + if {[lindex [statement clause $stmt] 1] eq "claims"} { lappend shareStatements [statement clause $stmt] } - } elseif {[llength [Statements::findMatches [list /someone/ wishes $::nodename shares all claims]]] > 0} { - dict for {_ stmt} $Statements::statements { - if {[lindex [statement clause $stmt] 1] eq "claims"} { - lappend shareStatements [statement clause $stmt] - } - } } - foreach m [Statements::findMatches [list /someone/ wishes $::nodename shares statements like /pattern/]] { - set pattern [dict get $m pattern] - foreach id [trie lookup $Statements::statementClauseToId $pattern] { - set clause [statement clause [Statements::get $id]] - set match [statement unify $pattern $clause] - if {$match != false} { - lappend shareStatements $clause - } + } + set matches [Statements::findMatches [list /someone/ wishes $::nodename shares statements like /pattern/]] + lappend matches {*}[Statements::findMatches [list /someone/ wishes $peer receives statements like /pattern/]] + foreach m $matches { + set pattern [dict get $m pattern] + foreach id [trie lookup $Statements::statementClauseToId $pattern] { + set clause [statement clause [Statements::get $id]] + set match [statement unify $pattern $clause] + if {$match != false} { + lappend shareStatements $clause } } - - incr sequenceNumber - run [subst { - Assert $::nodename shares statements {$shareStatements} with sequence number $sequenceNumber - Retract $::nodename shares statements /any/ with sequence number [expr {$sequenceNumber - 1}] - Step - }] } + + set sequenceNumber [incr Peers::${peer}::sequenceNumber] + Peers::${peer}::run [subst { + Assert $::nodename shares statements {$shareStatements} with sequence number $sequenceNumber + Retract $::nodename shares statements /any/ with sequence number [expr {$sequenceNumber - 1}] + Step + }] } if {[uplevel {Evaluator::isRunningInSerializedEnvironment}]} { @@ -717,14 +719,14 @@ Assert when /this/ has program code /__code/ { eval $__code } +Assert when /peer/ shares statements /statements/ with sequence number /gen/ { + foreach stmt $statements { Say {*}$stmt } +} + if {[info exists ::entry]} { # This all only runs if we're in a primary Folk process; we don't # want it to run in subprocesses (which also run main.tcl). - Assert when /peer/ shares statements /statements/ with sequence number /gen/ { - foreach stmt $statements { Say {*}$stmt } - } - source "lib/process.tcl" source "./web.tcl" source $::entry diff --git a/test/process.tcl b/test/process.tcl index 4e76b7de..ca6058f1 100644 --- a/test/process.tcl +++ b/test/process.tcl @@ -53,3 +53,21 @@ Assert when we are running { } Step vwait ::wereinaprocess + +Assert when we are running { + On process { + Wish $::nodename receives statements like [list /x/ claims the main process exists] + When the main process exists { + Commit { + Claim the subprocess heard that the main process exists + } + Step + } + } + Claim the main process exists + When the subprocess heard that the main process exists { + set ::heard true + } +} +Step +vwait ::heard diff --git a/web.tcl b/web.tcl index 652ab5da..90f2383c 100644 --- a/web.tcl +++ b/web.tcl @@ -103,7 +103,7 @@ proc handlePage {path contentTypeVar} { proc handleRead {chan addr port} { chan configure $chan -translation crlf gets $chan line; set firstline $line - puts "Http: $chan $addr $port: $line" + # puts "Http: $chan $addr $port: $line" set headers [list] while {[gets $chan line] >= 0 && $line ne ""} { if {[regexp -expanded {^( [^\s:]+ ) \s* : \s* (.+)} $line -> k v]} { @@ -140,7 +140,7 @@ proc handleRead {chan addr port} { } close $chan } elseif {[::websocket::test $::serverSock $chan "/ws" $headers]} { - puts "WS: $chan $addr $port" + # puts "WS: $chan $addr $port" ::websocket::upgrade $chan # from now the handleWS will be called (not anymore handleRead). } else { puts "Closing: $chan $addr $port $headers"; close $chan } @@ -148,6 +148,7 @@ proc handleRead {chan addr port} { proc handleWS {chan type msg} { if {$type eq "connect" || $type eq "ping" || $type eq "pong"} { + puts "Event $type from chan $chan" } elseif {$type eq "text"} { if {[catch {::websocket::send $chan text [eval $msg]} err] == 1} { if [catch { @@ -156,7 +157,7 @@ proc handleWS {chan type msg} { } err2] { puts "$::nodename: $err2" } } } else { - puts "$::nodename: Unhandled WS event $type $msg" + puts "$::nodename: Unhandled WS event $type on $chan ($msg)" } } -- cgit v1.2.3 From f472f8a7a57caef18b282f14bfb08f810ac78775 Mon Sep 17 00:00:00 2001 From: Omar Rizwan Date: Thu, 25 May 2023 23:49:26 -0400 Subject: WIP: Start implementing AprilTag detector. defineFolkImages shm --- lib/c.tcl | 2 +- pi/AprilTags.tcl | 65 +++++++++++++++++++++++ pi/Camera.tcl | 83 ++++++------------------------ pi/cUtils.tcl | 22 ++++++++ virtual-programs/camera.folk | 41 +++++++-------- virtual-programs/tags-and-calibration.folk | 5 ++ web.tcl | 2 +- 7 files changed, 129 insertions(+), 91 deletions(-) create mode 100644 pi/AprilTags.tcl diff --git a/lib/c.tcl b/lib/c.tcl index 81819606..bd6e6951 100644 --- a/lib/c.tcl +++ b/lib/c.tcl @@ -161,7 +161,7 @@ namespace eval c { set frame [info frame -2] if {[dict exists $frame line] && [dict exists $frame file] && [dict get $frame line] >= 0} { - #subst {#line [dict get $frame line] "[dict get $frame file]"} + subst {#line [dict get $frame line] "[dict get $frame file]"} } else { list } } ::proc code {newcode} { diff --git a/pi/AprilTags.tcl b/pi/AprilTags.tcl new file mode 100644 index 00000000..8d3b8a06 --- /dev/null +++ b/pi/AprilTags.tcl @@ -0,0 +1,65 @@ +source "pi/cUtils.tcl" + +namespace eval AprilTags { + rename [c create] apc + apc cflags -I$::env(HOME)/apriltag + apc include + apc include + apc include + apc include + apc code { + apriltag_detector_t *td; + apriltag_family_t *tf; + } + defineImageType apc + defineFolkImages apc + + apc proc detectInit {} void { + folkImagesMount(); + td = apriltag_detector_create(); + tf = tagStandard52h13_create(); + apriltag_detector_add_family_bits(td, tf, 1); + td->nthreads = 2; + } + + apc proc detect {image_t gray} Tcl_Obj* { + assert(gray.components == 1); + image_u8_t im = (image_u8_t) { .width = gray.width, .height = gray.height, .stride = gray.width, .buf = gray.data }; + + zarray_t *detections = apriltag_detector_detect(td, &im); + int detectionCount = zarray_size(detections); + + Tcl_Obj* detectionObjs[detectionCount]; + for (int i = 0; i < detectionCount; i++) { + apriltag_detection_t *det; + zarray_get(detections, i, &det); + + int size = sqrt((det->p[0][0] - det->p[1][0])*(det->p[0][0] - det->p[1][0]) + (det->p[0][1] - det->p[1][1])*(det->p[0][1] - det->p[1][1])); + detectionObjs[i] = Tcl_ObjPrintf("id %d center {%f %f} corners {{%f %f} {%f %f} {%f %f} {%f %f}} size %d", + det->id, + det->c[0], det->c[1], + det->p[0][0], det->p[0][1], + det->p[1][0], det->p[1][1], + det->p[2][0], det->p[2][1], + det->p[3][0], det->p[3][1], + size); + } + + + zarray_destroy(detections); + Tcl_Obj* result = Tcl_NewListObj(detectionCount, detectionObjs); + return result; + } + + apc proc detectCleanup {} void { + tagStandard52h13_destroy(tf); + apriltag_detector_destroy(td); + } + + c loadlib $::env(HOME)/apriltag/libapriltag.so + apc compile + + proc init {} { + detectInit + } +} diff --git a/pi/Camera.tcl b/pi/Camera.tcl index ead8152b..d1a06f4d 100644 --- a/pi/Camera.tcl +++ b/pi/Camera.tcl @@ -48,6 +48,7 @@ namespace eval Camera { } } defineImageType camc + defineFolkImages camc camc proc cameraOpen {char* device int width int height} camera_t* { printf("device [%s]\n", device); @@ -225,15 +226,22 @@ namespace eval Camera { .data = gray }; } - camc proc freeUint8Buffer {uint8_t* buf} void { - free(buf); - } camc proc newImage {int width int height int components} image_t { - return (image_t) { width, height, components, width*components, malloc(width*height*components) }; + static int imageCount = 0; + imageCount = (imageCount + 1) % 20; + + uint8_t* data = folkImagesBase + imageCount * (width*components*height); + return (image_t) { + .width = width, + .height = height, + .components = components, + .bytesPerRow = width*components, + .data = data + }; } camc proc freeImage {image_t image} void { - free(image.data); + // free(image.data); } c loadlib [expr {$tcl_platform(os) eq "Darwin" ? "/opt/homebrew/lib/libjpeg.dylib" : [lindex [exec /usr/sbin/ldconfig -p | grep libjpeg] end]}] @@ -250,6 +258,8 @@ namespace eval Camera { set WIDTH $width set HEIGHT $height + folkImagesMount + variable camera set camera [cameraOpen "/dev/video0" $WIDTH $HEIGHT] cameraInit $camera @@ -302,66 +312,3 @@ if {([info exists ::argv0] && $::argv0 eq [info script]) || \ freeImage $rgb } } - - -namespace eval AprilTags { - rename [c create] apc - apc cflags -I$::env(HOME)/apriltag - apc include - apc include - apc include - apc include - apc code { - apriltag_detector_t *td; - apriltag_family_t *tf; - } - defineImageType apc - - apc proc detectInit {} void { - td = apriltag_detector_create(); - tf = tagStandard52h13_create(); - apriltag_detector_add_family_bits(td, tf, 1); - td->nthreads = 2; - } - - apc proc detect {image_t gray} Tcl_Obj* { - assert(gray.components == 1); - image_u8_t im = (image_u8_t) { .width = gray.width, .height = gray.height, .stride = gray.width, .buf = gray.data }; - - zarray_t *detections = apriltag_detector_detect(td, &im); - int detectionCount = zarray_size(detections); - - Tcl_Obj* detectionObjs[detectionCount]; - for (int i = 0; i < detectionCount; i++) { - apriltag_detection_t *det; - zarray_get(detections, i, &det); - - int size = sqrt((det->p[0][0] - det->p[1][0])*(det->p[0][0] - det->p[1][0]) + (det->p[0][1] - det->p[1][1])*(det->p[0][1] - det->p[1][1])); - detectionObjs[i] = Tcl_ObjPrintf("id %d center {%f %f} corners {{%f %f} {%f %f} {%f %f} {%f %f}} size %d", - det->id, - det->c[0], det->c[1], - det->p[0][0], det->p[0][1], - det->p[1][0], det->p[1][1], - det->p[2][0], det->p[2][1], - det->p[3][0], det->p[3][1], - size); - } - - - zarray_destroy(detections); - Tcl_Obj* result = Tcl_NewListObj(detectionCount, detectionObjs); - return result; - } - - apc proc detectCleanup {} void { - tagStandard52h13_destroy(tf); - apriltag_detector_destroy(td); - } - - c loadlib $::env(HOME)/apriltag/libapriltag.so - apc compile - - proc init {} { - detectInit - } -} diff --git a/pi/cUtils.tcl b/pi/cUtils.tcl index 8c15296f..9fd4439d 100644 --- a/pi/cUtils.tcl +++ b/pi/cUtils.tcl @@ -29,3 +29,25 @@ proc ::defineImageType {cc} { $robj = Tcl_ObjPrintf("width %u height %u components %d bytesPerRow %u data 0x%" PRIxPTR, $rvalue.width, $rvalue.height, $rvalue.components, $rvalue.bytesPerRow, (uintptr_t) $rvalue.data); } } + +proc ::defineFolkImages {cc} { + set cc [uplevel {namespace current}]::$cc + $cc include + $cc include + $cc include + $cc include + $cc include + $cc code { + uint8_t* folkImagesBase = (uint8_t*) 0x280000000; + size_t folkImagesSize = 1000000000; + } + $cc proc folkImagesMount {} void { + int fd = shm_open("/folk-images", O_RDWR | O_CREAT, S_IROTH | S_IWOTH | S_IRUSR | S_IWUSR); + ftruncate(fd, folkImagesSize); + void* ptr = mmap(folkImagesBase, folkImagesSize, + PROT_READ | PROT_WRITE, MAP_SHARED | MAP_FIXED, fd, 0); + if (ptr == NULL || ptr != folkImagesBase) { + fprintf(stderr, "shmMount: failed"); exit(1); + } + } +} diff --git a/virtual-programs/camera.folk b/virtual-programs/camera.folk index 40950eb9..4075162c 100644 --- a/virtual-programs/camera.folk +++ b/virtual-programs/camera.folk @@ -1,33 +1,32 @@ if {$::isLaptop} return +namespace eval ::Camera { + variable WIDTH 1280 + variable HEIGHT 720 +} + On process { source pi/Camera.tcl # FIXME: do these in outer scope Camera::init 1280 720 puts "Camera tid: [getTid]" - set grayFrames [list] - while true { - # Hack: we free old images. Really this should be done on - # the main thread when it's actually done with them. - if {[llength $grayFrames] > 10} { - Camera::freeImage [lindex $grayFrames 0] - set grayFrames [lreplace $grayFrames 0 0] - } - set cameraTime [time { set grayFrame [Camera::grayFrame] }] - lappend grayFrames $grayFrame +} - Commit camera { - Claim the camera time is $cameraTime - Claim the camera frame is $grayFrame +On process { + Wish $::nodename receives statements like [list /someone/ claims the camera frame is /frame/] + + source pi/AprilTags.tcl + AprilTags::init + + When the camera frame is /frame/ { + set aprilTime [time { set tags [AprilTags::detect $frame] }] + Commit { + Claim the AprilTag time is $aprilTime + foreach tag $tags { + Claim tag [dict get $tag id] has center [dict get $tag center] size [dict get $tag size] + Claim tag [dict get $tag id] has corners [dict get $tag corners] + } } - Step } } - -# AprilTags::init - # foreach tag $tags { - # Claim tag [dict get $tag id] has center [dict get $tag center] size [dict get $tag size] - # Claim tag [dict get $tag id] has corners [dict get $tag corners] - # } - diff --git a/virtual-programs/tags-and-calibration.folk b/virtual-programs/tags-and-calibration.folk index d6c4fad7..36086099 100644 --- a/virtual-programs/tags-and-calibration.folk +++ b/virtual-programs/tags-and-calibration.folk @@ -2,6 +2,11 @@ Wish $this has filename "tags-and-calibration.folk" if {$::isLaptop} { return } +namespace eval ::Camera { + variable WIDTH 1280 + variable HEIGHT 720 +} + package require math::linearalgebra namespace import ::math::linearalgebra::add \ ::math::linearalgebra::sub \ diff --git a/web.tcl b/web.tcl index 90f2383c..4af9ade5 100644 --- a/web.tcl +++ b/web.tcl @@ -148,7 +148,7 @@ proc handleRead {chan addr port} { proc handleWS {chan type msg} { if {$type eq "connect" || $type eq "ping" || $type eq "pong"} { - puts "Event $type from chan $chan" + # puts "Event $type from chan $chan" } elseif {$type eq "text"} { if {[catch {::websocket::send $chan text [eval $msg]} err] == 1} { if [catch { -- cgit v1.2.3 From 87eff0f909898e4a6180bcca82be3a92869bad1d Mon Sep 17 00:00:00 2001 From: Charles Chamberlain Date: Thu, 1 Jun 2023 15:21:42 -0400 Subject: Fix bug in process naming: choose unique names in same file --- lib/process.tcl | 4 ++++ main.tcl | 9 ++++++++- virtual-programs/camera.folk | 1 - 3 files changed, 12 insertions(+), 2 deletions(-) diff --git a/lib/process.tcl b/lib/process.tcl index ade9a93f..1c86c6d5 100644 --- a/lib/process.tcl +++ b/lib/process.tcl @@ -1,4 +1,8 @@ set ::processPrelude { + if {[info exists ::entry]} { + return; # don't run if we're in the main process + } + source "main.tcl" proc every {ms body} { try $body diff --git a/main.tcl b/main.tcl index b9a69038..5ba2e113 100644 --- a/main.tcl +++ b/main.tcl @@ -604,12 +604,19 @@ proc Every {event args} { uplevel [list When {*}$pattern "$body\nEvaluator::Unmatch $level"] } } + proc On {event args} { if {$event eq "process"} { if {[llength $args] == 2} { lassign $args name body } elseif {[llength $args] == 1} { - set name "${::matchId}-process" + + if {![info exists ::SerializableEnvironment::nextSubprocessId]} { + set ::SerializableEnvironment::nextSubprocessId 0 + } + set subprocessId [incr ::SerializableEnvironment::nextSubprocessId] + + set name "${::matchId}-${subprocessId}-process" set body [lindex $args 0] } uplevel [list On-process $name $body] diff --git a/virtual-programs/camera.folk b/virtual-programs/camera.folk index 4075162c..f161ce11 100644 --- a/virtual-programs/camera.folk +++ b/virtual-programs/camera.folk @@ -10,7 +10,6 @@ On process { # FIXME: do these in outer scope Camera::init 1280 720 puts "Camera tid: [getTid]" - } On process { -- cgit v1.2.3 From ebfbdd3f392e3d327692a159d89b00f96db93106 Mon Sep 17 00:00:00 2001 From: Charles Chamberlain Date: Thu, 1 Jun 2023 16:41:46 -0400 Subject: Getting one camera frame from a thread --- lib/process.tcl | 12 +++++++++++- pi/Camera.tcl | 14 ++++++++++++++ virtual-programs/camera.folk | 8 ++++++++ 3 files changed, 33 insertions(+), 1 deletion(-) diff --git a/lib/process.tcl b/lib/process.tcl index 1c86c6d5..aa813e1c 100644 --- a/lib/process.tcl +++ b/lib/process.tcl @@ -58,7 +58,17 @@ proc On-process {name body} { proc handleUnmatch {} { variable pid variable name - catch {exec kill $pid} + variable stdio + close $stdio + exec kill -9 $pid + while {1} { + try { + exec kill -0 $pid + } on error err { + break + } + puts "waiting for unmatch kill to work" + } Retract /someone/ is running process $name Retract process $name has standard output log /something/ namespace delete ::Processes::$name diff --git a/pi/Camera.tcl b/pi/Camera.tcl index d1a06f4d..4832348d 100644 --- a/pi/Camera.tcl +++ b/pi/Camera.tcl @@ -260,6 +260,20 @@ namespace eval Camera { folkImagesMount + try { + while {1} { + set pid [exec lsof -t "/dev/video0"] + if {$pid eq ""} break + exec kill -9 $pid + } + } on error err { + puts "got an error when trying to claim the video input as our own: ${err}" + } + + # FIXME: This is bad. Something about the state of /dev/video0 makes the ioctl in cameraInit + # return "device busy" - sleeping helps... + exec sleep .5 + variable camera set camera [cameraOpen "/dev/video0" $WIDTH $HEIGHT] cameraInit $camera diff --git a/virtual-programs/camera.folk b/virtual-programs/camera.folk index f161ce11..b82c306d 100644 --- a/virtual-programs/camera.folk +++ b/virtual-programs/camera.folk @@ -10,6 +10,14 @@ On process { # FIXME: do these in outer scope Camera::init 1280 720 puts "Camera tid: [getTid]" + + while true { + set grayFrame [Camera::grayFrame] + Commit { + Claim the camera frame is $grayFrame; + } + Step + } } On process { -- cgit v1.2.3 From cb04cba2092b85cd108e1e10828b054bbf59ecbd Mon Sep 17 00:00:00 2001 From: Charles Chamberlain Date: Thu, 1 Jun 2023 16:47:55 -0400 Subject: Red error messages in web UI --- web.tcl | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/web.tcl b/web.tcl index 4af9ade5..b7ab84b8 100644 --- a/web.tcl +++ b/web.tcl @@ -33,7 +33,10 @@ proc handlePage {path contentTypeVar} { lappend l [subst {
  • - $id: [htmlEscape [statement short $stmt]] + $id: [htmlEscape [statement short $stmt]] 
    [htmlEscape [statement clause $stmt]]
    • -- cgit v1.2.3 From d43ebc6181dd8883831915f934247b447f1f8905 Mon Sep 17 00:00:00 2001 From: Charles Chamberlain Date: Thu, 1 Jun 2023 17:45:11 -0400 Subject: Use chan open for process execution --- lib/process.tcl | 24 ++++++++++++++---------- main.tcl | 14 +++++++++----- 2 files changed, 23 insertions(+), 15 deletions(-) diff --git a/lib/process.tcl b/lib/process.tcl index aa813e1c..77601a17 100644 --- a/lib/process.tcl +++ b/lib/process.tcl @@ -32,24 +32,28 @@ proc On-process {name body} { puts $tclfd [join [list $::processPrelude $body] "\n"]; close $tclfd # TODO: send it the serialized environment - variable stdio [open "|tclsh8.6 $tclfile 2>@1" w+] - variable pid [pid $stdio] + variable stdout_reader; variable stdout_writer + lassign [chan pipe] stdout_reader stdout_writer + + set pid [exec tclsh8.6 $tclfile >@ $stdout_writer 2>@ $stdout_writer &] variable log [list] proc handleReadable {} { variable name - variable stdio variable log - if {[gets $stdio line] >= 0} { + if {[gets $stdout_reader line] >= 0} { lappend log $line - puts "$name: $line" + puts "$name: $line **" Retract process $name has standard output log /l/ Assert process $name has standard output log $log Step - } elseif {[eof $stdio]} { close $stdio } + } elseif {[eof $stdout_reader]} { + close $stdout_reader + } } - fconfigure $stdio -blocking 0 -buffering line - fileevent $stdio readable [namespace code handleReadable] + # fconfigure $stdio -blocking 0 -buffering line + fconfigure $stdout_reader -blocking 0 -buffering line + fileevent $stdout_reader readable [namespace code handleReadable] if {$this ne ""} { Assert $this is running process $name @@ -58,8 +62,8 @@ proc On-process {name body} { proc handleUnmatch {} { variable pid variable name - variable stdio - close $stdio + variable stdout_reader + close $stdout_reader exec kill -9 $pid while {1} { try { diff --git a/main.tcl b/main.tcl index 5ba2e113..405ed4ce 100644 --- a/main.tcl +++ b/main.tcl @@ -705,11 +705,15 @@ proc Step {} { } set sequenceNumber [incr Peers::${peer}::sequenceNumber] - Peers::${peer}::run [subst { - Assert $::nodename shares statements {$shareStatements} with sequence number $sequenceNumber - Retract $::nodename shares statements /any/ with sequence number [expr {$sequenceNumber - 1}] - Step - }] + try { + Peers::${peer}::run [subst { + Assert $::nodename shares statements {$shareStatements} with sequence number $sequenceNumber + Retract $::nodename shares statements /any/ with sequence number [expr {$sequenceNumber - 1}] + Step + }] + } on error err { + puts stderr "error from peer $peer: $err" + } } if {[uplevel {Evaluator::isRunningInSerializedEnvironment}]} { -- cgit v1.2.3 From 38b17c5d6c96d3f4cc4da3a9623d3990e87bfe8e Mon Sep 17 00:00:00 2001 From: Omar Rizwan Date: Fri, 26 May 2023 10:49:28 -0400 Subject: Add shm test --- test/shm.tcl | 66 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 66 insertions(+) create mode 100644 test/shm.tcl diff --git a/test/shm.tcl b/test/shm.tcl new file mode 100644 index 00000000..78e93902 --- /dev/null +++ b/test/shm.tcl @@ -0,0 +1,66 @@ +proc assert condition { + set s "{$condition}" + if {![uplevel 1 expr $s]} { + return -code error "assertion failed: $condition" + } +} + + +Assert we are running +Assert when we are running { + On process { + set cc [c create] + $cc include + $cc include + $cc include + $cc include + $cc include + $cc proc shmMount {char* name size_t size void* addr} void { + int fd = shm_open(name, O_RDWR | O_CREAT, S_IROTH | S_IWOTH | S_IRUSR | S_IWUSR); + ftruncate(fd, size); + void* ptr = mmap(addr, size, PROT_READ | PROT_WRITE, MAP_SHARED | MAP_FIXED, fd, 0); + if (ptr == NULL || ptr != addr) { + fprintf(stderr, "shmMount: failed"); exit(1); + } + } + $cc proc blup {} void { + void* ptr = (void*)0x280000000; + shmMount("/folk-images", 1000000000, ptr); + + char* s = (char*)ptr; + snprintf(s, 100, "Hello!"); + } + $cc compile + blup + } + + On process { + set cc [c create] + $cc include + $cc include + $cc include + $cc include + $cc include + $cc proc shmMount {char* name size_t size void* addr} void { + int fd = shm_open(name, O_RDWR | O_CREAT, S_IROTH | S_IWOTH | S_IRUSR | S_IWUSR); + ftruncate(fd, size); + void* ptr = mmap(addr, size, PROT_READ | PROT_WRITE, MAP_SHARED | MAP_FIXED, fd, 0); + if (ptr == NULL || ptr != addr) { + fprintf(stderr, "shmMount: failed"); exit(1); + } + } + $cc proc blup {} void { + void* ptr = (void*)0x280000000; + shmMount("/folk-images", 1000000000, ptr); + + char* s = (char*)ptr; + printf("[%s]\n", s); + } + $cc compile + blup + } +} +Step + +after 1000 {set done true} +vwait done -- cgit v1.2.3 From 566401baaa17659ec9a6765d1b0c551e5c51deb1 Mon Sep 17 00:00:00 2001 From: Omar Rizwan Date: Fri, 2 Jun 2023 17:42:25 -0400 Subject: Fix handleReadable --- lib/process.tcl | 1 + 1 file changed, 1 insertion(+) diff --git a/lib/process.tcl b/lib/process.tcl index 7b7ad2e6..9ecfb4d2 100644 --- a/lib/process.tcl +++ b/lib/process.tcl @@ -41,6 +41,7 @@ proc On-process {name body} { proc handleReadable {} { variable name variable log + variable stdout_reader if {[gets $stdout_reader line] >= 0} { lappend log $line puts "$name: $line **" -- cgit v1.2.3 From a73c8a2034871390a0d045184f6b50c702120e8e Mon Sep 17 00:00:00 2001 From: Omar Rizwan Date: Thu, 15 Jun 2023 02:55:30 -0400 Subject: Fix(?) bidirectional peering --- lib/peer.tcl | 10 ++++++---- main.tcl | 2 +- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/lib/peer.tcl b/lib/peer.tcl index a93a936e..3f10189d 100644 --- a/lib/peer.tcl +++ b/lib/peer.tcl @@ -17,11 +17,11 @@ namespace eval clauseset { namespace ensemble create } -namespace eval Peers {} +namespace eval ::Peers {} proc ::peer {node} { package require websocket - namespace eval Peers::$node { + namespace eval ::Peers::$node { variable connected false variable prevShareStatements [clauseset create] @@ -60,10 +60,12 @@ proc ::peer {node} { proc init {n} { variable node $n; setupSock - vwait Peers::${n}::connected + vwait ::Peers::${n}::connected run [format { - namespace eval Peers::%s [format { + namespace eval ::Peers::%s [format { + variable connected true + variable prevShareStatements [clauseset create] proc run {msg} { ::websocket::send %%s text $msg } diff --git a/main.tcl b/main.tcl index def9813c..1d05f94d 100644 --- a/main.tcl +++ b/main.tcl @@ -192,7 +192,7 @@ proc Step {} { Display::commit ;# TODO: this is weird, not right level } - foreach peerNs [namespace children Peers] { + foreach peerNs [namespace children ::Peers] { apply [list {peer} { variable connected if {!$connected} { return } -- cgit v1.2.3 From dc4aed49961214305d71b4c5196a297c90b9f216 Mon Sep 17 00:00:00 2001 From: Omar Rizwan Date: Thu, 15 Jun 2023 04:29:16 -0400 Subject: Shrink folkImages size to fit on Pi 4 + loadlib rt --- pi/cUtils.tcl | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/pi/cUtils.tcl b/pi/cUtils.tcl index 9fd4439d..ca1e6410 100644 --- a/pi/cUtils.tcl +++ b/pi/cUtils.tcl @@ -39,7 +39,7 @@ proc ::defineFolkImages {cc} { $cc include $cc code { uint8_t* folkImagesBase = (uint8_t*) 0x280000000; - size_t folkImagesSize = 1000000000; + size_t folkImagesSize = 100000000; // 100MB } $cc proc folkImagesMount {} void { int fd = shm_open("/folk-images", O_RDWR | O_CREAT, S_IROTH | S_IWOTH | S_IRUSR | S_IWUSR); @@ -50,4 +50,5 @@ proc ::defineFolkImages {cc} { fprintf(stderr, "shmMount: failed"); exit(1); } } + c loadlib [lindex [exec /usr/sbin/ldconfig -p | grep librt.so] end] } -- cgit v1.2.3 From cbb001c5cbbe50d4afa2212fc4c24913c871e335 Mon Sep 17 00:00:00 2001 From: Omar Rizwan Date: Thu, 15 Jun 2023 04:51:44 -0400 Subject: Remove extra AT impl in Camera.tcl --- pi/Camera.tcl | 66 ----------------------------------------------------------- 1 file changed, 66 deletions(-) diff --git a/pi/Camera.tcl b/pi/Camera.tcl index af546ecb..50623da9 100644 --- a/pi/Camera.tcl +++ b/pi/Camera.tcl @@ -325,69 +325,3 @@ if {([info exists ::argv0] && $::argv0 eq [info script]) || \ freeImage $rgb } } - -namespace eval AprilTags { - rename [c create] apc - apc cflags -I$::env(HOME)/apriltag - apc include - apc include - apc include - apc include - apc code { - apriltag_detector_t *td; - apriltag_family_t *tf; - } - defineImageType apc - - apc proc detectInit {} void { - td = apriltag_detector_create(); - tf = tagStandard52h13_create(); - apriltag_detector_add_family_bits(td, tf, 1); - td->nthreads = 2; - } - - apc proc detect {image_t gray} Tcl_Obj* { - assert(gray.components == 1); - image_u8_t im = (image_u8_t) { .width = gray.width, .height = gray.height, .stride = gray.width, .buf = gray.data }; - - zarray_t *detections = apriltag_detector_detect(td, &im); - int detectionCount = zarray_size(detections); - - Tcl_Obj* detectionObjs[detectionCount]; - for (int i = 0; i < detectionCount; i++) { - apriltag_detection_t *det; - zarray_get(detections, i, &det); - - int size = sqrt( - (det->p[0][0] - det->p[1][0]) * (det->p[0][0] - det->p[1][0]) + - (det->p[0][1] - det->p[1][1]) * (det->p[0][1] - det->p[1][1]) - ); - - detectionObjs[i] = Tcl_ObjPrintf("id %d center {%f %f} corners {{%f %f} {%f %f} {%f %f} {%f %f}} size %d", - det->id, - det->c[0], det->c[1], - det->p[0][0], det->p[0][1], - det->p[1][0], det->p[1][1], - det->p[2][0], det->p[2][1], - det->p[3][0], det->p[3][1], - size); - } - - - zarray_destroy(detections); - Tcl_Obj* result = Tcl_NewListObj(detectionCount, detectionObjs); - return result; - } - - apc proc detectCleanup {} void { - tagStandard52h13_destroy(tf); - apriltag_detector_destroy(td); - } - - c loadlib $::env(HOME)/apriltag/libapriltag.so - apc compile - - proc init {} { - detectInit - } -} -- cgit v1.2.3 From 2d28e53decf2d774b95a92e3357598503d849cc6 Mon Sep 17 00:00:00 2001 From: Omar Rizwan Date: Thu, 15 Jun 2023 17:45:46 -0400 Subject: Simplify test/process --- test/process.tcl | 10 ++-------- 1 file changed, 2 insertions(+), 8 deletions(-) diff --git a/test/process.tcl b/test/process.tcl index 4056a71d..1895f2d7 100644 --- a/test/process.tcl +++ b/test/process.tcl @@ -8,8 +8,7 @@ Step Assert when we are running {{} { On process { - Assert claims things are good - Step + Claim things are good } When things are good { @@ -20,13 +19,11 @@ Step vwait ::good Assert when we are running {{} { - puts "Core: $::nodename" On process { set n 0 while true { incr n Commit { Claim the counter is $n } - Step if {$n > 10} { break } } } @@ -58,10 +55,7 @@ Assert when we are running {{} { On process { Wish $::nodename receives statements like [list /x/ claims the main process exists] When the main process exists { - Commit { - Claim the subprocess heard that the main process exists - } - Step + Commit { Claim the subprocess heard that the main process exists } } } Claim the main process exists -- cgit v1.2.3 From 54c0ff24020b7e213db477b334a482fe4a041582 Mon Sep 17 00:00:00 2001 From: Omar Rizwan Date: Fri, 16 Jun 2023 14:51:10 -0400 Subject: Add python3 test --- lib/language.tcl | 51 +++++++++++++++++++++++++++++++++++++++++++++++++++ main.tcl | 12 +----------- test/process.tcl | 17 +++++++++++++++++ 3 files changed, 69 insertions(+), 11 deletions(-) create mode 100644 lib/language.tcl diff --git a/lib/language.tcl b/lib/language.tcl new file mode 100644 index 00000000..68573492 --- /dev/null +++ b/lib/language.tcl @@ -0,0 +1,51 @@ +# 'Language' utilities that extend and customize base Tcl. + +proc fn {name argNames body} { + uplevel [list set ^$name [list $argNames $body]] +} +rename unknown _original_unknown +proc unknown {name args} { + if {[uplevel [list info exists ^$name]]} { + apply [uplevel [list set ^$name]] {*}$args + } else { + uplevel [list _original_unknown $name {*}$args] + } +} + +# Trim indentation in multiline quoted text. +proc undent {msg {whitespaceChars " "}} { + set msgLines [split $msg "\n"] + set maxLength [string length $msg] + + set regExp [subst -nocommands {([$whitespaceChars]*)[^$whitespaceChars]}] + + set indent [ + tcl::mathfunc::min {*}[ + lmap x $msgLines { + if {[regexp $regExp $x match whitespace]} { + string length $whitespace + } else { + lindex $maxLength + } + } + ] + ] + + join [ltrim [lmap x $msgLines {string range $x $indent end}]] "\n" +} +# Remove empty items at the beginning and the end of a list. +proc ltrim {list} { + set first [lsearch -not -exact $list {}] + set last [lsearch -not -exact [lreverse $list] {}] + return [ + if {$first == -1} { + list + } else { + lrange $list $first end-$last + } + ] +} + +proc python3 {args} { + exec python3 << [undent [join $args " "]] +} diff --git a/main.tcl b/main.tcl index 1d05f94d..72a326de 100644 --- a/main.tcl +++ b/main.tcl @@ -41,17 +41,7 @@ namespace eval Evaluator { } set ::logsize -1 ;# Hack to keep metrics working -proc fn {name argNames body} { - uplevel [list set ^$name [list $argNames $body]] -} -rename unknown _original_unknown -proc unknown {name args} { - if {[uplevel [list info exists ^$name]]} { - apply [uplevel [list set ^$name]] {*}$args - } else { - uplevel [list _original_unknown $name {*}$args] - } -} +source "lib/language.tcl" # invoke at top level, add/remove independent 'axioms' for the system proc Assert {args} { diff --git a/test/process.tcl b/test/process.tcl index 1895f2d7..94457d76 100644 --- a/test/process.tcl +++ b/test/process.tcl @@ -65,3 +65,20 @@ Assert when we are running {{} { }} Step vwait ::heard + +Retract when we are running /anything/ +Step + +Assert when we are running {{} { + On process { + eval [python3 { + print("Claim Python is done") + }] + } + When Python is done { + set ::pythondone true + } +}} +Step + +vwait ::pythondone -- cgit v1.2.3 From 34eedcb52f02f4dddccace2f0d411bc8bc396150 Mon Sep 17 00:00:00 2001 From: Omar Rizwan Date: Sat, 17 Jun 2023 12:41:36 -0400 Subject: fork play --- play/fork-play.tcl | 23 ++++++++++++++++++++ play/zygote-play.tcl | 60 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 83 insertions(+) create mode 100644 play/fork-play.tcl create mode 100644 play/zygote-play.tcl diff --git a/play/fork-play.tcl b/play/fork-play.tcl new file mode 100644 index 00000000..920a8987 --- /dev/null +++ b/play/fork-play.tcl @@ -0,0 +1,23 @@ +source "lib/c.tcl" +set cc [c create] +$cc include +$cc proc ::fork {} int { + return fork(); +} +$cc compile + +puts "In parent ([pid]). Forking" +set pid [fork] +if {$pid == 0} { + puts "In child ([pid]). Forking" + set pid2 [fork] + if {$pid2 == 0} { + puts "In grandchild ([pid]). Done" + exit 0 + } + puts "In child. Done" + exit 0 +} + +puts "In parent. Done" +while true {} diff --git a/play/zygote-play.tcl b/play/zygote-play.tcl new file mode 100644 index 00000000..358e59cd --- /dev/null +++ b/play/zygote-play.tcl @@ -0,0 +1,60 @@ +source "lib/c.tcl" +set cc [c create] +$cc include +$cc proc ::fork {} int { + return fork(); +} +$cc compile + +namespace eval Zygote { + proc init {} { + variable writer + lassign [chan pipe] reader writer + set pid [fork] + if {$pid == 0} { + # We're in the child (the zygote). We will block waiting + # for commands from the parent (the original/main thread). + close $writer + + fconfigure $reader -buffering line + # Zygote's main loop: + set script "" + while {[gets $reader line] != -1} { + append script $line\n + if {[info complete $script]} { + # FIXME: This fork breaks it. + set pid [fork] + if {$pid == 0} { + eval $script + exit 0 + } + set script "" + } + } + exit 0 + + } else { + # We're still in the parent. The child (the zygote) is $pid. + close $reader + # We will send the zygote a message every time we want it to + # fork. + fconfigure $writer -buffering line + } + } + proc spawn {code} { + variable writer + puts $writer $code + } +} + +Zygote::init + +Zygote::spawn { + puts "hello from [pid]" +} +Zygote::spawn { + puts "wow from [pid]" +} + +after 3000 { puts done; set ::done true } +vwait ::done -- cgit v1.2.3 From 02b7a883e3eb5e17426aed71f63c57425cb7f143 Mon Sep 17 00:00:00 2001 From: Omar Rizwan Date: Sun, 18 Jun 2023 16:28:30 -0400 Subject: Introduce fork-zygote process system. Also refactors/separates ::nodename to be ::thisNode (this computer) and ::thisProcess (this OS process). All tests should pass. Zygote-based processes are much faster to start up since they don't need to recompile C code or reload Folk. They still need to connect to Folk via WebSocket for now, and the automatic management we'd want (bidirectional, based on both match lifetime and process lifetime) isn't working yet. Some of the node vs. process distinction in naming still needs to be cleaned up, too, I think. --- laptop.tcl | 6 +- lib/environment.tcl | 24 ------- lib/language.tcl | 2 + lib/peer.tcl | 15 +++-- lib/process.tcl | 124 +++++++++++++++++++++++-------------- main.tcl | 57 +++++++++-------- test/basic.tcl | 2 +- test/perf.tcl | 12 ++-- test/process.tcl | 9 +-- test/shm.tcl | 4 +- user-programs/haippi7/laser-pi.tcl | 2 +- web.tcl | 6 +- 12 files changed, 137 insertions(+), 126 deletions(-) diff --git a/laptop.tcl b/laptop.tcl index 6154159a..3582f8d7 100644 --- a/laptop.tcl +++ b/laptop.tcl @@ -11,7 +11,7 @@ namespace eval Display { canvas .display -background black -width $Display::WIDTH -height $Display::HEIGHT pack .display - wm title . $::nodename + wm title . $::thisProcess wm geometry . [set Display::WIDTH]x[expr {$Display::HEIGHT + 40}]-0+0 ;# align to top-right of screen proc init {} {} @@ -75,8 +75,8 @@ if {[info exists ::shareNode]} { source "lib/peer.tcl" peer $::shareNode - Assert "laptop.tcl" wishes $::nodename shares statements like \ - [list $::nodename is providing root virtual programs /rootVirtualPrograms/] + Assert "laptop.tcl" wishes $::thisProcess shares statements like \ + [list $::thisProcess is providing root virtual programs /rootVirtualPrograms/] } } diff --git a/lib/environment.tcl b/lib/environment.tcl index ae5a369b..28dd33fb 100644 --- a/lib/environment.tcl +++ b/lib/environment.tcl @@ -1,5 +1,3 @@ -namespace eval ::SerializableEnvironment {} - proc serializeEnvironment {} { set argnames [list] set argvalues [list] @@ -10,31 +8,9 @@ proc serializeEnvironment {} { lappend argvalues [uplevel [list set $name]] } } - # foreach importName [namespace eval ::SerializableEnvironment {namespace import}] { - # dict set env %$importName [namespace origin ::SerializableEnvironment::$importName] - # } - # foreach procName [info procs ::SerializableEnvironment::*] { - # if {![dict exists $env %[namespace tail $procName]]} { - # dict set env ^[namespace tail $procName] \ - # [list [info args $procName] [info body $procName]] - # } - # } list $argnames $argvalues } -# proc deserializeEnvironment {env} { -# dict for {name value} $env { -# if {[string index $name 0] eq "^"} { -# proc ::SerializableEnvironment::[string range $name 1 end] {*}$value -# } elseif {[string index $name 0] eq "%"} { -# namespace eval ::SerializableEnvironment \ -# [list namespace import -force $value] -# } else { -# set ::SerializableEnvironment::$name $value -# } -# } -# } - set ::Evaluator::totalTimesMap [dict create] set ::Evaluator::runsMap [dict create] diff --git a/lib/language.tcl b/lib/language.tcl index 68573492..0433c298 100644 --- a/lib/language.tcl +++ b/lib/language.tcl @@ -4,6 +4,8 @@ proc fn {name argNames body} { uplevel [list set ^$name [list $argNames $body]] } rename unknown _original_unknown +# Trap resolution of commands so that they can call the lambda in +# lexical scope created by `fn`. proc unknown {name args} { if {[uplevel [list info exists ^$name]]} { apply [uplevel [list set ^$name]] {*}$args diff --git a/lib/peer.tcl b/lib/peer.tcl index 3f10189d..a142b077 100644 --- a/lib/peer.tcl +++ b/lib/peer.tcl @@ -27,7 +27,7 @@ proc ::peer {node} { proc log {s} { variable node - puts "$::nodename -> $node: $s" + puts "$::thisProcess -> $node: $s" } proc setupSock {} { variable node @@ -62,15 +62,20 @@ proc ::peer {node} { variable node $n; setupSock vwait ::Peers::${n}::connected + # Establish a peering on their end, in the reverse + # direction, so they can send stuff back to us. run [format { - namespace eval ::Peers::%s [format { + namespace eval {::Peers::%s} { variable connected true variable prevShareStatements [clauseset create] proc run {msg} { - ::websocket::send %%s text $msg + variable chan + ::websocket::send $chan text $msg } - } $chan] - } $::nodename] + + variable chan + } $chan + } $::thisProcess] } init } $node diff --git a/lib/process.tcl b/lib/process.tcl index 9ecfb4d2..fbed2e93 100644 --- a/lib/process.tcl +++ b/lib/process.tcl @@ -1,20 +1,59 @@ -set ::processPrelude { - if {[info exists ::entry]} { - return; # don't run if we're in the main process - } +namespace eval ::Zygote { + set cc [c create] + $cc include + $cc proc ::Zygote::fork {} int { return fork(); } + # FIXME: waitpid + # FIXME: some kind of shared-memory log queue + $cc compile - source "main.tcl" - proc every {ms body} { - try $body - after $ms [list after idle [namespace code [info level 0]]] - } + # The zygote is a process that's forked off during Folk + # startup. It can fork itself to create subprocesses on demand. + + # Fork Folk to create the zygote process (= set the current state + # of Folk as the startup state for all subprocesses that will be + # spawned later) + proc init {} { + variable reader + variable writer + lassign [chan pipe] reader writer + set pid [fork] + if {$pid == 0} { + # We're in the child (the zygote). We will block waiting + # for commands from the parent (the original/main thread). + close $writer + fconfigure $reader -buffering line + zygote - Assert $::nodename wishes $::nodename shares all claims - Assert $::nodename wishes $::nodename shares statements like \ - [list /someone/ wishes $::nodename receives statements like /pattern/] + } else { + # We're still in the parent. The child (the zygote) is $pid. + close $reader + # We will send the zygote a message every time we want it to + # fork. + fconfigure $writer -buffering line + } + } + # Zygote's main loop. + proc zygote {} { + variable reader + set script "" + while {[gets $reader line] != -1} { + append script $line\n + if {[info complete $script]} { + set pid [fork] + if {$pid == 0} { + eval $script + exit 0 + } + set script "" + } + } + exit 0 + } - source "lib/peer.tcl" - ::peer "localhost" + proc spawn {code} { + variable writer + puts $writer $code + } } proc On-process {name body} { @@ -23,42 +62,33 @@ proc On-process {name body} { set ::Processes::${name}::body $body set ::Processes::${name}::this [uplevel {expr {[info exists this] ? $this : ""}}] namespace eval ::Processes::$name { - variable tclfd [file tempfile tclfile tclfile.tcl] - set body [format { - Assert claims has program code {%s} - Step - vwait forever - } $body] - puts $tclfd [join [list $::processPrelude $body] "\n"]; close $tclfd + set processCode [list apply {{__name __body} { + set ::thisProcess $__name - # TODO: send it the serialized environment - variable stdout_reader; variable stdout_writer - lassign [chan pipe] stdout_reader stdout_writer + Assert wishes $::thisProcess shares all claims + Assert wishes $::thisProcess shares statements like \ + [list /someone/ wishes $ receives statements like /pattern/] - set pid [exec tclsh8.6 $tclfile >@ $stdout_writer 2>@ $stdout_writer &] + ::peer "localhost" - variable log [list] - proc handleReadable {} { - variable name - variable log - variable stdout_reader - if {[gets $stdout_reader line] >= 0} { - lappend log $line - puts "$name: $line **" - Retract process $name has standard output log /l/ - Assert process $name has standard output log $log - Step - } elseif {[eof $stdout_reader]} { - close $stdout_reader - } - } - # fconfigure $stdio -blocking 0 -buffering line - fconfigure $stdout_reader -blocking 0 -buffering line - fileevent $stdout_reader readable [namespace code handleReadable] + Assert claims $::thisProcess has pid [pid] + Assert claims $::thisProcess has program [list {_} $__body] + Step + vwait forever + }} $name $body] - if {$this ne ""} { - Assert $this is running process $name - } + Zygote::spawn [list apply {{processCode} { + # A supervisor that wraps the subprocess. + set pid [Zygote::fork] + if {$pid == 0} { + eval $processCode + } else { + # TODO: Supervise the subprocess. + # waitpid $pid + # how to report outcomes to Folk? + # does it have an inbox? do we assert into Folk and let it retract? + } + }} $processCode] proc handleUnmatch {} { variable pid @@ -72,10 +102,8 @@ proc On-process {name body} { } on error err { break } - puts "waiting for unmatch kill to work" } Retract /someone/ is running process $name - Retract process $name has standard output log /something/ namespace delete ::Processes::$name } uplevel 2 [list On unmatch ::Processes::${name}::handleUnmatch] diff --git a/main.tcl b/main.tcl index 72a326de..1310365a 100644 --- a/main.tcl +++ b/main.tcl @@ -31,10 +31,10 @@ namespace eval Evaluator { } if {$this ne ""} { Say $this has error $err with info $::errorInfo - puts stderr "$::nodename: Error in $this, match $::matchId: $err\n$::errorInfo" + puts stderr "$::thisProcess: Error in $this, match $::matchId: $err\n$::errorInfo" } else { Say $::matchId has error $err with info $::errorInfo - puts stderr "$::nodename: Error in match $::matchId: $err\n$::errorInfo" + puts stderr "$::thisProcess: Error in match $::matchId: $err\n$::errorInfo" } } } @@ -123,16 +123,16 @@ proc On {event args} { if {[llength $args] == 2} { lassign $args name body } elseif {[llength $args] == 1} { - - if {![info exists ::SerializableEnvironment::nextSubprocessId]} { - set ::SerializableEnvironment::nextSubprocessId 0 - } - set subprocessId [incr ::SerializableEnvironment::nextSubprocessId] - - set name "${::matchId}-${subprocessId}-process" + # Generate a unique name. + set this [uplevel {expr {[info exists this] ? $this : ""}}] + set subprocessId [uplevel {incr __subprocessId}] + set name "${this}-${::matchId}-${subprocessId}" set body [lindex $args 0] } - uplevel [list On-process $name $body] + # Serialize the lexical environment at the callsite so we can + # send that to the subprocess. + lassign [uplevel Evaluator::serializeEnvironment] argNames argValues + uplevel [list On-process $name [list apply [list $argNames $body] {*}$argValues]] } elseif {$event eq "unmatch"} { set body [lindex $args 0] @@ -155,9 +155,8 @@ proc After {n unit body} { } set ::committed [dict create] proc Commit {args} { - upvar this this set body [lindex $args end] - set key [list Commit [expr {[info exists this] ? $this : ""}] {*}[lreplace $args end end]] + set key [list Commit [uplevel {expr {[info exists this] ? $this : ""}}] {*}[lreplace $args end end]] lassign [uplevel Evaluator::serializeEnvironment] argNames argValues set lambda [list {this} [list apply [list $argNames $body] {*}$argValues]] Assert $key has program $lambda @@ -167,15 +166,13 @@ proc Commit {args} { dict set ::committed $key $lambda } -set ::nodename "[info hostname]-[pid]" - set ::stepCount 0 set ::stepTime "none" source "lib/peer.tcl" proc Step {} { incr ::stepCount - Assert $::nodename has step count $::stepCount - Retract $::nodename has step count [expr {$::stepCount - 1}] + Assert $::thisProcess has step count $::stepCount + Retract $::thisProcess has step count [expr {$::stepCount - 1}] set ::stepTime [time {Evaluator::Evaluate}] if {[namespace exists Display]} { @@ -188,11 +185,11 @@ proc Step {} { if {!$connected} { return } set shareStatements [clauseset create] - if {[llength [Statements::findMatches [list /someone/ wishes $::nodename shares all statements]]] > 0} { + if {[llength [Statements::findMatches [list /someone/ wishes $::thisProcess shares all statements]]] > 0} { dict for {_ stmt} [Statements::all] { clauseset add shareStatements [statement clause $stmt] } - } elseif {[llength [Statements::findMatches [list /someone/ wishes $::nodename shares all claims]]] > 0} { + } elseif {[llength [Statements::findMatches [list /someone/ wishes $::thisProcess shares all claims]]] > 0} { dict for {_ stmt} [Statements::all] { if {[lindex [statement clause $stmt] 1] eq "claims"} { clauseset add shareStatements [statement clause $stmt] @@ -200,7 +197,7 @@ proc Step {} { } } - set matches [Statements::findMatches [list /someone/ wishes $::nodename shares statements like /pattern/]] + set matches [Statements::findMatches [list /someone/ wishes $::thisProcess shares statements like /pattern/]] lappend matches {*}[Statements::findMatches [list /someone/ wishes $peer receives statements like /pattern/]] foreach m $matches { set pattern [dict get $m pattern] @@ -239,13 +236,16 @@ Assert when /__this/ has program code /__programCode/ {{__this __programCode} { Claim $__this has program [list {this} $__programCode] }} -Assert when /peer/ shares statements /statements/ with sequence number /gen/ {{peer statements gen} { - foreach stmt $statements { Say {*}$stmt } -}} +set ::thisNode "[info hostname]" +set ::nodename $::thisNode ;# for backward compat if {[info exists ::entry]} { - # This all only runs if we're in a primary Folk process; we don't - # want it to run in subprocesses (which also run main.tcl). + source "lib/process.tcl" + Zygote::init + + # Everything below here only runs if we're in the primary Folk + # process. + set ::thisProcess $::thisNode proc ::loadVirtualPrograms {} { set ::rootVirtualPrograms [dict create] @@ -259,7 +259,7 @@ if {[info exists ::entry]} { {*}[glob -nocomplain "user-programs/[info hostname]/*.folk"]] { loadProgram $programFilename } - Assert $::nodename is providing root virtual programs $::rootVirtualPrograms + Assert $::thisNode is providing root virtual programs $::rootVirtualPrograms # So we can retract them all at once if some other node connects and # wants to impose its root virtual programs: @@ -273,7 +273,7 @@ if {[info exists ::entry]} { # Are there foreign root virtual programs that should take priority over ours? foreach root $roots { - if {[dict get $root node] ne $::nodename} { + if {[dict get $root node] ne $::thisNode} { set chosenRoot $root break } @@ -319,12 +319,11 @@ if {[info exists ::entry]} { } dict set ::rootVirtualPrograms $programName $programCode - Assert $::nodename is providing root virtual programs $::rootVirtualPrograms - Retract $::nodename is providing root virtual programs $oldRootVirtualPrograms + Assert $::thisNode is providing root virtual programs $::rootVirtualPrograms + Retract $::thisNode is providing root virtual programs $oldRootVirtualPrograms Step } - source "lib/process.tcl" source "./web.tcl" source $::entry } diff --git a/test/basic.tcl b/test/basic.tcl index af2bb16f..78ea97da 100644 --- a/test/basic.tcl +++ b/test/basic.tcl @@ -11,7 +11,7 @@ proc count condition { Assert programOakland has program {{this} { Claim Omar lives in "Oakland" }} -Assert when $::nodename has step count /c/ {{c} { +Assert when $::thisProcess has step count /c/ {{c} { When Omar lives in /place/ { Claim $place is a place where Omar lives } diff --git a/test/perf.tcl b/test/perf.tcl index 97ee79cc..186f997c 100644 --- a/test/perf.tcl +++ b/test/perf.tcl @@ -9,22 +9,22 @@ Assert when /name/ is a /animal/ {{name animal} { Assert when /node/ has step count /c/ {{node c} {}} Assert Bob is a cat -puts "$::nodename: No additional statements:" +puts "$::thisProcess: No additional statements:" puts " [run]" for {set i 0} {$i < 100} {incr i} { Assert $i } -puts "$::nodename: Asserted 100 statements:" +puts "$::thisProcess: Asserted 100 statements:" puts " [run]" Assert Omar is a human -puts "$::nodename: Asserted 100 statements + Omar is a human:" +puts "$::thisProcess: Asserted 100 statements + Omar is a human:" puts " [run]" -puts "$::nodename: Same:" +puts "$::thisProcess: Same:" puts " [run]" -puts "$::nodename: Same:" +puts "$::thisProcess: Same:" puts " [run]" -puts "$::nodename: Same:" +puts "$::thisProcess: Same:" puts " [run]" diff --git a/test/process.tcl b/test/process.tcl index 94457d76..c8d25ba3 100644 --- a/test/process.tcl +++ b/test/process.tcl @@ -53,7 +53,7 @@ vwait ::wereinaprocess Assert when we are running {{} { On process { - Wish $::nodename receives statements like [list /x/ claims the main process exists] + Wish $::thisProcess receives statements like [list /x/ claims the main process exists] When the main process exists { Commit { Claim the subprocess heard that the main process exists } } @@ -70,10 +70,11 @@ Retract when we are running /anything/ Step Assert when we are running {{} { + set x done On process { - eval [python3 { - print("Claim Python is done") - }] + eval [python3 [subst { + print("Claim Python is $x") + }]] } When Python is done { set ::pythondone true diff --git a/test/shm.tcl b/test/shm.tcl index 78e93902..f57e8e83 100644 --- a/test/shm.tcl +++ b/test/shm.tcl @@ -7,7 +7,7 @@ proc assert condition { Assert we are running -Assert when we are running { +Assert when we are running {{} { On process { set cc [c create] $cc include @@ -59,7 +59,7 @@ Assert when we are running { $cc compile blup } -} +}} Step after 1000 {set done true} diff --git a/user-programs/haippi7/laser-pi.tcl b/user-programs/haippi7/laser-pi.tcl index 601f2809..19b9702a 100644 --- a/user-programs/haippi7/laser-pi.tcl +++ b/user-programs/haippi7/laser-pi.tcl @@ -97,7 +97,7 @@ namespace eval Camera { } $WIDTH $HEIGHT [thread::id]]] puts "Camera thread id: $cameraThread" - Assert when $::nodename has step count /c/ { + Assert when $::thisProcess has step count /c/ { foreach stmt $Camera::statements { Say {*}$stmt } diff --git a/web.tcl b/web.tcl index b7791654..1eb35ee7 100644 --- a/web.tcl +++ b/web.tcl @@ -152,12 +152,12 @@ proc handleWS {chan type msg} { } elseif {$type eq "text"} { if {[catch {::websocket::send $chan text [eval $msg]} err] == 1} { if [catch { - puts stderr "$::nodename: Error on receipt: $err\n$::errorInfo" + puts stderr "$::thisProcess: Error on receipt: $err\n$::errorInfo" ::websocket::send $chan text $err - } err2] { puts "$::nodename: $err2" } + } err2] { puts "$::thisProcess: $err2" } } } else { - puts "$::nodename: Unhandled WS event $type on $chan ($msg)" + puts "$::thisProcess: Unhandled WS event $type on $chan ($msg)" } } -- cgit v1.2.3 From db5e849f52f7256d4ab11fef955851f8d7914fdb Mon Sep 17 00:00:00 2001 From: Omar Rizwan Date: Sun, 18 Jun 2023 18:14:17 -0400 Subject: Add runtime arg typechecks to the C FFI --- lib/c.tcl | 35 ++++++++++++++++++++++------------- test/cstructs.tcl | 16 ++++++++++++++++ 2 files changed, 38 insertions(+), 13 deletions(-) diff --git a/lib/c.tcl b/lib/c.tcl index b09c5bb9..ce59855a 100644 --- a/lib/c.tcl +++ b/lib/c.tcl @@ -43,6 +43,9 @@ namespace eval c { #include #include #include + + #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) { return TCL_ERROR; } } variable code [list] variable objtypes [list] @@ -64,30 +67,36 @@ namespace eval c { } variable argtypes { - int { expr {{ int $argname; Tcl_GetIntFromObj(interp, $obj, &$argname); }}} - bool { expr {{ int $argname; Tcl_GetIntFromObj(interp, $obj, &$argname); }}} - int32_t { expr {{ int $argname; Tcl_GetIntFromObj(interp, $obj, &$argname); }}} - char { expr {{ char $argname = Tcl_GetString($obj)[0]; }}} - size_t { expr {{ size_t $argname; Tcl_GetLongFromObj(interp, $obj, (long *)&$argname); }}} - intptr_t { expr {{ intptr_t $argname; Tcl_GetLongFromObj(interp, $obj, (long *)&$argname); }}} - uint16_t { expr {{ uint16_t $argname; Tcl_GetIntFromObj(interp, $obj, (int *)&$argname); }}} - uint32_t { expr {{ uint32_t $argname; sscanf(Tcl_GetString($obj), "%"PRIu32, &$argname); }}} - uint64_t { expr {{ uint64_t $argname; sscanf(Tcl_GetString($obj), "%"PRIu64, &$argname); }}} + int { expr {{ int $argname; __ENSURE_OK(Tcl_GetIntFromObj(interp, $obj, &$argname)); }}} + bool { expr {{ int $argname; __ENSURE_OK(Tcl_GetIntFromObj(interp, $obj, &$argname)); }}} + int32_t { expr {{ int $argname; __ENSURE_OK(Tcl_GetIntFromObj(interp, $obj, &$argname)); }}} + char { expr {{ + char $argname; + { + int _len_$argname; + char* _tmp_$argname = Tcl_GetStringFromObj($obj, &_len_$argname); + __ENSURE(_len_$argname >= 1); + $argname = _tmp_$argname[0]; + } + }}} + size_t { expr {{ size_t $argname; __ENSURE_OK(Tcl_GetLongFromObj(interp, $obj, (long *)&$argname)); }}} + intptr_t { expr {{ intptr_t $argname; __ENSURE_OK(Tcl_GetLongFromObj(interp, $obj, (long *)&$argname)); }}} + uint16_t { expr {{ uint16_t $argname; __ENSURE_OK(Tcl_GetIntFromObj(interp, $obj, (int *)&$argname)); }}} + uint32_t { expr {{ uint32_t $argname; __ENSURE(sscanf(Tcl_GetString($obj), "%"PRIu32, &$argname) == 1); }}} + uint64_t { expr {{ uint64_t $argname; __ENSURE(sscanf(Tcl_GetString($obj), "%"PRIu64, &$argname) == 1); }}} char* { expr {{ char* $argname = Tcl_GetString($obj); }} } Tcl_Obj* { expr {{ Tcl_Obj* $argname = $obj; }}} default { if {[string index $argtype end] == "*"} { expr {{ $argtype $argname; - if (sscanf(Tcl_GetString($obj), "($argtype) 0x%p", &$argname) != 1) { - return TCL_ERROR; - } + __ENSURE(sscanf(Tcl_GetString($obj), "($argtype) 0x%p", &$argname) == 1); }} } elseif {[regexp {([^\[]+)\[(\d*)\]$} $argtype -> basetype arraylen]} { # note: arraylen can be "" expr {{ int ${argname}_objc; Tcl_Obj** ${argname}_objv; - Tcl_ListObjGetElements(interp, $obj, &${argname}_objc, &${argname}_objv); + __ENSURE_OK(Tcl_ListObjGetElements(interp, $obj, &${argname}_objc, &${argname}_objv)); $basetype $argname\[${argname}_objc\]; { for (int i = 0; i < ${argname}_objc; i++) { diff --git a/test/cstructs.tcl b/test/cstructs.tcl index 17f0fb41..c4849fab 100644 --- a/test/cstructs.tcl +++ b/test/cstructs.tcl @@ -25,3 +25,19 @@ $cc compile puts [omar] assert {[dict get [omar] name last] eq "Rizwan"} + +set cc [c create] +$cc proc plusone {int a} int { + return a + 1; +} +$cc proc dostuff {void* v} int { + return 300; +} +$cc compile +assert {[plusone 3] eq 4} + +catch {plusone Wrong} err +assert {[string match {expected integer but got "Wrong"*} $err]} + +catch {dostuff hi} err +assert {[string match {failed to convert argument from Tcl to C*} $err]} -- cgit v1.2.3 From 918a054bb60b8e33e41a3f2c561805abcb79cec3 Mon Sep 17 00:00:00 2001 From: Omar Rizwan Date: Sun, 18 Jun 2023 19:59:15 -0400 Subject: Use m/s: format for stringifying ids. Make subproc share all --- lib/evaluator.tcl | 16 +++++++++++----- lib/process.tcl | 4 +--- main.tcl | 8 +------- 3 files changed, 13 insertions(+), 15 deletions(-) diff --git a/lib/evaluator.tcl b/lib/evaluator.tcl index 8eacc659..8e968f94 100644 --- a/lib/evaluator.tcl +++ b/lib/evaluator.tcl @@ -6,8 +6,14 @@ namespace eval statement { $cc include $cc include - $cc struct statement_handle_t { int32_t idx; int32_t gen; } - $cc struct match_handle_t { int32_t idx; int32_t gen; } + $cc code { + typedef struct statement_handle_t { int32_t idx; int32_t gen; } statement_handle_t; + typedef struct match_handle_t { int32_t idx; int32_t gen; } match_handle_t; + } + $cc rtype statement_handle_t { $robj = Tcl_ObjPrintf("s%d:%d", $rvalue.idx, $rvalue.gen); } + $cc argtype statement_handle_t { statement_handle_t $argname; sscanf(Tcl_GetString($obj), "s%d:%d", &$argname.idx, &$argname.gen); } + $cc rtype match_handle_t { $robj = Tcl_ObjPrintf("m%d:%d", $rvalue.idx, $rvalue.gen); } + $cc argtype match_handle_t { match_handle_t $argname; sscanf(Tcl_GetString($obj), "m%d:%d", &$argname.idx, &$argname.gen); } $cc enum edge_type_t { EMPTY, PARENT, CHILD } @@ -562,7 +568,7 @@ namespace eval Statements { ;# singleton Statement store for (int i = 0; i < resultsCount; i++) { Tcl_Obj* matchObj = environmentToTclDict(results[i]); statement_handle_t id = results[i]->matchedStatementIds[0]; - Tcl_DictObjPut(NULL, matchObj, Tcl_ObjPrintf("__matcheeIds"), Tcl_ObjPrintf("{idx %d gen %d}", id.idx, id.gen)); + Tcl_DictObjPut(NULL, matchObj, Tcl_ObjPrintf("__matcheeIds"), Tcl_ObjPrintf("{s%d:%d}", id.idx, id.gen)); Tcl_ListObjAppendElement(NULL, ret, matchObj); ckfree((char *)results[i]); } @@ -826,7 +832,7 @@ namespace eval Evaluator { Tcl_ListObjAppendElement(interp, env, result->bindings[i].value); } - Tcl_ObjSetVar2(interp, Tcl_ObjPrintf("::matchId"), NULL, Tcl_ObjPrintf("idx %d gen %d", matchId.idx, matchId.gen), 0); + Tcl_ObjSetVar2(interp, Tcl_ObjPrintf("::matchId"), NULL, Tcl_ObjPrintf("m%d:%d", matchId.idx, matchId.gen), 0); tryRunInSerializedEnvironment(interp, lambda, env); } } @@ -1046,7 +1052,7 @@ namespace eval Evaluator { env = Tcl_DuplicateObj(env); Tcl_ListObjAppendElement(NULL, env, matches); - Tcl_ObjSetVar2(interp, Tcl_ObjPrintf("::matchId"), NULL, Tcl_ObjPrintf("idx %d gen %d", matchId.idx, matchId.gen), 0); + Tcl_ObjSetVar2(interp, Tcl_ObjPrintf("::matchId"), NULL, Tcl_ObjPrintf("m%d:%d", matchId.idx, matchId.gen), 0); tryRunInSerializedEnvironment(interp, lambda, env); } diff --git a/lib/process.tcl b/lib/process.tcl index fbed2e93..79dc6788 100644 --- a/lib/process.tcl +++ b/lib/process.tcl @@ -65,9 +65,7 @@ proc On-process {name body} { set processCode [list apply {{__name __body} { set ::thisProcess $__name - Assert wishes $::thisProcess shares all claims - Assert wishes $::thisProcess shares statements like \ - [list /someone/ wishes $ receives statements like /pattern/] + Assert wishes $::thisProcess shares all statements ::peer "localhost" diff --git a/main.tcl b/main.tcl index 1310365a..28743077 100644 --- a/main.tcl +++ b/main.tcl @@ -189,13 +189,7 @@ proc Step {} { dict for {_ stmt} [Statements::all] { clauseset add shareStatements [statement clause $stmt] } - } elseif {[llength [Statements::findMatches [list /someone/ wishes $::thisProcess shares all claims]]] > 0} { - dict for {_ stmt} [Statements::all] { - if {[lindex [statement clause $stmt] 1] eq "claims"} { - clauseset add shareStatements [statement clause $stmt] - } - } - } + } set matches [Statements::findMatches [list /someone/ wishes $::thisProcess shares statements like /pattern/]] lappend matches {*}[Statements::findMatches [list /someone/ wishes $peer receives statements like /pattern/]] -- cgit v1.2.3 From ed28874e58029163cef7f9648c3fb18212df38c5 Mon Sep 17 00:00:00 2001 From: Omar Rizwan Date: Sun, 18 Jun 2023 20:19:34 -0400 Subject: Fix dot and probably sharing --- lib/evaluator.tcl | 26 +++++++++++--------------- 1 file changed, 11 insertions(+), 15 deletions(-) diff --git a/lib/evaluator.tcl b/lib/evaluator.tcl index 8e968f94..98a37054 100644 --- a/lib/evaluator.tcl +++ b/lib/evaluator.tcl @@ -672,7 +672,7 @@ namespace eval Statements { ;# singleton Statement store s->typePtr = &statement_t_ObjType; s->internalRep.otherValuePtr = &statements[i]; - Tcl_ListObjAppendElement(NULL, ret, Tcl_ObjPrintf("idx %d", i)); + Tcl_ListObjAppendElement(NULL, ret, Tcl_ObjPrintf("s%d:%d", i, statements[i].gen)); Tcl_ListObjAppendElement(NULL, ret, s); } return ret; @@ -680,9 +680,7 @@ namespace eval Statements { ;# singleton Statement store proc dot {} { set dot [list] dict for {id stmt} [all] { - set id [dict get $id idx] - - lappend dot "subgraph cluster_$id {" + lappend dot "subgraph {" lappend dot "color=lightgray;" set label [statement clause $stmt] @@ -690,23 +688,21 @@ namespace eval Statements { ;# singleton Statement store expr { [string length $line] > 80 ? "[string range $line 0 80]..." : $line } }] "\n"] set label [string map {"\"" "\\\""} [string map {"\\" "\\\\"} $label]] - lappend dot "s$id \[label=\"s$id: $label\"\];" + lappend dot "<$id> \[label=\"$id: $label\"\];" - dict for {matchId_ _} [statement parentMatchIds $stmt] { - set matchId [dict get $matchId_ idx] - if {$matchId == -1} continue - set parents [lmap edge [matchEdges $matchId_] {expr { - [dict get $edge type] == 1 ? "s[dict get $edge statement idx]" : [continue] + dict for {matchId _} [statement parentMatchIds $stmt] { + set parents [lmap edge [matchEdges $matchId] {expr { + [dict get $edge type] == 1 ? "<[dict get $edge statement]>" : [continue] }}] - lappend dot "m$matchId \[label=\"m$matchId <- $parents\"\];" - lappend dot "m$matchId -> s$id;" + lappend dot "<$matchId> \[label=\"<$matchId> <- $parents\"\];" + lappend dot "<$matchId> -> <$id>;" } lappend dot "}" - dict for {childId _} [statement childMatchIds $stmt] { - set childId [dict get $childId idx] - lappend dot "s$id -> m$childId;" + dict for {childMatchId _} [statement childMatchIds $stmt] { + set childMatchId [string map {: _} $childMatchId] + lappend dot "<$id> -> <$childMatchId>;" } } return "digraph { rankdir=LR; [join $dot "\n"] }" -- cgit v1.2.3 From ccdd5ad22cef126ed1c5837fc8b8c8ded5eeccd3 Mon Sep 17 00:00:00 2001 From: Omar Rizwan Date: Sun, 18 Jun 2023 20:42:11 -0400 Subject: More sharing & dot cleanup/improvement/fixing --- hosts.tcl | 49 ++++++++++++++++++++++++++++++------------------- laptop.tcl | 3 ++- lib/evaluator.tcl | 5 ++--- 3 files changed, 34 insertions(+), 23 deletions(-) diff --git a/hosts.tcl b/hosts.tcl index 18675971..d5b2e795 100644 --- a/hosts.tcl +++ b/hosts.tcl @@ -1,25 +1,36 @@ -set wifi "Fios-LGTS3-5G" -catch { - if {$::tcl_platform(os) eq "Darwin"} { - set wifi [exec sh -c {/Sy*/L*/Priv*/Apple8*/V*/C*/R*/airport -I | sed -n "s/^.*SSID: \(.*\)$/\1/p"}] - } elseif {$::tcl_platform(os) eq "Linux"} { - set wifi [exec iwgetid -r] - } -} - -if {$wifi eq "cynosure"} { set ::shareNode "folk-omar.local" } \ -elseif {$wifi eq "Verizon_TWRHB4"} { set ::shareNode "folk-cwervo.local" } \ -elseif {$wifi eq "WONDERLAND"} { set ::shareNode "folk-haip.local" } \ -elseif {$wifi eq "GETNEAR"} { set ::shareNode "folk-ian.local" } \ -elseif {$wifi eq "Fios-LGTS3-5G" || $wifi eq "Fios-LGTS3"} { set ::shareNode "folk0.local" } \ -elseif {[string match "_onefact.org*" $wifi]} { set ::shareNode "folk-onefact.local" } \ -else { set ::shareNode "folk0.local" } - if {[info exists ::env(FOLK_SHARE_NODE)]} { set ::shareNode $::env(FOLK_SHARE_NODE) +} else { + try { + if {$::tcl_platform(os) eq "Darwin"} { + set wifi [exec sh -c {/Sy*/L*/Priv*/Apple8*/V*/C*/R*/airport -I | sed -n "s/^.*SSID: \(.*\)$/\1/p"}] + } elseif {$::tcl_platform(os) eq "Linux"} { + set wifi [exec iwgetid -r] + } + + if {$wifi eq "cynosure"} { + set ::shareNode "folk-omar.local" + } elseif {$wifi eq "Verizon_TWRHB4"} { + set ::shareNode "folk-cwervo.local" + } elseif {$wifi eq "WONDERLAND"} { + set ::shareNode "folk-haip.local" + } elseif {$wifi eq "GETNEAR"} { + set ::shareNode "folk-ian.local" + } elseif {$wifi eq "Fios-LGTS3-5G" || $wifi eq "Fios-LGTS3"} { + set ::shareNode "folk0.local" + } elseif {[string match "_onefact.org*" $wifi]} { + set ::shareNode "folk-onefact.local" + } else { + # there's no default. + } + } on error e { + set ::shareNode "none" + } } -if {$::shareNode eq "none"} { unset ::shareNode } + +if {[info exists ::shareNode] && $::shareNode eq "none"} { unset ::shareNode } if {[info exists ::argv] && $::argv eq "shareNode"} { - puts $::shareNode + if {[info exists ::shareNode]} { puts $::shareNode } \ + else { puts none } } diff --git a/laptop.tcl b/laptop.tcl index 3582f8d7..9a27de02 100644 --- a/laptop.tcl +++ b/laptop.tcl @@ -61,6 +61,7 @@ Assert when /program/ has error /err/ with info /info/ {{program err info} { source "hosts.tcl" if {[info exists ::shareNode]} { + puts "Will try to share with: $::shareNode" # copy to Pi if {[catch { # TODO: forward entry point @@ -69,7 +70,7 @@ if {[info exists ::shareNode]} { exec -ignorestderr ssh folk@$::shareNode -- sudo systemctl restart folk >@stdout & } err]} { puts "error syncing: $err" - puts "Proceeding without sharing to table." + puts "Proceeding without sharing." } else { source "lib/peer.tcl" diff --git a/lib/evaluator.tcl b/lib/evaluator.tcl index 98a37054..119855ce 100644 --- a/lib/evaluator.tcl +++ b/lib/evaluator.tcl @@ -692,16 +692,15 @@ namespace eval Statements { ;# singleton Statement store dict for {matchId _} [statement parentMatchIds $stmt] { set parents [lmap edge [matchEdges $matchId] {expr { - [dict get $edge type] == 1 ? "<[dict get $edge statement]>" : [continue] + [dict get $edge type] == 1 ? "[dict get $edge statement]" : [continue] }}] - lappend dot "<$matchId> \[label=\"<$matchId> <- $parents\"\];" + lappend dot "<$matchId> \[label=\"$matchId <- $parents\"\];" lappend dot "<$matchId> -> <$id>;" } lappend dot "}" dict for {childMatchId _} [statement childMatchIds $stmt] { - set childMatchId [string map {: _} $childMatchId] lappend dot "<$id> -> <$childMatchId>;" } } -- cgit v1.2.3 From f4958c8d7892c1f7027649f51121f32e6fb776a7 Mon Sep 17 00:00:00 2001 From: Omar Rizwan Date: Sun, 18 Jun 2023 21:07:14 -0400 Subject: Make laptop run w/o Tk --- laptop.tcl | 69 ++++++++++++++++++++++++++++++++++---------------------------- 1 file changed, 38 insertions(+), 31 deletions(-) diff --git a/laptop.tcl b/laptop.tcl index 9a27de02..c3aeba1a 100644 --- a/laptop.tcl +++ b/laptop.tcl @@ -1,5 +1,3 @@ -package require Tk - namespace eval Display { variable WIDTH 800 variable HEIGHT 600 @@ -9,12 +7,37 @@ namespace eval Display { variable green green variable red red - canvas .display -background black -width $Display::WIDTH -height $Display::HEIGHT - pack .display - wm title . $::thisProcess - wm geometry . [set Display::WIDTH]x[expr {$Display::HEIGHT + 40}]-0+0 ;# align to top-right of screen - - proc init {} {} + proc init {} { + package require Tk + + canvas .display -background black -width $Display::WIDTH -height $Display::HEIGHT + pack .display + wm title . $::thisProcess + wm geometry . [set Display::WIDTH]x[expr {$Display::HEIGHT + 40}]-0+0 ;# align to top-right of screen + + set ::chs [list] + bind . {apply {{k} { + lappend ::chs $k + Retract keyboard claims the keyboard character log is /something/ + Assert keyboard claims the keyboard character log is $::chs + Step + }} %K} + + proc ::Display::commit {} { + .display delete all + + set displayList [list] + foreach match [Statements::findMatches {/someone/ wishes display runs /command/}] { + lappend displayList [dict get $match command] + } + + proc lcomp {a b} {expr {[lindex $a 2] == "text"}} + variable displayTime + set displayTime [time { + eval [join [lsort -command lcomp $displayList] "\n"] + }] + } + } proc fillRect {x0 y0 x1 y1 color} { uplevel [list Wish display runs [list .display create rectangle $x0 $y0 $x1 $y1 -fill $color]] @@ -30,31 +53,11 @@ namespace eval Display { } variable displayTime - proc commit {} { - .display delete all - - set displayList [list] - foreach match [Statements::findMatches {/someone/ wishes display runs /command/}] { - lappend displayList [dict get $match command] - } - proc lcomp {a b} {expr {[lindex $a 2] == "text"}} - variable displayTime - set displayTime [time { - eval [join [lsort -command lcomp $displayList] "\n"] - }] - } + # No-op until Display::init is called. + proc commit {} {} } -set ::chs [list] -proc handleKeyPress {k} { - lappend ::chs $k - Retract keyboard claims the keyboard character log is /something/ - Assert keyboard claims the keyboard character log is $::chs - Step -} -bind . {handleKeyPress %K} - Assert when /program/ has error /err/ with info /info/ {{program err info} { puts stderr "Error: $program has error $err with info $info" }} @@ -81,7 +84,11 @@ if {[info exists ::shareNode]} { } } -Display::init +try { + Display::init +} on error e { + puts stderr "Failed to init display: $e" +} loadVirtualPrograms Step -- cgit v1.2.3 From 34c07b5e657ad908086947291711fa4c09967af3 Mon Sep 17 00:00:00 2001 From: Omar Rizwan Date: Sun, 18 Jun 2023 22:59:10 -0400 Subject: Clean up unmatch and sharing so it actually only runs on subproc --- lib/process.tcl | 39 +++++++++++++++++++++------------------ main.tcl | 7 +++++-- 2 files changed, 26 insertions(+), 20 deletions(-) diff --git a/lib/process.tcl b/lib/process.tcl index 79dc6788..7176b9c2 100644 --- a/lib/process.tcl +++ b/lib/process.tcl @@ -65,12 +65,13 @@ proc On-process {name body} { set processCode [list apply {{__name __body} { set ::thisProcess $__name - Assert wishes $::thisProcess shares all statements + Assert wishes $::thisProcess shares all wishes + Assert wishes $::thisProcess shares all claims ::peer "localhost" Assert claims $::thisProcess has pid [pid] - Assert claims $::thisProcess has program [list {_} $__body] + Assert when $::thisProcess has pid /something/ [list {} $__body] Step vwait forever }} $name $body] @@ -88,22 +89,24 @@ proc On-process {name body} { } }} $processCode] - proc handleUnmatch {} { - variable pid - variable name - variable stdout_reader - close $stdout_reader - exec kill -9 $pid - while {1} { - try { - exec kill -0 $pid - } on error err { - break - } - } - Retract /someone/ is running process $name - namespace delete ::Processes::$name + When (non-capturing) $name has pid /pid/ { + On unmatch { exec kill -9 $pid } } - uplevel 2 [list On unmatch ::Processes::${name}::handleUnmatch] + + # proc handleUnmatch {} { + # variable pid + # variable name + # exec kill -9 $pid + # while {1} { + # try { + # exec kill -0 $pid + # } on error err { + # break + # } + # } + # Retract /someone/ is running process $name + # namespace delete ::Processes::$name + # } + # uplevel 2 [list On unmatch ::Processes::${name}::handleUnmatch] } } diff --git a/main.tcl b/main.tcl index 28743077..b9c08562 100644 --- a/main.tcl +++ b/main.tcl @@ -185,8 +185,11 @@ proc Step {} { if {!$connected} { return } set shareStatements [clauseset create] - if {[llength [Statements::findMatches [list /someone/ wishes $::thisProcess shares all statements]]] > 0} { - dict for {_ stmt} [Statements::all] { + set shareAllWishes [expr {[llength [Statements::findMatches [list /someone/ wishes $::thisProcess shares all wishes]]] > 0}] + set shareAllClaims [expr {[llength [Statements::findMatches [list /someone/ wishes $::thisProcess shares all claims]]] > 0}] + dict for {_ stmt} [Statements::all] { + if {($shareAllWishes && [lindex [statement clause $stmt] 1] eq "wishes") || + ($shareAllClaims && [lindex [statement clause $stmt] 1] eq "claims")} { clauseset add shareStatements [statement clause $stmt] } } -- cgit v1.2.3 From d34dd912016343bc020572c700790a8c5c6f0dfa Mon Sep 17 00:00:00 2001 From: Omar Rizwan Date: Mon, 19 Jun 2023 00:06:34 -0400 Subject: Fix process sync test --- test/process.tcl | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/test/process.tcl b/test/process.tcl index c8d25ba3..c69fe26c 100644 --- a/test/process.tcl +++ b/test/process.tcl @@ -43,9 +43,9 @@ Assert when we are running {{} { When I am in a process { Commit { Claim we were in a process } } - When we were in a process { - set ::wereinaprocess true - } + } + When we were in a process { + set ::wereinaprocess true } }} Step -- cgit v1.2.3 From fba548c134fee5562f9ba7558b3ff9a3178f0f1a Mon Sep 17 00:00:00 2001 From: Omar Rizwan Date: Mon, 19 Jun 2023 01:01:07 -0400 Subject: Fix bidirectional peering --- lib/peer.tcl | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/lib/peer.tcl b/lib/peer.tcl index a142b077..513e204a 100644 --- a/lib/peer.tcl +++ b/lib/peer.tcl @@ -46,8 +46,9 @@ proc ::peer {node} { } elseif {$type eq "error"} { log "WebSocket error: $type $msg" after 2000 [namespace code setupSock] - } elseif {$type eq "text" || $type eq "ping" || $type eq "pong"} { - # We don't handle responses yet. + } elseif {$type eq "text"} { + eval $msg + } elseif {$type eq "ping" || $type eq "pong"} { } else { error "Unknown WebSocket event: $type $msg" } -- cgit v1.2.3 From f62f3e2d9d06add473fa9b82e8e2697c7904c998 Mon Sep 17 00:00:00 2001 From: Omar Rizwan Date: Mon, 19 Jun 2023 12:39:42 -0400 Subject: WIP: Tag detect on same thread as camera for now. --- pi/cUtils.tcl | 2 +- virtual-programs/camera.folk | 32 +++++++++++++++----------------- 2 files changed, 16 insertions(+), 18 deletions(-) diff --git a/pi/cUtils.tcl b/pi/cUtils.tcl index ca1e6410..d0046857 100644 --- a/pi/cUtils.tcl +++ b/pi/cUtils.tcl @@ -50,5 +50,5 @@ proc ::defineFolkImages {cc} { fprintf(stderr, "shmMount: failed"); exit(1); } } - c loadlib [lindex [exec /usr/sbin/ldconfig -p | grep librt.so] end] + $cc cflags -lrt } diff --git a/virtual-programs/camera.folk b/virtual-programs/camera.folk index b82c306d..b865392e 100644 --- a/virtual-programs/camera.folk +++ b/virtual-programs/camera.folk @@ -7,33 +7,31 @@ namespace eval ::Camera { On process { source pi/Camera.tcl - # FIXME: do these in outer scope + source pi/AprilTags.tcl Camera::init 1280 720 + AprilTags::init + puts "Camera tid: [getTid]" while true { - set grayFrame [Camera::grayFrame] - Commit { - Claim the camera frame is $grayFrame; - } - Step - } -} - -On process { - Wish $::nodename receives statements like [list /someone/ claims the camera frame is /frame/] - - source pi/AprilTags.tcl - AprilTags::init - - When the camera frame is /frame/ { - set aprilTime [time { set tags [AprilTags::detect $frame] }] + set cameraTime [time { + set grayFrame [Camera::grayFrame] + }] + set aprilTime [time { + set tags [AprilTags::detect $grayFrame] + }] + Commit { + Claim the camera frame is $grayFrame + + Claim the camera time is $cameraTime Claim the AprilTag time is $aprilTime + foreach tag $tags { Claim tag [dict get $tag id] has center [dict get $tag center] size [dict get $tag size] Claim tag [dict get $tag id] has corners [dict get $tag corners] } } + Step } } -- cgit v1.2.3 From 8ad09e5f697d7fdc739ba16a5c329ac69312e6e4 Mon Sep 17 00:00:00 2001 From: Omar Rizwan Date: Mon, 19 Jun 2023 13:40:19 -0400 Subject: Disable shapes log --- virtual-programs/shapes.folk | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/virtual-programs/shapes.folk b/virtual-programs/shapes.folk index b693220e..455125b9 100644 --- a/virtual-programs/shapes.folk +++ b/virtual-programs/shapes.folk @@ -76,7 +76,7 @@ When /someone/ wishes /p/ draws a /color/ /shape/ offset /offsetVector/ & /p/ ha set y [expr {$y + $offsetY}] } - puts "drawing $shape at $x $y" + # puts "drawing $shape at $x $y" set adjustedWidth [expr {$width * 0.25}] set x [expr { $x * 1.3}] -- cgit v1.2.3 From a5b40ecd2ba5e4e04ed35a410d05953d877e0d13 Mon Sep 17 00:00:00 2001 From: Omar Rizwan Date: Mon, 19 Jun 2023 13:40:27 -0400 Subject: Add assert to lib/language.tcl --- lib/language.tcl | 12 ++++++++++++ test/basic.tcl | 6 ------ test/commit.tcl | 7 ------- test/cstructs.tcl | 7 ------- test/joins.tcl | 7 ------- test/negation.tcl | 6 ------ test/shm.tcl | 8 -------- test/trie.tcl | 7 ------- test/with-all.tcl | 11 ----------- 9 files changed, 12 insertions(+), 59 deletions(-) diff --git a/lib/language.tcl b/lib/language.tcl index 0433c298..709e5697 100644 --- a/lib/language.tcl +++ b/lib/language.tcl @@ -51,3 +51,15 @@ proc ltrim {list} { proc python3 {args} { exec python3 << [undent [join $args " "]] } + +proc assert condition { + set s "{$condition}" + if {![uplevel 1 expr $s]} { + set errmsg "assertion failed: $condition" + if {[lindex $condition 1] eq "eq" && [string index [lindex $condition 0] 0] eq "$"} { + set errmsg "$errmsg\n[uplevel 1 [list set [string range [lindex $condition 0] 1 end]]] is not equal to [lindex $condition 2]" + } + return -code error $errmsg + } +} + diff --git a/test/basic.tcl b/test/basic.tcl index 78ea97da..c39916dd 100644 --- a/test/basic.tcl +++ b/test/basic.tcl @@ -1,9 +1,3 @@ -proc assert condition { - set s "{$condition}" - if {![uplevel 1 expr $s]} { - return -code error "assertion failed: $condition" - } -} proc count condition { Statements::count $condition } diff --git a/test/commit.tcl b/test/commit.tcl index 2a8bdaed..1cf780b8 100644 --- a/test/commit.tcl +++ b/test/commit.tcl @@ -1,10 +1,3 @@ -proc assert condition { - set s "{$condition}" - if {![uplevel 1 expr $s]} { - return -code error "assertion failed: $condition" - } -} - Assert programBall has program {{this} { Commit { Claim $this has a ball at x 100 y 100 } diff --git a/test/cstructs.tcl b/test/cstructs.tcl index c4849fab..623cd53f 100644 --- a/test/cstructs.tcl +++ b/test/cstructs.tcl @@ -1,10 +1,3 @@ -proc assert condition { - set s "{$condition}" - if {![uplevel 1 expr $s]} { - return -code error "assertion failed: $condition" - } -} - set cc [c create] $cc struct Name { char* first; diff --git a/test/joins.tcl b/test/joins.tcl index 799abe0c..57d80300 100644 --- a/test/joins.tcl +++ b/test/joins.tcl @@ -1,10 +1,3 @@ -proc assert condition { - set s "{$condition}" - if {![uplevel 1 expr $s]} { - return -code error "assertion failed: $condition" - } -} - Assert Omar is a person Assert Omar lives in "New York" Assert Elmo is a person diff --git a/test/negation.tcl b/test/negation.tcl index 0067783a..501d7295 100644 --- a/test/negation.tcl +++ b/test/negation.tcl @@ -1,9 +1,3 @@ -proc assert condition { - set s "{$condition}" - if {![uplevel 1 expr $s]} { - return -code error "assertion failed: $condition" - } -} Assert programNegation has program code { When /nobody/ is booping { set ::booping nope diff --git a/test/shm.tcl b/test/shm.tcl index f57e8e83..c3d63fc7 100644 --- a/test/shm.tcl +++ b/test/shm.tcl @@ -1,11 +1,3 @@ -proc assert condition { - set s "{$condition}" - if {![uplevel 1 expr $s]} { - return -code error "assertion failed: $condition" - } -} - - Assert we are running Assert when we are running {{} { On process { diff --git a/test/trie.tcl b/test/trie.tcl index 9e353d58..92ad9efa 100644 --- a/test/trie.tcl +++ b/test/trie.tcl @@ -2,13 +2,6 @@ set t [trie create] trie add t {Omar is a person} 1 trie add t {Generic is a /y/} 2 -proc assert condition { - set s "{$condition}" - if {![uplevel 1 expr $s]} { - return -code error "assertion failed: $condition" - } -} - assert {[trie lookup $t {Omar is a person}] eq {1}} assert {[trie lookup $t {/p/ is a person}] eq {1 2}} assert {[trie lookup $t {Omar is a /x/}] eq {1}} diff --git a/test/with-all.tcl b/test/with-all.tcl index d628a9db..27e594bd 100644 --- a/test/with-all.tcl +++ b/test/with-all.tcl @@ -1,14 +1,3 @@ -proc assert condition { - set s "{$condition}" - if {![uplevel 1 expr $s]} { - set errmsg "assertion failed: $condition" - if {[lindex $condition 1] eq "eq" && [string index [lindex $condition 0] 0] eq "$"} { - set errmsg "$errmsg\n[uplevel 1 [list set [string range [lindex $condition 0] 1 end]]] is not equal to [lindex $condition 2]" - } - return -code error $errmsg - } -} - Assert programOakland has program code { Claim Omar lives in "Oakland" } -- cgit v1.2.3 From 4b2679ca8a61ce2edf9b74876df97aa923657872 Mon Sep 17 00:00:00 2001 From: Omar Rizwan Date: Tue, 27 Jun 2023 15:39:47 -0400 Subject: Add prefix math ops to language --- lib/language.tcl | 2 ++ virtual-programs/regions.folk | 3 --- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/lib/language.tcl b/lib/language.tcl index 709e5697..b706753a 100644 --- a/lib/language.tcl +++ b/lib/language.tcl @@ -63,3 +63,5 @@ proc assert condition { } } +namespace import ::tcl::mathop::* +namespace import ::tcl::mathfunc::* diff --git a/virtual-programs/regions.folk b/virtual-programs/regions.folk index 1702bbfa..8f320b42 100644 --- a/virtual-programs/regions.folk +++ b/virtual-programs/regions.folk @@ -1,5 +1,4 @@ namespace eval ::vec2 { - namespace import ::tcl::mathop::+ ::tcl::mathop::- ::tcl::mathop::* proc add {a b} { list [+ [lindex $a 0] [lindex $b 0]] [+ [lindex $a 1] [lindex $b 1]] } @@ -21,8 +20,6 @@ namespace eval ::vec2 { proc dot {a b} { expr {[lindex $a 0]*[lindex $b 0] + [lindex $a 1]*[lindex $b 1]} } - namespace import ::tcl::mathfunc::max ::tcl::mathfunc::min - namespace import ::tcl::mathop::/ proc distanceToLineSegment {a v w} { set l2 [vec2 distance $v $w] if {$l2 == 0.0} { -- cgit v1.2.3 From 82d01c81089de61083b0bb52c5525384a38dc964 Mon Sep 17 00:00:00 2001 From: Omar Rizwan Date: Tue, 27 Jun 2023 15:40:13 -0400 Subject: Fix error rendering in web editor --- virtual-programs/new-program-web-editor.folk | 9 +- virtual-programs/web-editor.folk | 188 ++++++++++++++------------- 2 files changed, 102 insertions(+), 95 deletions(-) diff --git a/virtual-programs/new-program-web-editor.folk b/virtual-programs/new-program-web-editor.folk index 692b00e0..5797365b 100644 --- a/virtual-programs/new-program-web-editor.folk +++ b/virtual-programs/new-program-web-editor.folk @@ -113,9 +113,9 @@ Wish the web server handles route "/new" with handler { ws.close(); } ws.onmessage = (msg) => { - if (msg.data.startsWith("ERROR:")) { + if (msg.data.startsWith("Error:")) { const errorEl = document.getElementById("error"); - if (msg.data == "ERROR: {}") { + if (msg.data === "Error:") { errorEl.style.backgroundColor = ""; errorEl.innerText = ""; } else { @@ -153,7 +153,10 @@ Wish the web server handles route "/new" with handler { if {$::isLaptop} { Step } `); setTimeout(() => { - send(`list ERROR: [Statements::findMatches [list {${program}} has error /err/ with info /errorInfo/]]`); + send(` +set errors [Statements::findMatches [list {${program}} has error /err/ with info /errorInfo/]] +join [list "Error:" {*}[lmap e $errors {dict get $e errorInfo}]] "\n" +`); }, 500); } let jobid; diff --git a/virtual-programs/web-editor.folk b/virtual-programs/web-editor.folk index 6669d9fa..ae14f9b4 100644 --- a/virtual-programs/web-editor.folk +++ b/virtual-programs/web-editor.folk @@ -1,117 +1,121 @@ Wish the web server handles route {/page/(.*)$} with handler { if {[regexp -all {/page/(\d*)$} $path whole_match program_id]} { - set filename "../folk-printed-programs/$program_id.folk" + set filename "../folk-printed-programs/$program_id.folk" set fp [open $filename r] set file_data [read $fp] close $fp } elseif {[regexp -all {/page/(.*)$} $path whole_match program_id]} { - set filename "virtual-programs/$program_id.folk" + set filename "virtual-programs/$program_id.folk" set fp [open $filename r] set file_data [read $fp] close $fp } html [string map [list file_data [htmlEscape $file_data] program_id $program_id file_name $filename] { - - -
    - Status - - -
    - - 
    
-	
-	
-	
+            setTimeout(() => {
+              send(`
+set errors [Statements::findMatches [list program_id has error /err/ with info /errorInfo/]]
+join [list "Error:" {*}[lmap e $errors {dict get $e errorInfo}]] "\n"
+`);
+            }, 500);
+          }
+
+          let jobid;
+          function handlePrint() {
+            const code = document.getElementById("code").value;
+            jobid = String(Math.random());
+            send(`Assert web wishes to print program program_id with code {${code}} with job id {${jobid}}`);
+            setTimeout(500, () => {
+              send(`Retract web wishes to print program program_id with code {${code}} with job id {${jobid}}`);
+            });
+          }
+        
+        
+        
     }]
 }
-- 
cgit v1.2.3


From 408289c1faff488a54f30d50d77a61ac163c55a4 Mon Sep 17 00:00:00 2001
From: Omar Rizwan 
Date: Wed, 28 Jun 2023 10:49:38 -0400
Subject: Clean up process unmatch handler

---
 lib/process.tcl | 20 +++-----------------
 1 file changed, 3 insertions(+), 17 deletions(-)

diff --git a/lib/process.tcl b/lib/process.tcl
index 7176b9c2..b3aa9bf4 100644
--- a/lib/process.tcl
+++ b/lib/process.tcl
@@ -90,23 +90,9 @@ proc On-process {name body} {
         }} $processCode]
 
         When (non-capturing) $name has pid /pid/ {
-            On unmatch { exec kill -9 $pid }
+            On unmatch {
+                exec kill -9 $pid
+            }
         }
-
-        # proc handleUnmatch {} {
-        #     variable pid
-        #     variable name
-        #     exec kill -9 $pid
-        #     while {1} {
-        #       try {
-        #         exec kill -0 $pid
-        #       } on error err {
-        #         break
-        #       }
-        #     }
-        #     Retract /someone/ is running process $name
-        #     namespace delete ::Processes::$name
-        # }
-        # uplevel 2 [list On unmatch ::Processes::${name}::handleUnmatch]
     }
 }
-- 
cgit v1.2.3


From f2ea85d7498c5799d6b2c04af0a045d4e8f18f44 Mon Sep 17 00:00:00 2001
From: Omar Rizwan 
Date: Wed, 28 Jun 2023 10:49:48 -0400
Subject: Remove old Collect after adding new one

(May usually fix problem with virtual-program live edit, bc camera
won't have to get destroyed/replaced if you edit another virtual
program, bc this incrementalizes changes to the set of virtual programs)
---
 lib/evaluator.tcl | 31 +++++++++++++++++--------------
 1 file changed, 17 insertions(+), 14 deletions(-)

diff --git a/lib/evaluator.tcl b/lib/evaluator.tcl
index 119855ce..f890238b 100644
--- a/lib/evaluator.tcl
+++ b/lib/evaluator.tcl
@@ -995,20 +995,6 @@ namespace eval Evaluator {
 
         statement_t* collect = get(collectId);
 
-        // First, delete the existing match child.
-        {
-            for (size_t i = 0; i < collect->n_edges; i++) {
-                edge_to_match_t* edge = statementEdgeAt(collect, i);
-                if (edge->type == CHILD) {
-                    match_handle_t childMatchId = edge->match;
-                    matchGet(childMatchId)->recollectOnDestruction = false;
-                    reactToMatchRemoval(interp, childMatchId);
-                    matchRemove(childMatchId);
-                    break;
-                }
-            }
-        }
-
         Tcl_Obj* clause = collect->clause;
         int clauseLength; Tcl_Obj** clauseWords;
         Tcl_ListObjGetElements(interp, clause, &clauseLength, &clauseWords);
@@ -1040,15 +1026,32 @@ namespace eval Evaluator {
             }
         }
 
+        // Create a new match for the new collection.
         match_handle_t matchId = addMatchImpl(parentsCount, parents);
         match_t* match = matchGet(matchId);
         match->recollectOnDestruction = true;
         match->recollectCollectId = collectId;
 
+        // Run the When body within this new match.
         env = Tcl_DuplicateObj(env);
         Tcl_ListObjAppendElement(NULL, env, matches);
         Tcl_ObjSetVar2(interp, Tcl_ObjPrintf("::matchId"), NULL, Tcl_ObjPrintf("m%d:%d", matchId.idx, matchId.gen), 0);
         tryRunInSerializedEnvironment(interp, lambda, env);
+
+        // Finally, delete the old match child if any.
+        // (We do this last, _after_ adding the new match, because it helps with incrementality.)
+        {
+            for (size_t i = 0; i < collect->n_edges; i++) {
+                edge_to_match_t* edge = statementEdgeAt(collect, i);
+                if (edge->type == CHILD && !matchHandleIsEqual(edge->match, matchId)) {
+                    match_handle_t childMatchId = edge->match;
+                    matchGet(childMatchId)->recollectOnDestruction = false;
+                    reactToMatchRemoval(interp, childMatchId);
+                    matchRemove(childMatchId);
+                    break;
+                }
+            }
+        }
     }
 
     $cc code {
-- 
cgit v1.2.3


From da45db025e8a2ce6a70f0a1391f82756cfe0a560 Mon Sep 17 00:00:00 2001
From: Omar Rizwan 
Date: Thu, 29 Jun 2023 16:26:56 -0400
Subject: Retract statements on process disconnect. Fixes ghost?

---
 Makefile     |  2 +-
 lib/peer.tcl | 44 +++++++++++++++++++++++---------------------
 main.tcl     | 11 ++++++++---
 web.tcl      | 12 ++++++++++++
 4 files changed, 44 insertions(+), 25 deletions(-)

diff --git a/Makefile b/Makefile
index fe17ea2d..c3cdac01 100644
--- a/Makefile
+++ b/Makefile
@@ -29,7 +29,7 @@ ssh:
 	ssh folk@$(FOLK_SHARE_NODE)
 
 flamegraph:
-	sudo perf record -F 997 --tid=$(shell pgrep tclsh8.6) -g -- sleep 30
+	sudo perf record -F 997 --tid=$(shell pgrep tclsh8.6 | head) -g -- sleep 30
 	sudo perf script -f > out.perf
 	~/FlameGraph/stackcollapse-perf.pl out.perf > out.folded
 	~/FlameGraph/flamegraph.pl out.folded > out.svg
diff --git a/lib/peer.tcl b/lib/peer.tcl
index 513e204a..8618a126 100644
--- a/lib/peer.tcl
+++ b/lib/peer.tcl
@@ -19,20 +19,21 @@ namespace eval clauseset {
 
 namespace eval ::Peers {}
 
-proc ::peer {node} {
+proc ::peer {process} {
     package require websocket
-    namespace eval ::Peers::$node {
+    namespace eval ::Peers::$process {
         variable connected false
         variable prevShareStatements [clauseset create]
+        variable prevReceivedStatements [clauseset create]
 
         proc log {s} {
-            variable node
-            puts "$::thisProcess -> $node: $s"
+            variable process
+            puts "$::thisProcess -> $process: $s"
         }
         proc setupSock {} {
-            variable node
-            log "Trying to connect to: ws://$node:4273/ws"
-            variable sock [::websocket::open "ws://$node:4273/ws" [namespace code handleWs]]
+            variable process
+            log "Trying to connect to: ws://$process:4273/ws"
+            variable sock [::websocket::open "ws://$process:4273/ws" [namespace code handleWs]]
         }
         proc handleWs {sock type msg} {
             if {$type eq "connect"} {
@@ -42,6 +43,7 @@ proc ::peer {node} {
                 log "Disconnected"
                 variable connected false
                 variable prevShareStatements [clauseset create]
+                variable prevReceivedStatements [clauseset create]
                 after 2000 [namespace code setupSock]
             } elseif {$type eq "error"} {
                 log "WebSocket error: $type $msg"
@@ -56,28 +58,28 @@ proc ::peer {node} {
 
         proc run {msg} {
             variable sock
-            ::websocket::send $sock text $msg
+            ::websocket::send $sock text [list namespace eval ::Peers::$::thisProcess $msg]
         }
 
         proc init {n} {
-            variable node $n; setupSock
+            variable process $n; setupSock
             vwait ::Peers::${n}::connected
 
             # Establish a peering on their end, in the reverse
             # direction, so they can send stuff back to us.
-            run [format {
-                namespace eval {::Peers::%s} {
-                    variable connected true
-                    variable prevShareStatements [clauseset create]
-                    proc run {msg} {
-                        variable chan
-                        ::websocket::send $chan text $msg
-                    }
-
+            # It'll implicitly run in a ::Peers::X namespace on their end
+            # (because of how `run` is implemented above)
+            run {
+                variable chan [uplevel {set chan}]
+                variable connected true
+                variable prevShareStatements [clauseset create]
+                variable prevReceivedStatements [clauseset create]
+                proc run {msg} {
                     variable chan
-                } $chan
-            } $::thisProcess]
+                    ::websocket::send $chan text $msg
+                }
+            }
         }
         init
-    } $node
+    } $process
 }
diff --git a/main.tcl b/main.tcl
index 658bb4b9..dbbd6c7a 100644
--- a/main.tcl
+++ b/main.tcl
@@ -209,9 +209,14 @@ proc Step {} {
             set shareAssertStatements [clauseset clauses [clauseset minus $shareStatements $prevShareStatements]]
             set shareRetractStatements [clauseset clauses [clauseset minus $prevShareStatements $shareStatements]]
             if {[llength $shareAssertStatements] > 0 || [llength $shareRetractStatements] > 0} {
-                run [list apply {{shareAssertStatements shareRetractStatements} {
-                    foreach stmt $shareAssertStatements { Assert {*}$stmt }
-                    foreach stmt $shareRetractStatements { Retract {*}$stmt }
+                run [list apply {{receivedAssertStatements receivedRetractStatements} {
+                    upvar [uplevel {namespace current}]::prevReceivedStatements prevReceivedStatements
+                    # TODO: Just track process provenance in the statements?
+                    set prevReceivedStatements [clauseset minus \
+                                                    [clauseset add $prevReceivedStatements $receivedAssertStatements] \
+                                                    $receivedRetractStatements]
+                    foreach stmt $receivedAssertStatements { Assert {*}$stmt }
+                    foreach stmt $receivedRetractStatements { Retract {*}$stmt }
                     Step
                 }} $shareAssertStatements $shareRetractStatements]
             }
diff --git a/web.tcl b/web.tcl
index 1eb35ee7..40216ecb 100644
--- a/web.tcl
+++ b/web.tcl
@@ -156,6 +156,18 @@ proc handleWS {chan type msg} {
                 ::websocket::send $chan text $err
             } err2] { puts "$::thisProcess: $err2" }
         }
+    } elseif {$type eq "disconnect"} {
+        foreach peerNs [namespace children ::Peers] {
+            apply [list {disconnectedChan} {
+                variable chan
+                if {$chan eq $disconnectedChan} {
+                    variable prevReceivedStatements
+                    foreach stmt $prevReceivedStatements {
+                        Retract {*}$stmt
+                    }
+                }
+            } $peerNs] $chan
+        }
     } else {
         puts "$::thisProcess: Unhandled WS event $type on $chan ($msg)"
     }
-- 
cgit v1.2.3


From a07746b1b642b5492de81b55c170cc6afddd7181 Mon Sep 17 00:00:00 2001
From: Omar Rizwan 
Date: Thu, 29 Jun 2023 16:27:53 -0400
Subject: README updates

---
 README.md | 9 +--------
 1 file changed, 1 insertion(+), 8 deletions(-)

diff --git a/README.md b/README.md
index 0d539e9e..06d7575f 100644
--- a/README.md
+++ b/README.md
@@ -194,17 +194,10 @@ Edit /boot/cmdline.txt https://github.com/raspberrypi/firmware/issues/1647#issue
 https://askubuntu.com/questions/1321443/very-long-startup-time-on-ubuntu-server-network-configuration
 (add `optional: true` to all netplan interfaces)
 
-## Setup notes
-
-- get a separate computer (Raspberry Pi 4, probably). don't use your laptop.
-- make as solid / permanent a mount as you can. you shouldn't be
-  scared of it falling and you shouldn't have to take it apart and put
-  it back together every time
-
 ## License
 
 We intend to release this repo as open-source under an MIT, GPLv3,
-Apache 2.0, or AGPLv3 license by June 2023 or earlier; by contributing
+Apache 2.0, or AGPLv3 license in 2023; by contributing
 code, you're also agreeing to license your code under whichever
 license we end up choosing.
 
-- 
cgit v1.2.3


From cd88ed198e39cc969fedca8da56eff60fd6c2e0a Mon Sep 17 00:00:00 2001
From: Omar Rizwan 
Date: Thu, 29 Jun 2023 17:08:39 -0400
Subject: Fix minor(?) memory leak

---
 lib/evaluator.tcl | 1 +
 1 file changed, 1 insertion(+)

diff --git a/lib/evaluator.tcl b/lib/evaluator.tcl
index f890238b..6d462d09 100644
--- a/lib/evaluator.tcl
+++ b/lib/evaluator.tcl
@@ -1024,6 +1024,7 @@ namespace eval Evaluator {
             for (int j = 0; j < results[i]->matchedStatementIdsCount; j++) {
                 parents[parentsCount++] = results[i]->matchedStatementIds[j];
             }
+            ckfree((char *)results[i]);
         }
 
         // Create a new match for the new collection.
-- 
cgit v1.2.3


From b9eb1ed9ce0acddf5247a633dc2f3f9fb360efc5 Mon Sep 17 00:00:00 2001
From: Omar Rizwan 
Date: Thu, 29 Jun 2023 17:08:57 -0400
Subject: Actually fix root pairing from laptop

---
 lib/peer.tcl | 33 +++++++++++++++++----------------
 main.tcl     |  6 +++---
 2 files changed, 20 insertions(+), 19 deletions(-)

diff --git a/lib/peer.tcl b/lib/peer.tcl
index 8618a126..a412bea6 100644
--- a/lib/peer.tcl
+++ b/lib/peer.tcl
@@ -3,13 +3,14 @@ lappend auto_path "./vendor"
 namespace eval clauseset {
     # only used for statement syndication
 
-    namespace export create add minus clauses
+    namespace export create add remove minus clauses
     proc create {args} {
         set kvs [list]
         foreach k $args { lappend kvs $k true }
         dict create {*}$kvs
     }
     proc add {sv k} { upvar $sv s; dict set s $k true }
+    proc remove {sv k} { upvar $sv s; dict unset s $k }
     proc minus {s t} {
         dict filter $s script {k v} {expr {![dict exists $t $k]}}
     }
@@ -39,6 +40,21 @@ proc ::peer {process} {
             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 above)
+                run {
+                    variable chan [uplevel {set chan}]
+                    variable connected true
+                    variable prevShareStatements [clauseset create]
+                    variable prevReceivedStatements [clauseset create]
+                    proc run {msg} {
+                        variable chan
+                        ::websocket::send $chan text $msg
+                    }
+                }
             } elseif {$type eq "disconnect"} {
                 log "Disconnected"
                 variable connected false
@@ -64,21 +80,6 @@ proc ::peer {process} {
         proc init {n} {
             variable process $n; setupSock
             vwait ::Peers::${n}::connected
-
-            # 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 above)
-            run {
-                variable chan [uplevel {set chan}]
-                variable connected true
-                variable prevShareStatements [clauseset create]
-                variable prevReceivedStatements [clauseset create]
-                proc run {msg} {
-                    variable chan
-                    ::websocket::send $chan text $msg
-                }
-            }
         }
         init
     } $process
diff --git a/main.tcl b/main.tcl
index dbbd6c7a..11b22aa3 100644
--- a/main.tcl
+++ b/main.tcl
@@ -212,9 +212,9 @@ proc Step {} {
                 run [list apply {{receivedAssertStatements receivedRetractStatements} {
                     upvar [uplevel {namespace current}]::prevReceivedStatements prevReceivedStatements
                     # TODO: Just track process provenance in the statements?
-                    set prevReceivedStatements [clauseset minus \
-                                                    [clauseset add $prevReceivedStatements $receivedAssertStatements] \
-                                                    $receivedRetractStatements]
+                    clauseset add prevReceivedStatements $receivedAssertStatements
+                    clauseset remove prevReceivedStatements $receivedRetractStatements
+
                     foreach stmt $receivedAssertStatements { Assert {*}$stmt }
                     foreach stmt $receivedRetractStatements { Retract {*}$stmt }
                     Step
-- 
cgit v1.2.3


From b0d6328206fd7327149e0707ffc57fac964b5e47 Mon Sep 17 00:00:00 2001
From: Omar Rizwan 
Date: Thu, 29 Jun 2023 17:10:31 -0400
Subject: Try to get just main thread for flamegraph

---
 Makefile | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/Makefile b/Makefile
index c3cdac01..97b31d65 100644
--- a/Makefile
+++ b/Makefile
@@ -29,7 +29,7 @@ ssh:
 	ssh folk@$(FOLK_SHARE_NODE)
 
 flamegraph:
-	sudo perf record -F 997 --tid=$(shell pgrep tclsh8.6 | head) -g -- sleep 30
+	sudo perf record -F 997 --tid=$(shell pgrep tclsh8.6 | awk '{print $1}') -g -- sleep 30
 	sudo perf script -f > out.perf
 	~/FlameGraph/stackcollapse-perf.pl out.perf > out.folded
 	~/FlameGraph/flamegraph.pl out.folded > out.svg
-- 
cgit v1.2.3


From c69e98c4d9295b70d0a063e5bc2012140fc9d4b0 Mon Sep 17 00:00:00 2001
From: Omar Rizwan 
Date: Thu, 29 Jun 2023 17:35:27 -0400
Subject: Properly dispose invalidated statements. Live edit works?

---
 lib/peer.tcl | 10 ++++++----
 main.tcl     | 12 ++++++------
 2 files changed, 12 insertions(+), 10 deletions(-)

diff --git a/lib/peer.tcl b/lib/peer.tcl
index a412bea6..49f7bb26 100644
--- a/lib/peer.tcl
+++ b/lib/peer.tcl
@@ -3,17 +3,19 @@ lappend auto_path "./vendor"
 namespace eval clauseset {
     # only used for statement syndication
 
-    namespace export create add remove minus clauses
+    namespace export create add union difference clauses
     proc create {args} {
         set kvs [list]
         foreach k $args { lappend kvs $k true }
         dict create {*}$kvs
     }
-    proc add {sv k} { upvar $sv s; dict set s $k true }
-    proc remove {sv k} { upvar $sv s; dict unset s $k }
-    proc minus {s t} {
+    proc add {sv stmt} { upvar $sv s; dict set s $stmt true }
+
+    proc union {s t} { dict merge $s $t }
+    proc difference {s t} {
         dict filter $s script {k v} {expr {![dict exists $t $k]}}
     }
+
     proc clauses {s} { dict keys $s }
     namespace ensemble create
 }
diff --git a/main.tcl b/main.tcl
index 11b22aa3..163534d6 100644
--- a/main.tcl
+++ b/main.tcl
@@ -206,17 +206,17 @@ proc Step {} {
             }
 
             variable prevShareStatements
-            set shareAssertStatements [clauseset clauses [clauseset minus $shareStatements $prevShareStatements]]
-            set shareRetractStatements [clauseset clauses [clauseset minus $prevShareStatements $shareStatements]]
+            set shareAssertStatements [clauseset difference $shareStatements $prevShareStatements]
+            set shareRetractStatements [clauseset difference $prevShareStatements $shareStatements]
             if {[llength $shareAssertStatements] > 0 || [llength $shareRetractStatements] > 0} {
                 run [list apply {{receivedAssertStatements receivedRetractStatements} {
                     upvar [uplevel {namespace current}]::prevReceivedStatements prevReceivedStatements
                     # TODO: Just track process provenance in the statements?
-                    clauseset add prevReceivedStatements $receivedAssertStatements
-                    clauseset remove prevReceivedStatements $receivedRetractStatements
+                    set prevReceivedStatements [clauseset union $prevReceivedStatements $receivedAssertStatements]
+                    set prevReceivedStatements [clauseset difference $prevReceivedStatements $receivedRetractStatements]
 
-                    foreach stmt $receivedAssertStatements { Assert {*}$stmt }
-                    foreach stmt $receivedRetractStatements { Retract {*}$stmt }
+                    dict for {stmt _} $receivedAssertStatements { Assert {*}$stmt }
+                    dict for {stmt _} $receivedRetractStatements { Retract {*}$stmt }
                     Step
                 }} $shareAssertStatements $shareRetractStatements]
             }
-- 
cgit v1.2.3


From d5eef54671532767fbaec67c91bab1fae9e7b17b Mon Sep 17 00:00:00 2001
From: Omar Rizwan 
Date: Thu, 29 Jun 2023 19:07:04 -0400
Subject: Introduce shared Folk heap: fixes blob detector

---
 main.tcl         | 47 +++++++++++++++++++++++++++++++++++++++++++++++
 pi/AprilTags.tcl |  2 --
 pi/Camera.tcl    | 11 ++++++++---
 pi/cUtils.tcl    | 23 -----------------------
 4 files changed, 55 insertions(+), 28 deletions(-)

diff --git a/main.tcl b/main.tcl
index 163534d6..d1ead649 100644
--- a/main.tcl
+++ b/main.tcl
@@ -241,6 +241,53 @@ Assert when /__this/ has program code /__programCode/ {{__this __programCode} {
 set ::thisNode "[info hostname]"
 set ::nodename $::thisNode ;# for backward compat
 
+namespace eval ::Heap {
+    # Folk has a shared heap among all processes on a given node
+    # (physical machine).
+
+    # Memory allocated from the Folk heap should be accessible, at
+    # exactly the same virtual address, from any Folk process.
+
+    proc init {} {
+        variable cc [c create]
+        $cc include 
+        $cc include 
+        $cc include 
+        $cc include 
+        $cc include 
+        $cc code {
+            size_t folkHeapSize = 100000000; // 100MB
+            uint8_t* folkHeapBase;
+            uint8_t* _Atomic folkHeapPointer;
+        }
+        # The memory mapping of the heap will be inherited by all
+        # subprocesses, since it's established before the creation of
+        # the zygote.
+        $cc proc folkHeapMount {} void {
+            int fd = shm_open("/folk-heap", O_RDWR | O_CREAT, S_IROTH | S_IWOTH | S_IRUSR | S_IWUSR);
+            ftruncate(fd, folkHeapSize);
+            folkHeapBase = (uint8_t*) mmap(0, folkHeapSize,
+                                           PROT_READ | PROT_WRITE, MAP_SHARED, fd, 0);
+            if (folkHeapBase == NULL) {
+                fprintf(stderr, "heapMount: failed"); exit(1);
+            }
+            folkHeapPointer = folkHeapBase;
+        }
+        $cc proc folkHeapAlloc {size_t sz} void* {
+            if (folkHeapPointer + sz > folkHeapBase + folkHeapSize) {
+                fprintf(stderr, "heapAlloc: out of memory"); exit(1);
+            }
+            void* ptr = folkHeapPointer;
+            folkHeapPointer = folkHeapPointer + sz;
+            return (void*) ptr;
+        }
+        if {$::tcl_platform(os) eq "Linux"} { $cc cflags -lrt }
+        $cc compile
+        folkHeapMount
+    }
+}
+Heap::init
+
 if {[info exists ::entry]} {
     source "lib/process.tcl"
     Zygote::init
diff --git a/pi/AprilTags.tcl b/pi/AprilTags.tcl
index 8d3b8a06..a489a1f4 100644
--- a/pi/AprilTags.tcl
+++ b/pi/AprilTags.tcl
@@ -12,10 +12,8 @@ namespace eval AprilTags {
         apriltag_family_t *tf;
     }
     defineImageType apc
-    defineFolkImages apc
 
     apc proc detectInit {} void {
-        folkImagesMount();
         td = apriltag_detector_create();
         tf = tagStandard52h13_create();
         apriltag_detector_add_family_bits(td, tf, 1);
diff --git a/pi/Camera.tcl b/pi/Camera.tcl
index 50623da9..963d1261 100644
--- a/pi/Camera.tcl
+++ b/pi/Camera.tcl
@@ -33,6 +33,8 @@ namespace eval Camera {
     }
 
     camc code {
+        uint8_t* folkImagesBase;
+
         void quit(const char* msg) {
             fprintf(stderr, "[%s] %d: %s\n", msg, errno, strerror(errno));
             exit(1);
@@ -48,7 +50,6 @@ namespace eval Camera {
         }
     }
     defineImageType camc
-    defineFolkImages camc
 
     camc proc cameraOpen {char* device int width int height} camera_t* {
         printf("device [%s]\n", device);
@@ -226,7 +227,13 @@ namespace eval Camera {
         };
     }
 
+    camc import ::Heap::cc folkHeapAlloc as folkHeapAlloc
     camc proc newImage {int width int height int components} image_t {
+        if (folkImagesBase == NULL) {
+            folkImagesBase = folkHeapAlloc(50000000); // 50MB
+        }
+
+        // FIXME: This is a hack.
         static int imageCount = 0;
         imageCount = (imageCount + 1) % 20;
 
@@ -257,8 +264,6 @@ namespace eval Camera {
         set WIDTH $width
         set HEIGHT $height
 
-        folkImagesMount
-
         try {
           while {1} {
             set pid [exec lsof -t "/dev/video0"]
diff --git a/pi/cUtils.tcl b/pi/cUtils.tcl
index d0046857..8c15296f 100644
--- a/pi/cUtils.tcl
+++ b/pi/cUtils.tcl
@@ -29,26 +29,3 @@ proc ::defineImageType {cc} {
         $robj = Tcl_ObjPrintf("width %u height %u components %d bytesPerRow %u data 0x%" PRIxPTR, $rvalue.width, $rvalue.height, $rvalue.components, $rvalue.bytesPerRow, (uintptr_t) $rvalue.data);
     }
 }
-
-proc ::defineFolkImages {cc} {
-    set cc [uplevel {namespace current}]::$cc
-    $cc include 
-    $cc include 
-    $cc include 
-    $cc include 
-    $cc include 
-    $cc code {
-        uint8_t* folkImagesBase = (uint8_t*) 0x280000000;
-        size_t folkImagesSize = 100000000; // 100MB
-    }
-    $cc proc folkImagesMount {} void {
-        int fd = shm_open("/folk-images", O_RDWR | O_CREAT, S_IROTH | S_IWOTH | S_IRUSR | S_IWUSR);
-        ftruncate(fd, folkImagesSize);
-        void* ptr = mmap(folkImagesBase, folkImagesSize,
-                         PROT_READ | PROT_WRITE, MAP_SHARED | MAP_FIXED, fd, 0);
-        if (ptr == NULL || ptr != folkImagesBase) {
-            fprintf(stderr, "shmMount: failed"); exit(1);
-        }
-    }
-    $cc cflags -lrt
-}
-- 
cgit v1.2.3


From 635445b8148114efc1990f33e8ef35b81416e443 Mon Sep 17 00:00:00 2001
From: Omar Rizwan 
Date: Thu, 29 Jun 2023 19:13:44 -0400
Subject: Actually fix remote-flamegraph

---
 Makefile | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/Makefile b/Makefile
index 97b31d65..d83bfceb 100644
--- a/Makefile
+++ b/Makefile
@@ -29,7 +29,7 @@ ssh:
 	ssh folk@$(FOLK_SHARE_NODE)
 
 flamegraph:
-	sudo perf record -F 997 --tid=$(shell pgrep tclsh8.6 | awk '{print $1}') -g -- sleep 30
+	sudo perf record -F 997 --tid=$(shell pgrep tclsh8.6 | head -1) -g -- sleep 30
 	sudo perf script -f > out.perf
 	~/FlameGraph/stackcollapse-perf.pl out.perf > out.folded
 	~/FlameGraph/flamegraph.pl out.folded > out.svg
-- 
cgit v1.2.3


From d5552d2b7454ea58d88497d9df2fb6a07d42f1f8 Mon Sep 17 00:00:00 2001
From: Omar Rizwan 
Date: Thu, 29 Jun 2023 19:32:42 -0400
Subject: Measure stepTime including peer time

---
 main.tcl | 6 ++++--
 1 file changed, 4 insertions(+), 2 deletions(-)

diff --git a/main.tcl b/main.tcl
index d1ead649..70598647 100644
--- a/main.tcl
+++ b/main.tcl
@@ -169,11 +169,12 @@ proc Commit {args} {
 set ::stepCount 0
 set ::stepTime "none"
 source "lib/peer.tcl"
-proc Step {} {
+proc StepImpl {} {
     incr ::stepCount
     Assert $::thisProcess has step count $::stepCount
     Retract $::thisProcess has step count [expr {$::stepCount - 1}]
-    set ::stepTime [time {Evaluator::Evaluate}]
+
+    Evaluator::Evaluate
 
     if {[namespace exists Display]} {
         Display::commit ;# TODO: this is weird, not right level
@@ -224,6 +225,7 @@ proc Step {} {
         } $peerNs] [namespace tail $peerNs]
     }
 }
+proc Step {} { set ::stepTime [time StepImpl] }
 
 source "lib/math.tcl"
 
-- 
cgit v1.2.3


From a3e789bf5ecb1aef73e7897365da1cf773fee322 Mon Sep 17 00:00:00 2001
From: Omar Rizwan 
Date: Fri, 30 Jun 2023 01:03:57 -0400
Subject: Add doubles to c.tcl

---
 lib/c.tcl | 2 ++
 1 file changed, 2 insertions(+)

diff --git a/lib/c.tcl b/lib/c.tcl
index ce59855a..503e0b9f 100644
--- a/lib/c.tcl
+++ b/lib/c.tcl
@@ -68,6 +68,7 @@ namespace eval c {
 
             variable argtypes {
                 int { expr {{ int $argname; __ENSURE_OK(Tcl_GetIntFromObj(interp, $obj, &$argname)); }}}
+                double { expr {{ double $argname; __ENSURE_OK(Tcl_GetDoubleFromObj(interp, $obj, &$argname)); }}}
                 bool { expr {{ int $argname; __ENSURE_OK(Tcl_GetIntFromObj(interp, $obj, &$argname)); }}}
                 int32_t { expr {{ int $argname; __ENSURE_OK(Tcl_GetIntFromObj(interp, $obj, &$argname)); }}}
                 char { expr {{
@@ -122,6 +123,7 @@ namespace eval c {
             variable rtypes {
                 int { expr {{ $robj = Tcl_NewIntObj($rvalue); }}}
                 int32_t { expr {{ $robj = Tcl_NewIntObj($rvalue); }}}
+                double { expr {{ $robj = Tcl_NewDoubleObj($rvalue); }}}
                 char { expr {{ $robj = Tcl_ObjPrintf("%c", $rvalue); }}}
                 bool { expr {{ $robj = Tcl_NewIntObj($rvalue); }}}
                 uint16_t { expr {{ $robj = Tcl_NewIntObj($rvalue); }}}
-- 
cgit v1.2.3


From 706015fdab34c9f39447b0f78a30b461d7bf4af8 Mon Sep 17 00:00:00 2001
From: Omar Rizwan 
Date: Fri, 30 Jun 2023 01:04:05 -0400
Subject: Load librt for Pi

---
 main.tcl | 5 ++++-
 1 file changed, 4 insertions(+), 1 deletion(-)

diff --git a/main.tcl b/main.tcl
index 70598647..86ae9e0e 100644
--- a/main.tcl
+++ b/main.tcl
@@ -283,7 +283,10 @@ namespace eval ::Heap {
             folkHeapPointer = folkHeapPointer + sz;
             return (void*) ptr;
         }
-        if {$::tcl_platform(os) eq "Linux"} { $cc cflags -lrt }
+        if {$::tcl_platform(os) eq "Linux"} {
+            $cc cflags -lrt
+            c loadlib [lindex [exec /usr/sbin/ldconfig -p | grep librt.so] end]
+        }
         $cc compile
         folkHeapMount
     }
-- 
cgit v1.2.3


From 7d34fdb07745b4e468a425122feeaf2d7515593b Mon Sep 17 00:00:00 2001
From: Omar Rizwan 
Date: Fri, 30 Jun 2023 13:43:42 -0400
Subject: Fix load librt to work on folk0 also

(it was accidentally trying to load the 32-bit librt.so at end)
---
 main.tcl | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/main.tcl b/main.tcl
index 86ae9e0e..e679a1ee 100644
--- a/main.tcl
+++ b/main.tcl
@@ -285,7 +285,7 @@ namespace eval ::Heap {
         }
         if {$::tcl_platform(os) eq "Linux"} {
             $cc cflags -lrt
-            c loadlib [lindex [exec /usr/sbin/ldconfig -p | grep librt.so] end]
+            c loadlib [lindex [exec /usr/sbin/ldconfig -p | grep librt.so | head -1] end]
         }
         $cc compile
         folkHeapMount
-- 
cgit v1.2.3