diff --git a/game.js b/game.js index 89f0b12..31411ba 100644 --- a/game.js +++ b/game.js @@ -1,71 +1,73 @@ window.addEventListener("load", async () => { try { - await Scheme.load_main("game.wasm", {}, { - window: { - get: () => window, - innerWidth: () => window.innerWidth, - innerHeight: () => window.innerHeight, - requestAnimationFrame: (f) => window.requestAnimationFrame(f), - setTimeout: (f, delay) => window.setTimeout(f, delay) - }, - document: { - get: () => document, - body: () => document.body, - getElementById: (id) => document.getElementById(id), - createTextNode: (text) => document.createTextNode(text), - createElement: (tag) => document.createElement(tag) - }, - element: { - value: (elem) => elem.value, - setValue: (elem, value) => elem.value = value, - width: (elem) => elem.width, - height: (elem) => elem.height, - setWidth: (elem, width) => elem.width = width, - setHeight: (elem, height) => elem.height = height, - appendChild: (parent, child) => parent.appendChild(child), - setAttribute: (elem, name, value) => elem.setAttribute(name, value), - removeAttribute: (elem, name) => elem.removeAttribute(name), - remove: (elem) => elem.remove(), - replaceWith: (oldElem, newElem) => oldElem.replaceWith(newElem), - clone: (elem) => elem.cloneNode() - }, - event: { - addEventListener: (target, type, listener) => target.addEventListener(type, listener), - removeEventListener: (target, type, listener) => target.removeEventListener(type, listener), - preventDefault: (event) => event.preventDefault(), - keyboardCode: (event) => event.code - }, - image: { - new: (src) => { - const img = new Image(); - img.src = src; - return img; + await Scheme.load_main("game.wasm", { + user_imports: { + window: { + get: () => window, + innerWidth: () => window.innerWidth, + innerHeight: () => window.innerHeight, + requestAnimationFrame: (f) => window.requestAnimationFrame(f), + setTimeout: (f, delay) => window.setTimeout(f, delay) + }, + document: { + get: () => document, + body: () => document.body, + getElementById: (id) => document.getElementById(id), + createTextNode: (text) => document.createTextNode(text), + createElement: (tag) => document.createElement(tag) + }, + element: { + value: (elem) => elem.value, + setValue: (elem, value) => elem.value = value, + width: (elem) => elem.width, + height: (elem) => elem.height, + setWidth: (elem, width) => elem.width = width, + setHeight: (elem, height) => elem.height = height, + appendChild: (parent, child) => parent.appendChild(child), + setAttribute: (elem, name, value) => elem.setAttribute(name, value), + removeAttribute: (elem, name) => elem.removeAttribute(name), + remove: (elem) => elem.remove(), + replaceWith: (oldElem, newElem) => oldElem.replaceWith(newElem), + clone: (elem) => elem.cloneNode() + }, + event: { + addEventListener: (target, type, listener) => target.addEventListener(type, listener), + removeEventListener: (target, type, listener) => target.removeEventListener(type, listener), + preventDefault: (event) => event.preventDefault(), + keyboardCode: (event) => event.code + }, + image: { + new: (src) => { + const img = new Image(); + img.src = src; + return img; + } + }, + media: { + newAudio: (src) => new Audio(src), + play: (media) => media.play(), + pause: (media) => media.pause(), + volume: (media) => media.volume, + setVolume: (media, volume) => media.volume = volume, + setLoop: (media, loop) => media.loop = (loop == 1), + seek: (media, time) => media.currentTime = time + }, + canvas: { + getContext: (elem, type) => elem.getContext(type), + setFillColor: (ctx, color) => ctx.fillStyle = color, + setFont: (ctx, font) => ctx.font = font, + setTextAlign: (ctx, align) => ctx.textAlign = align, + clearRect: (ctx, x, y, w, h) => ctx.clearRect(x, y, w, h), + fillRect: (ctx, x, y, w, h) => ctx.fillRect(x, y, w, h), + fillText: (ctx, text, x, y) => ctx.fillText(text, x, y), + drawImage: (ctx, image, sx, sy, sw, sh, dx, dy, dw, dh) => ctx.drawImage(image, sx, sy, sw, sh, dx, dy, dw, dh), + setScale: (ctx, sx, sy) => ctx.scale(sx, sy), + setTransform: (ctx, a, b, c, d, e, f) => ctx.setTransform(a, b, c, d, e, f), + setImageSmoothingEnabled: (ctx, enabled) => ctx.imageSmoothingEnabled = (enabled == 1) + }, + math: { + random: () => Math.random() } - }, - media: { - newAudio: (src) => new Audio(src), - play: (media) => media.play(), - pause: (media) => media.pause(), - volume: (media) => media.volume, - setVolume: (media, volume) => media.volume = volume, - setLoop: (media, loop) => media.loop = (loop == 1), - seek: (media, time) => media.currentTime = time - }, - canvas: { - getContext: (elem, type) => elem.getContext(type), - setFillColor: (ctx, color) => ctx.fillStyle = color, - setFont: (ctx, font) => ctx.font = font, - setTextAlign: (ctx, align) => ctx.textAlign = align, - clearRect: (ctx, x, y, w, h) => ctx.clearRect(x, y, w, h), - fillRect: (ctx, x, y, w, h) => ctx.fillRect(x, y, w, h), - fillText: (ctx, text, x, y) => ctx.fillText(text, x, y), - drawImage: (ctx, image, sx, sy, sw, sh, dx, dy, dw, dh) => ctx.drawImage(image, sx, sy, sw, sh, dx, dy, dw, dh), - setScale: (ctx, sx, sy) => ctx.scale(sx, sy), - setTransform: (ctx, a, b, c, d, e, f) => ctx.setTransform(a, b, c, d, e, f), - setImageSmoothingEnabled: (ctx, enabled) => ctx.imageSmoothingEnabled = (enabled == 1) - }, - math: { - random: () => Math.random() } }); } catch(e) { diff --git a/game.scm b/game.scm index 4c1042c..a742289 100644 --- a/game.scm +++ b/game.scm @@ -18,235 +18,26 @@ ;;; ;;; Code: -(import (scheme base) - (scheme inexact) - (hoot debug) - (hoot ffi) - (hoot hashtables) - (hoot match) - (dom canvas) - (dom document) - (dom element) - (dom event) - (dom image) - (dom media) - (dom window) - (math) - (math rect) - (math vector)) +(use-modules (dom canvas) + (dom document) + (dom element) + (dom event) + (dom image) + (dom media) + (dom window) + (hoot ffi) + (hoot hashtables) + (ice-9 match) + (math) + (math rect) + (math vector)) -;; Data types -(define-record-type - (make-brick-type image points) - brick-type? - (image brick-type-image) - (points brick-type-points)) - -(define-record-type - (make-brick type hitbox) - brick? - (type brick-type) - (hitbox brick-hitbox) - (broken? brick-broken? set-brick-broken!)) - -(define-record-type - (make-ball velocity hitbox) - ball? - (velocity ball-velocity) - (hitbox ball-hitbox)) - -(define-record-type - (make-paddle velocity hitbox) - paddle? - (velocity paddle-velocity) - (hitbox paddle-hitbox)) - -(define-record-type - (make-level state bricks ball paddle score move-left? move-right?) - level? - (state level-state set-level-state!) ; play, win, lose - (bricks level-bricks) - (ball level-ball) - (paddle level-paddle) - (score level-score set-level-score!) - (move-left? level-move-left? set-level-move-left!) - (move-right? level-move-right? set-level-move-right!)) - -;; Assets -(define image:paddle (make-image "assets/images/paddle.png")) -(define image:ball (make-image "assets/images/ball.png")) -(define image:brick-red (make-image "assets/images/brick-red.png")) -(define image:brick-green (make-image "assets/images/brick-green.png")) -(define image:brick-blue (make-image "assets/images/brick-blue.png")) -(define audio:brick (make-audio "assets/sounds/brick.wav")) -(define audio:paddle (make-audio "assets/sounds/paddle.wav")) - -;; Game data -(define game-width 640.0) -(define game-height 480.0) -(define brick-width 64.0) -(define brick-height 32.0) -(define ball-width 22.0) -(define ball-height 22.0) -(define paddle-width 104.0) -(define paddle-height 24.0) -(define paddle-speed 6.0) -(define brick:red (make-brick-type image:brick-red 10)) -(define brick:green (make-brick-type image:brick-green 20)) -(define brick:blue (make-brick-type image:brick-blue 30)) - -(define (make-brick* type x y) - (make-brick type (make-rect x y brick-width brick-height))) - -(define (make-brick-grid types) - (let* ((h (vector-length types)) - (w (vector-length (vector-ref types 0))) - (offset-x (/ (- game-width (* w brick-width)) 2.0)) - (offset-y 48.0) - (bricks (make-vector (* w h)))) - (do ((y 0 (+ y 1))) - ((= y h)) - (let ((row (vector-ref types y))) - (do ((x 0 (+ x 1))) - ((= x w)) - (vector-set! bricks (+ (* y w) x) - (make-brick* (vector-ref row x) - (+ offset-x (* x brick-width)) - (+ offset-y (* y brick-height))))))) - bricks)) - -(define (make-level-1) - (make-level 'play - (make-brick-grid - (vector - (vector brick:red brick:green brick:blue brick:red brick:green brick:blue brick:red brick:green) - (vector brick:green brick:blue brick:red brick:green brick:blue brick:red brick:green brick:blue) - (vector brick:blue brick:red brick:green brick:blue brick:red brick:green brick:blue brick:red) - (vector brick:red brick:green brick:blue brick:red brick:green brick:blue brick:red brick:green) - (vector brick:green brick:blue brick:red brick:green brick:blue brick:red brick:green brick:blue) - (vector brick:blue brick:red brick:green brick:blue brick:red brick:green brick:blue brick:red))) - (make-ball (vec2 1.0 3.0) - (make-rect (/ game-width 2.0) (/ game-height 2.0) - ball-width ball-height)) - (make-paddle (vec2 0.0 0.0) - (make-rect (- (/ game-width 2.0) - (/ paddle-width 2.0)) - (- game-height paddle-height 8.0) - paddle-width paddle-height)) - 0 #f #f)) - -;; Game state -(define *level* (make-level-1)) - -(define (level-clear? level) - (let ((bricks (level-bricks level))) - (let loop ((i 0)) - (if (< i (vector-length bricks)) - (if (brick-broken? (vector-ref bricks i)) - (loop (+ i 1)) - #f) - #t)))) - -(define (win! level) - (set-level-state! level 'win)) - -(define (lose! level) - (set-level-state! level 'lose)) - -(define (update-paddle-velocity! level) - (let ((speed (* paddle-speed - (+ (if (level-move-left? level) -1.0 0.0) - (if (level-move-right? level) 1.0 0.0))))) - (set-vec2-x! (paddle-velocity (level-paddle level)) speed))) - -(define (speed-up-ball! ball) - (let* ((v (ball-velocity ball)) - (speed (+ (vec2-magnitude v) (* (random) 0.1))) - ;; Also change its angle slightly. Not the proper Breakout - ;; behavior but I don't want to write the code for that. :) - (dir (+ (atan (vec2-y v) (vec2-x v)) - (- (* (random) 0.5) 0.25)))) - (set-vec2-x! v (* (cos dir) speed)) - (set-vec2-y! v (* (sin dir) speed)))) - -(define (reflect-ball! ball x? y?) - (let ((v (ball-velocity ball))) - (when x? (set-vec2-x! v (- (vec2-x v)))) - (when y? (set-vec2-y! v (- (vec2-y v)))))) - -(define (collide-ball! ball hitbox) - (let ((b-hitbox (ball-hitbox ball))) - (and (rect-intersects? b-hitbox hitbox) - (let ((overlap (rect-clip b-hitbox hitbox))) - ;; Resolve collision by adjusting the ball's position the - ;; minimum amount along the X or Y axis. - (if (< (rect-width overlap) (rect-height overlap)) - (begin - (reflect-ball! ball #t #f) - (if (= (rect-x b-hitbox) (rect-x overlap)) - (set-rect-x! b-hitbox (+ (rect-x b-hitbox) (rect-width overlap))) - (set-rect-x! b-hitbox (- (rect-x b-hitbox) (rect-width overlap))))) - (begin - (reflect-ball! ball #f #t) - (if (= (rect-y b-hitbox) (rect-y overlap)) - (set-rect-y! b-hitbox (+ (rect-y b-hitbox) (rect-height overlap))) - (set-rect-y! b-hitbox (- (rect-y b-hitbox) (rect-height overlap)))))))))) +(define game-width 320.0) +(define game-height 240.0) (define dt (/ 1000.0 60.0)) ; aim for updating at 60Hz (define (update) - (match (level-state *level*) - ('play - (let* ((bricks (level-bricks *level*)) - (ball (level-ball *level*)) - (b-velocity (ball-velocity ball)) - (b-hitbox (ball-hitbox ball)) - (paddle (level-paddle *level*)) - (p-velocity (paddle-velocity paddle)) - (p-hitbox (paddle-hitbox paddle)) - (score (level-score *level*))) - ;; Move ball and paddle - (set-rect-x! b-hitbox (+ (rect-x b-hitbox) (vec2-x b-velocity))) - (set-rect-y! b-hitbox (+ (rect-y b-hitbox) (vec2-y b-velocity))) - ;; We only move the paddle along the x-axis. - (set-rect-x! p-hitbox - (clamp (+ (rect-x p-hitbox) (vec2-x p-velocity)) - 0.0 - (- game-width paddle-width))) - ;; Collide ball against walls, bricks, and paddle. - (cond - ((< (rect-x b-hitbox) 0.0) ; left wall - (set-rect-x! b-hitbox 0.0) - (reflect-ball! ball #t #f)) - ((> (+ (rect-x b-hitbox) (rect-width b-hitbox)) game-width) ; right wall - (set-rect-x! b-hitbox (- game-width (rect-width b-hitbox))) - (reflect-ball! ball #t #f)) - ((< (rect-y b-hitbox) 0.0) ; top wall - (set-rect-y! b-hitbox 0.0) - (reflect-ball! ball #f #t)) - ((> (+ (rect-y b-hitbox) (rect-height b-hitbox)) game-height) ; bottom wall - (lose! *level*)) - ((collide-ball! ball (paddle-hitbox paddle)) - (media-play audio:paddle) - (speed-up-ball! ball)) - (else - (let loop ((i 0) (hit? #f)) - (if (< i (vector-length bricks)) - (let ((brick (vector-ref bricks i))) - (if (and (not (brick-broken? brick)) - (collide-ball! ball (brick-hitbox brick))) - (begin - (media-play audio:brick) - (speed-up-ball! ball) - (set-brick-broken! brick #t) - (set-level-score! *level* - (+ (level-score *level*) - (brick-type-points (brick-type brick)))) - (loop (+ i 1) #t)) - (loop (+ i 1) hit?))) - ;; Maybe change to win state if all bricks are broken. - (when (and hit? (level-clear? *level*)) - (win! *level*)))))))) - (_ #t)) + #t (timeout update-callback dt)) (define update-callback (procedure->external update)) @@ -260,53 +51,12 @@ str))))) (define (draw prev-time) - (let ((bricks (level-bricks *level*)) - (ball (level-ball *level*)) - (paddle (level-paddle *level*)) - (score (level-score *level*))) - ;; Draw background - (set-fill-color! context "#140c1c") - (fill-rect context 0.0 0.0 game-width game-height) - ;; Draw bricks - (do ((i 0 (+ i 1))) - ((= i (vector-length bricks))) - (let* ((brick (vector-ref bricks i)) - (type (brick-type brick)) - (hitbox (brick-hitbox brick))) - (unless (brick-broken? brick) - (draw-image context (brick-type-image type) - 0.0 0.0 - brick-width brick-height - (rect-x hitbox) (rect-y hitbox) - brick-width brick-height)))) - ;; Draw paddle - (let ((w 104.0) - (h 24.0) - (hitbox (paddle-hitbox paddle))) - (draw-image context image:paddle - 0.0 0.0 w h - (rect-x hitbox) (rect-y hitbox) w h)) - ;; Draw ball - (let ((w 22.0) - (h 22.0) - (hitbox (ball-hitbox ball))) - (draw-image context image:ball - 0.0 0.0 w h - (rect-x hitbox) (rect-y hitbox) w h)) - ;; Print score - (set-fill-color! context "#ffffff") - (set-font! context "bold 24px monospace") - (set-text-align! context "left") - (fill-text context "SCORE:" 16.0 36.0) - (fill-text context (number->string* score) 108.0 36.0) - (match (level-state *level*) - ('win - (set-text-align! context "center") - (fill-text context "YAY YOU DID IT!!!" (/ game-width 2.0) (/ game-height 2.0))) - ('lose - (set-text-align! context "center") - (fill-text context "OH NO, GAME OVER :(" (/ game-width 2.0) (/ game-height 2.0))) - (_ #t))) + (set-fill-color! context "#140c1c") + (fill-rect context 0.0 0.0 game-width game-height) + (set-fill-color! context "#ffffff") + (set-font! context "bold 24px monospace") + (set-text-align! context "left") + (fill-text context "HELLO" 16.0 36.0) (request-animation-frame draw-callback)) (define draw-callback (procedure->external draw)) @@ -317,37 +67,17 @@ (define (on-key-down event) (let ((key (keyboard-event-code event))) - (match (level-state *level*) - ('play - (cond - ((string=? key key:left) - (set-level-move-left! *level* #t) - (update-paddle-velocity! *level*)) - ((string=? key key:right) - (set-level-move-right! *level* #t) - (update-paddle-velocity! *level*)))) - ((or 'win 'lose) - (when (string=? key key:confirm) - (set! *level* (make-level-1))))))) + (pk 'key-down key))) (define (on-key-up event) (let ((key (keyboard-event-code event))) - (match (level-state *level*) - ('play - (cond - ((string=? key key:left) - (set-level-move-left! *level* #f) - (update-paddle-velocity! *level*)) - ((string=? key key:right) - (set-level-move-right! *level* #f) - (update-paddle-velocity! *level*)))) - (_ #t)))) + (pk 'key-up key))) ;; Canvas and event loop setup (define canvas (get-element-by-id "canvas")) (define context (get-context canvas "2d")) -(set-element-width! canvas (exact game-width)) -(set-element-height! canvas (exact game-height)) +(set-element-width! canvas (inexact->exact game-width)) +(set-element-height! canvas (inexact->exact game-height)) (add-event-listener! (current-document) "keydown" (procedure->external on-key-down)) (add-event-listener! (current-document) "keyup" diff --git a/modules/goblins/abstract-types.scm b/modules/goblins/abstract-types.scm new file mode 100644 index 0000000..035f9eb --- /dev/null +++ b/modules/goblins/abstract-types.scm @@ -0,0 +1,43 @@ +;;; Copyright 2023 Jessica Tallon +;;; +;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;; you may not use this file except in compliance with the License. +;;; You may obtain a copy of the License at +;;; +;;; http://www.apache.org/licenses/LICENSE-2.0 +;;; +;;; Unless required by applicable law or agreed to in writing, software +;;; distributed under the License is distributed on an "AS IS" BASIS, +;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;; See the License for the specific language governing permissions and +;;; limitations under the License. +(define-module (goblins abstract-types) + #:export (zilch + zilch? + + + make-tagged + make-tagged* + tagged? + tagged-label + tagged-data)) + +;; This is both a 2nd and secondary "bottom" or null/void type that's used +;; within CapTP. This works alongside guile's *unspecified* bottom type. +(define (make-zilch) + (define-record-type + (_make-zilch) + zilch?) + (values (_make-zilch) zilch?)) + +(define-values (zilch zilch?) + (make-zilch)) + +(define-record-type + (make-tagged label data) + tagged? + (label tagged-label) + (data tagged-data)) + +(define (make-tagged* label . args) + (make-tagged label args)) diff --git a/modules/goblins/core-types.scm b/modules/goblins/core-types.scm new file mode 100644 index 0000000..a0fbf5b --- /dev/null +++ b/modules/goblins/core-types.scm @@ -0,0 +1,237 @@ +;;; Copyright 2019-2023 Christine Lemmer-Webber +;;; Copyright 2023 David Thompson +;;; Copyright 2022-2024 Jessica Tallon +;;; Copyright 2023 Juliana Sims +;;; +;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;; you may not use this file except in compliance with the License. +;;; You may obtain a copy of the License at +;;; +;;; http://www.apache.org/licenses/LICENSE-2.0 +;;; +;;; Unless required by applicable law or agreed to in writing, software +;;; distributed under the License is distributed on an "AS IS" BASIS, +;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;; See the License for the specific language governing permissions and +;;; limitations under the License. + + +;; This module should largely be considered private and should typically +;; not be used directly. If you need these things, most of them are +;; exported from core and if they haven't been, likely it's because you +;; don't need them. +(define-module (goblins core-types) + #:use-module (hoot hashtables) + #:use-module (ice-9 match) + #:export ( + _make-actormap + actormap? + actormap-metatype + actormap-data + actormap-vat-connector + actormap-ref + actormap-set! + + + make-actormap-metatype + actormap-metatype? + actormap-metatype-name + actormap-metatype-ref-proc + actormap-metatype-set!-proc + + + make-whactormap-data + whactormap-data? + whactormap-data-wht + + whactormap? + whactormap-ref + whactormap-set! + whactormap-metatype + + + make-transactormap-data + transactormap-data? + transactormap-data-parent + transactormap-data-delta + transactormap-data-merged? + set-transactormap-data-merged?! + transactormap-merged? + + + make-local-object-refr + local-object-refr? + local-object-refr-debug-name + local-object-refr-vat-connector + + + make-local-promise-refr + local-promise-refr? + local-promise-refr-vat-connector + + + make-remote-object-refr + remote-object-refr? + remote-object-refr-captp-connector + remote-object-refr-sealed-pos + + + make-remote-promise-refr + remote-promise-refr? + remote-promise-refr-captp-connector + remote-promise-refr-sealed-pos + + local-refr? + local-refr-vat-connector + remote-refr? + remote-refr-captp-connector + remote-refr-sealed-pos + live-refr? + promise-refr?)) + +;; hoot hacks + +(define *unspecified* (if #f #f)) + +;; Actormaps, etc +;; ============== +(define-record-type + ;; TODO: This is confusing, naming-wise? (see make-actormap alias) + (_make-actormap metatype data vat-connector) + actormap? + (metatype actormap-metatype) + (data actormap-data) + (vat-connector actormap-vat-connector)) + +(define-record-type + (make-actormap-metatype name ref-proc set!-proc) + actormap-metatype? + (name actormap-metatype-name) + (ref-proc actormap-metatype-ref-proc) + (set!-proc actormap-metatype-set!-proc)) + +(define (actormap-set! am key val) + ((actormap-metatype-set!-proc (actormap-metatype am)) + am key val) + *unspecified*) + +;; (-> actormap? local-refr? (or/c mactor? #f)) +(define (actormap-ref am key) + ((actormap-metatype-ref-proc (actormap-metatype am)) am key)) + +(define-record-type + (make-whactormap-data wht) + whactormap-data? + (wht whactormap-data-wht)) + +(define (whactormap? obj) + "Return #t if OBJ is a weak-hash actormap, else #f. + +Type: Any -> Boolean" + (and (actormap? obj) + (eq? (actormap-metatype obj) whactormap-metatype))) + +(define (whactormap-ref am key) + (define wht (whactormap-data-wht (actormap-data am))) + (weak-key-hashtable-ref wht key #f)) + +(define (whactormap-set! am key val) + (define wht (whactormap-data-wht (actormap-data am))) + (weak-key-hashtable-set! wht key val)) + +(define whactormap-metatype + (make-actormap-metatype 'whactormap whactormap-ref whactormap-set!)) + +;; Transactional actormaps +;; ======================= + +(define-record-type + (make-transactormap-data parent delta merged?) + transactormap-data? + (parent transactormap-data-parent) + (delta transactormap-data-delta) + (merged? transactormap-data-merged? set-transactormap-data-merged?!)) + +(define (transactormap-merged? transactormap) + (transactormap-data-merged? (actormap-data transactormap))) + +;; Ref(r)s +;; ======= + +(define-record-type + (make-local-object-refr debug-name vat-connector) + local-object-refr? + (debug-name local-object-refr-debug-name) + (vat-connector local-object-refr-vat-connector)) + +(define-record-type + (make-local-promise-refr vat-connector) + local-promise-refr? + (vat-connector local-promise-refr-vat-connector)) + +(define (local-refr? obj) + "Return #t if OBJ is an object or promise reference in the current +process, else #f. + +Type: Any -> Boolean" + (or (local-object-refr? obj) (local-promise-refr? obj))) + +(define (local-refr-vat-connector local-refr) + (match local-refr + [(? local-object-refr?) + (local-object-refr-vat-connector local-refr)] + [(? local-promise-refr?) + (local-promise-refr-vat-connector local-refr)])) + +;; Captp-connector should be a procedure which both sends a message +;; to the local node representative actor, but also has something +;; serialized that knows which specific remote node + session this +;; corresponds to (to look up the right captp session and forward) + +(define-record-type + (make-remote-object-refr captp-connector sealed-pos) + remote-object-refr? + (captp-connector remote-object-refr-captp-connector) + (sealed-pos remote-object-refr-sealed-pos)) + +(define-record-type + (make-remote-promise-refr captp-connector sealed-pos) + remote-promise-refr? + (captp-connector remote-promise-refr-captp-connector) + (sealed-pos remote-promise-refr-sealed-pos)) + +(define (promise-refr? maybe-promise) + "Return #t if MAYBE-PROMISE is a promise reference, else #f. + +Type: Any -> Boolean" + (or (local-promise-refr? maybe-promise) (remote-promise-refr? maybe-promise))) + +(define (remote-refr-captp-connector remote-refr) + (match remote-refr + [(? remote-object-refr?) + (remote-object-refr-captp-connector remote-refr)] + [(? remote-promise-refr?) + (remote-promise-refr-captp-connector remote-refr)])) + +(define (remote-refr-sealed-pos remote-refr) + (match remote-refr + [(? remote-object-refr?) + (remote-object-refr-sealed-pos remote-refr)] + [(? remote-promise-refr?) + (remote-promise-refr-sealed-pos remote-refr)])) + +(define (remote-refr? obj) + "Return #t if OBJ is an object or promise reference in a different +process, else #f. + +Type: Any -> Boolean" + (or (remote-object-refr? obj) + (remote-promise-refr? obj))) + +(define (live-refr? obj) + "Return #t if OBJ is a local or remote object or promise reference, +else #f. + +Type: Any -> Boolean" + (or (local-refr? obj) + (remote-refr? obj))) diff --git a/modules/goblins/core.scm b/modules/goblins/core.scm new file mode 100644 index 0000000..f13a82b --- /dev/null +++ b/modules/goblins/core.scm @@ -0,0 +1,2370 @@ +;;; Copyright 2019-2023 Christine Lemmer-Webber +;;; Copyright 2023 David Thompson +;;; Copyright 2022-2024 Jessica Tallon +;;; Copyright 2023 Juliana Sims +;;; +;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;; you may not use this file except in compliance with the License. +;;; You may obtain a copy of the License at +;;; +;;; http://www.apache.org/licenses/LICENSE-2.0 +;;; +;;; Unless required by applicable law or agreed to in writing, software +;;; distributed under the License is distributed on an "AS IS" BASIS, +;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;; See the License for the specific language governing permissions and +;;; limitations under the License. + +(define-module (goblins core) + #:export (make-actormap + make-transactormap + make-whactormap + + actormap-spawn + actormap-spawn! + + actormap-turn* + actormap-turn + + actormap-turn-message + + actormap-peek + actormap-poke! + actormap-reckless-poke! + + actormap-run + actormap-run! + actormap-run* + + actormap-churn + actormap-churn-run + actormap-churn-run! + + dispatch-message + dispatch-messages + + transactormap-reparent + transactormap-merge! + transactormap-buffer-merge! + + copy-whactormap + + near-refr? + far-refr? + + spawn spawn-named + $ <-np <- + on + on-sever + + <-np-extern + listen-to + + await await* + <<- + + spawn-promise-cons + spawn-promise-values + + ;; TODO: separate this out! + + make-message message? + message-from-vat + message-to + message-resolve-me + message-args + + + questioned? + questioned-message + questioned-answer-this-question + + + make-listen-request listen-request? + listen-request-from-vat + listen-request-to + listen-request-listener + listen-request-wants-partial? + + forward-to-captp? + forward-to-captp-msg + + message-or-request-from-vat + message-or-request-to + message-who-wants-response + + syscaller-free + + near-promise-broken? + near-promise-settled? + near-settled-promise-value + near-promise-resolved? + near-resolved-promise-value + + ;; test-core.scm needs these; they are not otherwise exported + *unspecified* + transactormap-set! + transactormap-ref + mactor:local-link?) + #:pure + #:use-module ((hoot errors) #:select (raise-exception)) + #:use-module ((hoot error-handling) #:select (format-exception)) + #:use-module (hoot exceptions) + #:use-module (hoot hashtables) + #:use-module (hoot match) + #:use-module ((hoot syntax) #:select (define*)) + #:use-module (ice-9 control) + #:use-module (ice-9 vlist) + #:use-module (ice-9 q) + #:use-module (goblins core-types) + #:use-module (goblins ghash) + #:use-module (scheme base) + #:use-module (scheme write)) + + +;;; Utilities (which should be moved to their own modules) +;;; ====================================================== + +;;; hoot hacks + + +(define *unspecified* (if #f #f)) + +;;; Here's basically your pre-goblins area. + +;; mimic Racket's seteq +(define (vseteq . items) + (alist->vhash (map (lambda (x) (cons x #t)) items) hashq)) +(define (vseteq-add vseteq item) + (vhash-consq item #t vseteq)) +(define (vseteq-member? vseteq item) + (vhash-assq item vseteq)) + +;; (TODO: Use from (goblins simple-sealers) when we break +;; into modules. For now we want to demonstrate stages as quasi-self-contained.) + +(define* (make-sealer-triplet #:optional name) + (define-record-type + (seal val) + sealed? + (val unseal)) + (values seal unseal sealed?)) + + +;;; .============================. +;;; | High level view of Goblins | +;;; '============================' +;;; +;;; There's a lot of architecture here. +;;; It's a lot to take in, so let's start out with a "high level view". +;;; Here's an image to get started: +;;; +;;; .----------------------------------. .-------------------. +;;; | Node 1 | | Node 2 | +;;; | ======= | | ======= | +;;; | | | | +;;; | .--------------. .---------. .-. .-. | +;;; | | Vat A | | Vat B | | \______| \_ .----------. | +;;; | | .---. | | .-. | .-| / | / | | Vat C | | +;;; | | (Alice)----------->(Bob)----' '-' '-' | | .---. | | +;;; | | '---' | | '-' | | | '--->(Carol) | | +;;; | | \ | '----^----' | | | '---' | | +;;; | | V | | | | | | | +;;; | | .----. | | .-. .-. | .----. | | +;;; | | (Alfred) | '-------/ |______/ |____---(Carlos) | | +;;; | | '----' | \ | \ | | '----' | | +;;; | | | '-' '-' '----------' | +;;; | '--------------' | | | +;;; | | | | +;;; '----------------------------------' '-------------------' +;;; +;;; Here we see the following: +;;; +;;; - Zooming in the farthest, we are looking at the "object layer"... +;;; Alice has a reference to Alfred and Bob, Bob has a reference to Carol, +;;; Carlos has a reference to Bob. Reference possession is directional; +;;; even though Alice has a reference to Bob, Bob does not have a +;;; reference to Alice. +;;; +;;; - One layer up is the "vat layer"... here we can see that Alice and +;;; Alfred are both objects in Vat A, Bob is an object in Vat B, and +;;; Carol and Carlos are objects in Vat C. +;;; +;;; - Zooming out the farthest is the "node/network level". +;;; There are two nodes (Node 1 and Node 2) connected over a +;;; Goblins CapTP network. The stubby shapes on the borders between the +;;; nodes represent the directions of references Node 1 has to +;;; objects in Node 2 (at the top) and references Node 2 has to +;;; Node 1. Both nodes in this diagram are cooperating to preserve +;;; that Bob has access to Carol but that Carol does not have access to +;;; Bob, and that Carlos has access to Bob but Bob does not have access +;;; to Carlos. (However there is no strict guarantee from either +;;; node's perspective that this is the case... generally it's in +;;; everyone's best interests to take a "principle of least authority" +;;; approach though so usually it is.) +;;; +;;; This illustration is what's sometimes called a "grannovetter diagram" +;;; in the ocap community, inspired by the kinds of diagrams in Mark +;;; S. Grannovetter's "The Strength of Weak Ties" paper. The connection is +;;; that while the "Weak Ties" paper was describing the kinds of social +;;; connections between people (Alice knows Bob, Bob knows Carol), similar +;;; patterns arise in ocap systems (the object Alice has a refernce to Bob, +;;; and Bob has a reference to Carol). +;;; +;;; With that in mind, we're now ready to look at things more structurally. +;;; +;;; +;;; .============================. +;;; | Goblins abstraction layers | +;;; '============================' +;;; +;;; Generally, things look like so: +;;; +;;; (node (vat (actormap {refr: (mactor object-handler)}))) +;;; +;;; However, we could really benefit from looking at those in more detail, +;;; so from the outermost layer in... +;;; +;;; .--- A node in Goblins is basically an OS process. +;;; | However, the broader Goblins CapTP/MachineTP network is +;;; | made up of many nodes. A connection to another node +;;; | is the closest amount of "assurance" a Goblins node has +;;; | that it is delivering to a specific destination. +;;; | Nonetheless, Goblins users generally operate at the object +;;; | reference level of abstraction, even across nodes. +;;; | +;;; | An object reference on the same node is considered +;;; | "local" and an object reference on another node is +;;; | considered "remote". +;;; | +;;; | .--- Christine: "How about I call this 'hive'?" +;;; | | Ocap community: "We hate that, use 'vat'" +;;; | | Everyone else: "What's a 'vat' what a weird name" +;;; | | +;;; | | A vat is a traditional ocap term, both a container for +;;; | | objects but most importantly an event loop that +;;; | | communicates with other event loops. Vats operate +;;; | | "one turn at a time"... a toplevel message is handled +;;; | | for some object which is transactional; either it happens +;;; | | or, if something bad happens in-between, no effects occur +;;; | | at all (except that a promise waiting for the result of +;;; | | this turn is broken). +;;; | | +;;; | | Objects in the same vat are "near", whereas objects in +;;; | | remote vats are "far". (As you may notice, "near" objects +;;; | | can be "near" or "far", but "remote" objects are always +;;; | | "far".) +;;; | | +;;; | | This distinction is important, because Goblins supports +;;; | | both asynchronous messages + promises via `<-` and +;;; | | classic synchronous call-and-return invocations via `$`. +;;; | | However, while any actor can call any other actor via +;;; | | <-, only near actors may use $ for synchronous call-retun +;;; | | invocations. In the general case, a turn starts by +;;; | | delivering to an actor in some vat a message passed with <-, +;;; | | but during that turn many other near actors may be called +;;; | | with $. For example, this allows for implementing transactional +;;; | | actions as transferring money from one account/purse to another +;;; | | with $ in the same vat very easily, while knowing that if +;;; | | something bad happens in this transaction, no actor state +;;; | | changes will be committed (though listeners waiting for +;;; | | the result of its transaction will be informed of its failure); +;;; | | ie, the financial system will not end up in a corrupt state. +;;; | | In this example, it is possible for users all over the network +;;; | | to hold and use purses in this vat, even though this vat is +;;; | | responsible for money transfer between those purses. +;;; | | For an example of such a financial system in E, see +;;; | | "An Ode to the Grannovetter Diagram": +;;; | | http://erights.org/elib/capability/ode/index.html +;;; | | +;;; | | .--- Earlier we said that vats are both an event loop and +;;; | | | a container for storing actor state. Surprise! The +;;; | | | vat is actually wrapping the container, which is called +;;; | | | an "actormap". While vats do not expose their actormaps, +;;; | | | Goblins has made a novel change by allowing actormaps to +;;; | | | be used as independent first-class objects. Most users +;;; | | | will rarely do this, but first-class usage of actormaps +;;; | | | is still useful if integrating Goblins with an existing +;;; | | | event loop (such as one for a video game or a GUI) or for +;;; | | | writing unit tests. +;;; | | | +;;; | | | The keys to actormaps are references (called "refrs") +;;; | | | and the values are current behavior. This is described +;;; | | | below. +;;; | | | +;;; | | | Actormaps also technically operate on "turns", which are +;;; | | | a transactional operation. Once a turn begins, a dynamic +;;; | | | "syscaller" (or "actor context") is initialized so that +;;; | | | actors can make changes within this transaction. At the +;;; | | | end of the turn, the user of actormap-turn is presented +;;; | | | with the transactional actormap (called "transactormap") +;;; | | | which can either be committed or not to the current mutable +;;; | | | actormap state ("whactormap", which stands for +;;; | | | "weak hash actormap"), alongside a queue of messages that +;;; | | | were scheduled to be run from actors in this turn using <-, +;;; | | | and the result of the computation run. +;;; | | | +;;; | | | However, few users will operate using actormap-turn directly, +;;; | | | and will instead either use actormap-poke! (which automatically +;;; | | | commits the transaction if it succeeds or propagates the error) +;;; | | | or actormap-peek (which returns the result but throws away the +;;; | | | transaction; useful for getting a sense of what's going on +;;; | | | without committing any changes to actor state). +;;; | | | Or, even more commonly, they'll just use a vat and never think +;;; | | | about actormaps at all. +;;; | | | +;;; | | | .--- A reference to an object or actor. +;;; | | | | Traditionally called a "ref" by the ocap community, but +;;; | | | | scheme already uses "-ref" everywhere so we call it +;;; | | | | "refr" instead. Whatever. +;;; | | | | +;;; | | | | Anyway, these are the real "capabilities" of Goblins' +;;; | | | | "object capability system". Holding onto one gives you +;;; | | | | authority to make invocations with <- or $, and can be +;;; | | | | passed around to procedure or actor invocations. +;;; | | | | Effectively the "moral equivalent" of a procedure +;;; | | | | reference. If you have it, you can use (and share) it; +;;; | | | | if not, you can't. +;;; | | | | +;;; | | | | Actually, technically these are local-live-refrs... +;;; | | | | see "The World of Refrs" below for the rest of them. +;;; | | | | +;;; | | | | .--- We're now at the "object behavior" side of +;;; | | | | | things. I wish I could avoid talking about +;;; | | | | | "mactors" but we're talking about the actual +;;; | | | | | implementation here so... "mactor" stands for +;;; | | | | | "meta-actor", and really there are a few +;;; | | | | | "core kinds of behavior" (mainly for promises +;;; | | | | | vs object behavior). But in the general case, +;;; | | | | | most objects from a user's perspective are the +;;; | | | | | mactor:object kind, which is just a wrapper +;;; | | | | | around the current object handler (as well as +;;; | | | | | some information to track when this object is +;;; | | | | | "becoming" another kind of object. +;;; | | | | | +;;; | | | | | .--- Finally, "object"... a term that is +;;; | | | | | | unambiguous and well-understood! Well, +;;; | | | | | | "object" in our system means "references +;;; | | | | | | mapping to an encapsulation of state". +;;; | | | | | | Refrs are the reference part, so +;;; | | | | | | object-handlers are the "current state" +;;; | | | | | | part. The time when an object transitions +;;; | | | | | | from "one" behavior to another is when it +;;; | | | | | | returns a new handler wrapped in a "become" +;;; | | | | | | wrapper specific to this object (and +;;; | | | | | | provided to the object at construction +;;; | | | | | | time) +;;; | | | | | | +;;; V V V V V V +;;; (node (vat (actormap {refr: (mactor object-handler)}))) +;;; +;;; +;;; Whew! That's a lot of info, so go take a break and then we'll go onto +;;; the next section. +;;; +;;; +;;; .====================. +;;; | The World of Refrs | +;;; '====================' +;;; +;;; There are a few kinds of references, explained below: +;;; +;;; live refrs : +;;; (runtime or captp session) : offline-storeable +;;; ========================== : ================= +;;; : +;;; local? remote? : +;;; .----------------.----------------. : +;;; object? | local-object | remote-object | : [sturdy refrs] +;;; |----------------+----------------| : +;;; promise? | local-promise | remote-promise | : [cert chains] +;;; '----------------'----------------' : +;;; +;;; On the left hand side we see live references (only valid within this +;;; process runtime or between nodes across captp sessions) and +;;; offline-storeable references (sturdy refrs, a kind of bearer URI, +;;; and certificate chains, which are like "deeds" indicating that the +;;; possessor of some cryptographic material is permitted access). +;;; +;;; All offline-storeable references must first be converted to live +;;; references before they can be used (authority to do this itself a +;;; capability, as well as authority to produce these offline-storeable +;;; objects). +;;; +;;; Live references subdivide into local (on the same node) and +;;; remote (on a foreign node). These are typed as either +;;; representing an object or a promise. +;;; +;;; (Local references also further subdivide into "near" and "far", +;;; but rather than being encoded in the reference type this is +;;; determined relative to another local-refr or the current actor +;;; context.) + + +;; Actormaps, etc +;; ============== + +;; Weak-hash actormaps +;; =================== + + +(define* (make-whactormap #:key [vat-connector #f]) + "Create and return a reference to a weak-hash actormap. If provided, +VAT-CONNECTOR is the syscaller of the containing vat. + +Type: (Optional Syscaller) -> WHActormap" + (_make-actormap whactormap-metatype + (make-whactormap-data (make-weak-key-hashtable)) + vat-connector)) + +;; TODO: again, confusing (see ) +(define make-actormap make-whactormap) + +(define (copy-whactormap am) + "Copy whactormap AM to a new whactormap with the same contents." + (define old-ht (whactormap-data-wht (actormap-data am))) + (define new-ht (make-weak-key-hashtable)) + ;; Update new-ht with all of old-ht's values + (hashtable-for-each (lambda (key val) + (weak-key-hashtable-set! new-ht key val)) + old-ht) + ;; Return newly made whactormap + (_make-actormap whactormap-metatype + (make-whactormap-data new-ht) + (actormap-vat-connector am))) + + + + +(define (transactormap-ref transactormap key) + (define tm-data (actormap-data transactormap)) + (define tm-delta + (transactormap-data-delta tm-data)) + (define tm-val (hashtable-ref tm-delta key #f)) + (when (transactormap-data-merged? tm-data) + (error "Can't use transactormap-ref on merged transactormap")) + (if tm-val + ;; we got it, it's in our delta + tm-val + ;; search parents for key + (let ([parent (transactormap-data-parent tm-data)]) + (actormap-ref parent key)))) + +(define (transactormap-set! transactormap key val) + (define tm-delta (transactormap-data-delta (actormap-data transactormap))) + (when (transactormap-merged? transactormap) + (error "Can't use transactormap-set! on merged transactormap")) + (hashtable-set! tm-delta key val) + *unspecified*) + +;; Not threadsafe, but probably doesn't matter +(define (transactormap-merge! transactormap) + "Commit the changes in TRANSACTORMAP to the generational history. + +Type: TransActormap -> Void" + ;; Serves two functions: + ;; - to extract the root weak-hasheq + ;; - to merge this transaction on top of the weak-hasheq + (define (do-merge! transactormap) + (define tm-data (actormap-data transactormap)) + (define parent (transactormap-data-parent tm-data)) + (define parent-mtype (actormap-metatype parent)) + ;; TODO: Should we actually return the root-wht instead, + ;; since that's what we're comitting to? + (define root-actormap + (cond + [(eq? parent-mtype whactormap-metatype) + parent] + [(eq? parent-mtype transactormap-metatype) + (do-merge! parent)] + [else + (error (string-append "Actormap metatype not supported for merging: " + parent-mtype))])) + ;; Optimization: we pull out the root weak hash table here and + ;; merge it + (define root-wht (whactormap-data-wht (actormap-data root-actormap))) + (unless (transactormap-data-merged? tm-data) + (hashtable-for-each + (lambda (key val) + (weak-key-hashtable-set! root-wht key val)) + (transactormap-data-delta tm-data)) + (set-transactormap-data-merged?! tm-data #t)) + + root-actormap) + (do-merge! transactormap) + *unspecified*) + +(define (transactormap-buffer-merge! transactormap) + "Merge TRANSACTORMAP against its parent buffer (also a +transactormap). + +Type: TransActormap -> Void" + (define tm-data (actormap-data transactormap)) + (define parent (transactormap-data-parent tm-data)) + (define parent-mtype (actormap-metatype parent)) + (unless (eq? parent-mtype transactormap-metatype) + (error "Can only do a buffered merge against another transactormap")) + (when (or (transactormap-data-merged? tm-data) + (transactormap-data-merged? (actormap-data parent))) + (error "Transactormap already merged!")) + (hashtable-for-each + (lambda (key val) + (transactormap-set! parent key val)) + (transactormap-data-delta tm-data)) + (set-transactormap-data-merged?! tm-data #t)) + +(define transactormap-metatype + (make-actormap-metatype 'transactormap transactormap-ref transactormap-set!)) + +(define (make-transactormap parent) + "Create a return a reference to a transactional actormap +representing the generation after PARENT. + +Type: Actormap -> TransActormap" + (define vat-connector (actormap-vat-connector parent)) + (_make-actormap transactormap-metatype + (make-transactormap-data parent (make-eq-hashtable) #f) + vat-connector)) + +(define (transactormap-reparent transactormap new-parent) + (define vat-connector (actormap-vat-connector new-parent)) + (define delta (transactormap-data-delta (actormap-data transactormap))) + (_make-actormap transactormap-metatype + (make-transactormap-data new-parent delta #f) + vat-connector)) + + +;; "Become" sealer/unsealers +;; ========================= + +(define (make-become-sealer-triplet) + (define-record-type + (make-become-seal new-behavior return-val) + become-sealed? + (new-behavior unseal-behavior) + (return-val unseal-return-val)) + (define* (become new-behavior #:optional [return-val *unspecified*]) + (make-become-seal new-behavior return-val)) + (define (unseal sealed) + (values (unseal-behavior sealed) + (unseal-return-val sealed))) + (values become unseal become-sealed?)) + + + +;; Mactors +;; ======= + +;;; .======================. +;;; | The World of Mactors | +;;; '======================' +;;; +;;; This is getting really deep into the weeds and is really only +;;; relevant to anyone hacking on this module. +;;; +;;; Mactors are only ever relevant to the internals of a vat, but they +;;; do define some common behaviors. +;;; +;;; Here are the categories and transition states: +;;; +;;; Unresolved Resolved +;;; __________________________ ___________________________ +;;; | || | +;;; +;;; .----------------->. [object] +;;; | | +;;; | .--. | .-->[local-link] +;;; [naive]-->. | v | | | +;;; +>+->[closer]------->'--->+-->[encased] +;;; [question]-->' | | | +;;; | | '-->[broken] +;;; '------>'--->[remote-link] ^ +;;; | | +;;; '----------->' +;;; +;;; |________________________________________||_____________| +;;; Eventual Settled +;;; +;;; The four major categories of mactors: +;;; +;;; - Unresolved: A promise that has never been fulfilled or broken. +;;; - Resolved: Either an object with its own handler or a promise which +;;; has been fulfilled to some value/object reference or which has broken. +;;; +;;; and: +;;; +;;; - Eventual: Something which *might* eventually transition its state. +;;; - Settled: Something which will never transition its state again. +;;; +;;; The surprising thing here is that there is any distinction between +;;; unresolved/resolved and eventual/settled at all. The key to +;;; understanding the difference is observing that a mactor:remote-link +;;; might become broken upon network disconnect from that object. +;;; +;;; One intersting observation is that if you have a local-object-refr that +;;; it is sure to correspond to a mactor:object. A local-promise-refr can +;;; correspond to any object state *except* for mactor:object (if a promise +;;; resolves to a local object, it must point to it via mactor:local-link.) +;;; (remote-refrs of course never correspond to a mactor on this node; +;;; those are managed by captp.) +;;; +;;; See also: +;;; - The comments above each of these below +;;; - "Miranda methods": +;;; http://www.erights.org/elang/blocks/miranda.html +;;; - "Reference mechanics": +;;; http://erights.org/elib/concurrency/refmech.html + +;; TODO: Maybe move this to core-types? +;; local-objects are the most common type, have a message handler +;; which specifies how to respond to the next message, as well as +;; a predicate and unsealer to identify and unpack when a message +;; handler specifies that this actor would like to "become" a new +;; version of itself (get a new handler) +(define-record-type + (make-mactor:object behavior constructor-refr spawned-constructor + self-portrait become-unsealer become?) + mactor:object? + ;; Behavior procedure + (behavior mactor:object-behavior) + ;; Reference to the constructor procedure or redefinable-object-constructor + ;; this actor was spawned from + ;; TODO: rename this, it's not a live-refr, and it kind of sounds like it is + (constructor-refr mactor:object-constructor-refr) + ;; This is the inner constructor *procedure*, which is unboxed from a + ;; redefinable-object-constructor, so we can compare if the constructor + ;; changed when doing an `actormap-replace-behavior' + (spawned-constructor mactor:object-spawned-constructor) + ;; The object's self-portrait procedure, if it exists + (self-portrait mactor:object-self-portrait) + ;; The following two are the predicate and unsealer from a + ;; `make-become-sealer-triplet', specific to this actor + (become-unsealer mactor:object-become-unsealer) + (become? mactor:object-become?)) + +;; The other kinds of mactors correspond to promises and their resolutions. + +;; There are two supertypes here which are not used directly: +;; mactor:unresolved and mactor:eventual. See above for an explaination +;; of what these mean. +;; These are never directly exposed as mactors, hence the ~ +(define-record-type + (make-m~eventual resolver-unsealer resolver-tm?) + m~eventual? + ;; We can still be resolved, so identify who is allowed to do that + ;; and provide a mechanism for unsealing the resolution + (resolver-unsealer m~eventual-resolver-unsealer) + (resolver-tm? m~eventual-resolver-tm?)) +(define-record-type + (make-m~unresolved eventual listeners) + m~unresolved? + ;; the info + (eventual m~unresolved-eventual) + ;; Who's listening for a resolution? + (listeners m~unresolved-listeners)) + +;; The most common kind of freshly made promise is a naive one. +;; It knows no interesting information about how what it will eventually +;; become. +;; Since it knows of no closer information it keeps a queue of waiting +;; messages which will eventually be transmitted. +(define-record-type + (make-mactor:naive unresolved waiting-messages) + mactor:naive? + (unresolved mactor:naive-unresolved) + ;; All of these get "rewritten" as this promise is either resolved + ;; or moved closer to resolution. + (waiting-messages mactor:naive-waiting-messages)) + +;; A special kind of "freshly made" promise which also corresponds to being +;; a question on the remote end. Keeps track of the captp-connector +;; relevant to this connection so it can send it messages and the +;; question-finder that it corresponds to (used for passing along messages). +(define-record-type + (make-mactor:question unresolved captp-connector question-finder) + mactor:question? + (unresolved mactor:question-unresolved) + (captp-connector mactor:question-captp-connector) + (question-finder mactor:question-question-finder)) + +;; "You make me closer to God" -- Nine Inch Nails +;; Well, in this case we're actually just "closer to resolution"... +;; pointing at some other promise that isn't us. +;; +;; NOTE: Any attempt to remove this in favor of "deferring an answer +;; until fulfillment is possible" should think through whether it will +;; also prevent cycles. A great deal of work went into that here. +(define-record-type + (make-mactor:closer unresolved point-to history waiting-messages) + mactor:closer? + (unresolved mactor:closer-unresolved) + ;; Who do we currently point to? + (point-to mactor:closer-point-to) + ;; A set of promises we used to point to before they themselves + ;; resolved... used to detect cycles + (history mactor:closer-history) + ;; Any messages that are waiting to be passed along... + ;; Currently only if we're pointing to a remote-promise, otherwise + ;; this will be an empty list. + (waiting-messages mactor:closer-waiting-messages)) + +;; Point at a remote object. +;; It's eventual because, well, it could still break on network partition. +(define-record-type + (make-mactor:remote-link eventual point-to) + mactor:remote-link? + (eventual mactor:remote-link-eventual) + (point-to mactor:remote-link-point-to)) + +;; Link to an object on the same node. +(define-record-type + (make-mactor:local-link point-to) + mactor:local-link? + (point-to mactor:local-link-point-to)) + +;; A promise that has resolved to some value +(define-record-type + (make-mactor:encased val) + mactor:encased? + (val mactor:encased-val)) + +;; Breakage (and remember why!) +(define-record-type + (make-mactor:broken problem) + mactor:broken? + (problem mactor:broken-problem)) + +;; Rather than directly storing references to listeners, we use these +;; structs because, at least at the time, we have this +;; notion of being interested in "partial" updates (rather than waiting +;; until full promise resolution) +;; +;; While this is a curious feature, we never fully documented why we +;; made the decision to enable this. It would be interesting to document +;; it, and we probably will indeed need to for ocapn interoperability. +(define-record-type + (make-listener-info resolve-me wants-partial?) + listener-info? + (resolve-me listener-info-resolve-me) + (wants-partial? listener-info-wants-partial?)) + +(define (mactor:eventual? obj) + (or (mactor:remote-link? obj) + (mactor:unresolved? obj))) +(define (mactor:unresolved? obj) + (or (mactor:naive? obj) + (mactor:question? obj) + (mactor:closer? obj))) + +(define (mactor-get-m~unresolved obj) + (match obj + [(? mactor:naive?) (mactor:naive-unresolved obj)] + [(? mactor:question?) (mactor:question-unresolved obj)] + [(? mactor:closer?) (mactor:closer-unresolved obj)])) + +(define (mactor-get-m~eventual obj) + (match obj + [(? mactor:unresolved? obj) + (m~unresolved-eventual (mactor-get-m~unresolved obj))] + [(? mactor:remote-link? obj) + (mactor:remote-link-eventual obj)])) + +(define (mactor:unresolved-listeners mactor) + (define unresolved (mactor-get-m~unresolved mactor)) + (m~unresolved-listeners unresolved)) + +(define (mactor:unresolved-add-listener mactor new-listener wants-partial?) + (define new-listener-info + (make-listener-info new-listener wants-partial?)) + (define old-unresolved (mactor-get-m~unresolved mactor)) + (define new-unresolved + (make-m~unresolved (m~unresolved-eventual old-unresolved) + (cons new-listener-info + (m~unresolved-listeners old-unresolved)))) + (match mactor + [(? mactor:naive?) + (make-mactor:naive new-unresolved + (mactor:naive-waiting-messages mactor))] + [(? mactor:question?) + (make-mactor:question new-unresolved + (mactor:question-captp-connector mactor) + (mactor:question-question-finder mactor))] + [(? mactor:closer?) + (make-mactor:closer new-unresolved + (mactor:closer-point-to mactor) + (mactor:closer-history mactor) + (mactor:closer-waiting-messages mactor))])) + +;; Helper for syscaller's fulfill-promise and break-promise methods +(define (unseal-mactor-resolution mactor sealed-resolution) + (define eventual (mactor-get-m~eventual mactor)) + (define resolver-tm? + (m~eventual-resolver-tm? eventual)) + (define resolver-unsealer + (m~eventual-resolver-unsealer eventual)) + ;; Is this a valid resolution? + (unless (resolver-tm? sealed-resolution) + (error "Resolution sealed with wrong trademark!")) + (resolver-unsealer sealed-resolution)) + +(define (near-refr? obj) + "Return #t if OBJ is an object or promise reference within the same +vat, else #f. + +Type: Any -> Boolean" + (and (local-refr? obj) + (let ((sys (get-syscaller-or-die))) + (sys 'near-refr? obj)))) +(define (far-refr? obj) + "Return #t if OBJ is an object or promise reference within a +different vat, else #f. + +Type: Any -> Boolean" + (and (live-refr? obj) + (not (near-refr? obj)))) + +(define (near-promise-broken? promise-refr) + (mactor:broken? (near-mactor promise-refr))) + +(define* (near-promise-settled? promise-refr #:key [broken-ok? #t]) + (match (near-mactor promise-refr) + [(or (? mactor:local-link?) (? mactor:encased?)) + #t] + [(? mactor:broken?) + broken-ok?] + [_ #f])) + +(define (near-settled-promise-value promise-refr) + (define mactor (near-mactor promise-refr)) + (match mactor + [(? mactor:local-link?) + (mactor:local-link-point-to mactor)] + [(? mactor:encased?) + (mactor:encased-val mactor)] + [(? mactor:broken?) + (raise-exception (mactor:broken-problem mactor))])) + +(define* (near-promise-resolved? promise-refr #:key [broken-ok? #t]) + (match (near-mactor promise-refr) + [(or (? mactor:local-link?) (? mactor:encased?)) + #t] + [(? mactor:broken?) + broken-ok?] + [_ #f])) + +(define (near-resolved-promise-value promise-refr) + (define mactor (near-mactor promise-refr)) + (match mactor + [(? mactor:local-link?) + (mactor:local-link-point-to mactor)] + [(? mactor:remote-link?) + (mactor:remote-link-point-to mactor)] + [(? mactor:encased?) + (mactor:encased-val mactor)] + [(? mactor:broken?) + (raise-exception (mactor:broken-problem mactor))])) + +;; Dangerous and dynamic... not intended to be exposed outside of here +;; at this time, anyway. +;; Used to implement some promise-introspection methods... +(define (near-mactor refr) + ((current-syscaller) 'near-mactor refr)) + + + +;; Messages +;; -------- + +;; These are the main things that get sent as the toplevel of a turn in a vat! +(define-record-type + (make-message from-vat to resolve-me args) + message? + ;; which vat connector the message came from + (from-vat message-from-vat) + ;; who's receiving the message (the invoked actor) + (to message-to) + ;; who's interested in the result (a resolver) + (resolve-me message-resolve-me) + ;; arguments to the invoked actor + (args message-args)) + +;; When speaking to the captp connector, sometimes we're really asking +;; a question. +(define-record-type + (make-questioned message answer-this-question) + questioned? + (message questioned-message) + ;; This one's a question-finder... supplied by the captp connector! + (answer-this-question questioned-answer-this-question)) + +;; Sent in the same way as , but does listen requests specifically +(define-record-type + (make-listen-request from-vat to listener wants-partial?) + listen-request? + (from-vat listen-request-from-vat) + (to listen-request-to) + (listener listen-request-listener) + (wants-partial? listen-request-wants-partial?)) + +;; This kluge is for when we need to forward a message to captp... but +;; typically also it might have a question-finder for the `to' field... +;; so we put in this hack to let the code handling the turn/churn know +;; how to dispatch these since the message might not be addressed to +;; a normal refr. This is kind of weird though, because you don't need +;; this if we have a remote-refr that already has a captp-connector. +;; It could be that instead we should make another kind of remote-refr +;; specifically for questions which have not been assigned slots... yet. +(define-record-type + (make-forward-to-captp msg connector) + forward-to-captp? + (msg forward-to-captp-msg) + (connector forward-to-captp-connector)) + +(define (message-or-request-from-vat val) + (match val + [(? forward-to-captp? forward-me) + (message-or-request-from-vat (forward-to-captp-msg forward-me))] + [(? message? msg) (message-from-vat msg)] + [(? listen-request? lr) (listen-request-from-vat lr)] + [(? questioned? qstn) (message-from-vat (questioned-message qstn))])) + +(define (message-or-request-to val) + (match val + [(? forward-to-captp? forward-me) + (message-or-request-to (forward-to-captp-msg forward-me))] + [(? message? msg) (message-to msg)] + [(? listen-request? lr) (listen-request-to lr)] + [(? questioned? qstn) (message-to (questioned-message qstn))])) + +(define (message-who-wants-response val) + (match val + [(? message? msg) + (message-resolve-me msg)] + [(? listen-request? lr) + (listen-request-listener lr)] + [(? questioned? qm) + (message-who-wants-response (questioned-message qm))])) + + +;; Syscaller +;; ========= + +;; Do NOT export this esp under serious ocap confinement +(define current-syscaller (make-parameter #f)) + +(define (fresh-syscaller actormap) + (define vat-connector + (actormap-vat-connector actormap)) + (define new-msgs '()) + + (define (queue-new-msg! new-msg) + (set! new-msgs (cons new-msg new-msgs))) + + (define closed? #f) + + (define (this-syscaller method-id . args) + (define method + (case method-id + [($) _$] + [(spawn) _spawn] + [(<-) _<-] + [(<-np) _<-np] + [(spawn-mactor) spawn-mactor] + [(send-message) _send-message] + ;; TODO: + [(fulfill-promise) fulfill-promise] + [(break-promise) break-promise] + [(handle-message) _handle-message] + [(handle-listen) _handle-listen] + [(send-listen) _send-listen] + [(on) _on] + [(vat-connector) get-vat-connector] + [(near-refr?) near-refr?] + [(near-mactor) near-mactor] + [else (error 'invalid-syscaller-method + method-id)])) + (when closed? + (error "Syscaller closed business while processing:" + method-id args)) + (apply method args)) + + ;; TODO + (define (near-refr? obj) + (and (local-refr? obj) + (eq? (local-refr-vat-connector obj) + vat-connector))) + + (define (near-mactor refr) + (actormap-ref actormap refr)) + + (define (get-vat-connector) + vat-connector) + + (define (actormap-ref-or-die to-refr) + (define mactor + (actormap-ref actormap to-refr)) + (unless mactor + (error 'no-such-actor "no actor with this id in this vat:" to-refr)) + mactor) + + ;; call actor's behavior + (define (_$ to-refr args) + ;; Restrict to live-refrs which appear to have the same + ;; vat-connector as us + (unless (local-refr? to-refr) + (error 'not-callable + "Not a live reference:" to-refr)) + + (unless (eq? (local-refr-vat-connector to-refr) + vat-connector) + (error 'not-callable + "Not in the same vat:" to-refr)) + + (define mactor + (actormap-ref-or-die to-refr)) + + (match mactor + [(? mactor:object?) + (let ((actor-behavior + (mactor:object-behavior mactor)) + (become? + (mactor:object-become? mactor)) + (become-unsealer + (mactor:object-become-unsealer mactor))) + (define (_do-actor-call) + (apply actor-behavior args)) + (define (_handle-await k fulfill-proc promise?) + (define-values (waiting-promise waiting-resolver) + (_spawn-promise-values)) + ;; Let the fulfill-proc set up how we resolve this + ;; (see the `await' procedure for an example) + (fulfill-proc waiting-resolver) + ;; We wait on the coroutine to see if it succeds or not, + ;; and re-awaken to the continuation set up by `await*' + ;; which will act appropriately depending on whether + ;; we tell it this succeeds or fails. + ;; Note that the `bcom' relevant to this actor will no longer + ;; work as a form of "become"... a feature, actually! + ;; + ;; However, it could be that this is really + ;; the right thing to do because promise chains for an + ;; infinite loop could themselves become infinite. So + ;; maybe this is a feature. + (define maybe-on-vow + (on waiting-promise + (lambda (val) + (call-with-prompt *actor-await-prompt* + (lambda () + (k 'resume val)) + _handle-await)) + #:catch + (lambda (err) + (call-with-prompt *actor-await-prompt* + (lambda () + (k 'error err)) + _handle-await)) + #:promise? promise?)) + ;; Since we do not allow for "returning useful values" in + ;; case of coroutines, we default to returning the symbol `*awaited*'. + ;; However, users can specifically select for a promise to be returned + ;; by passing in #:promise? #t. + (if promise? + maybe-on-vow + '*awaited*)) + + ;; I guess watching for this guarantees that an immediate call + ;; against a local actor will not be tail recursive. + ;; TODO: We need to document that. + (define-values (new-behavior return-val self-portrait) + (let ([returned + (call-with-prompt *actor-await-prompt* + _do-actor-call _handle-await)]) + (if (become? returned) + ;; The unsealer unseals both the behavior and return-value anyway + (let-values ([(new-beh return-val) (become-unsealer returned)]) + (values new-beh return-val (mactor:object-self-portrait mactor))) + + ;; In this case, we're not becoming anything, so just give us + ;; the return-val + (values #f returned (mactor:object-self-portrait mactor))))) + + ;; if a new behavior for this actor was specified, + ;; let's replace it + (when new-behavior + (unless (procedure? new-behavior) + (error 'become-failure "Tried to become a non-procedure behavior:" + new-behavior)) + (actormap-set! actormap to-refr + (make-mactor:object + new-behavior + (mactor:object-constructor-refr mactor) + (mactor:object-spawned-constructor mactor) + self-portrait + (mactor:object-become-unsealer mactor) + (mactor:object-become? mactor)))) + + return-val)] + ;; If it's an encased value, "calling" it just returns the + ;; internal value. + [(? mactor:encased?) + (mactor:encased-val mactor)] + ;; Ah... we're linking to another actor locally, so let's + ;; just de-symlink and call that instead. + [(? mactor:local-link?) + (_$ (mactor:local-link-point-to mactor) + args)] + ;; Not a callable mactor! + [_other + (error 'not-callable + "Not callable with $ or from toplevel <-:" + 'to-refr: to-refr 'args: args + 'mactor: mactor)])) + + ;; spawn a new actor + (define (_spawn maybe-constructor args debug-name) + (define-values (become become-unsealer become-sealed?) + (make-become-sealer-triplet)) + (define-values (constructor constructor-refr) + (values maybe-constructor + maybe-constructor)) + (define initial-behavior + (apply constructor become args)) + (define* (create-refr beh #:optional maybe-self-portrait) + (match beh + ;; New procedure, so let's set it + [(? procedure?) + (let ((actor-refr + (make-local-object-refr debug-name vat-connector))) + (actormap-set! actormap actor-refr + (make-mactor:object beh + constructor-refr + constructor + maybe-self-portrait + become-unsealer become-sealed?)) + actor-refr)] + ;; If someone returns another actor, just let that be the actor + [(? live-refr? pre-existing-refr) + pre-existing-refr] + [_ + (error 'invalid-actor-handler "Not a procedure or live refr:" initial-behavior)])) + (create-refr initial-behavior)) + + (define (spawn-mactor mactor debug-name) + (actormap-spawn-mactor! actormap mactor debug-name)) + + (define (fulfill-promise promise-id sealed-val) + (call/ec + (lambda (return-early) + (define orig-mactor + (actormap-ref-or-die promise-id)) + (unless (mactor:unresolved? orig-mactor) + (error 'resolving-resolved + "Attempt to resolve resolved actor:" promise-id)) + (define resolve-to-val + (unseal-mactor-resolution orig-mactor sealed-val)) + + (define orig-waiting-messages + (match orig-mactor + [(? mactor:naive?) + (mactor:naive-waiting-messages orig-mactor)] + [(? mactor:closer?) + (mactor:closer-waiting-messages orig-mactor)] + [_ '()])) + + (define (forward-messages) + (let send-rest ([waiting-messages orig-waiting-messages]) + (match waiting-messages + ['() *unspecified*] + ;; TODO: add support for here, right?!?! + [((? message? msg) . rest-waiting) + (let ((resolve-me (message-resolve-me msg)) + (args (message-args msg))) + ;; preserve FIFO by recursing first + (send-rest rest-waiting) + ;; and then send this message along + (_send-message resolve-to-val resolve-me args))]))) + + (define new-waiting-messages + (if (remote-promise-refr? resolve-to-val) + ;; don't forward waiting messages to remote promises + orig-waiting-messages + ;; but do forward to literally anything else... empty + ;; the queue! + (begin (forward-messages) + '()))) + + (define orig-listeners + (mactor:unresolved-listeners orig-mactor)) + + (define next-mactor-state + (match resolve-to-val + [(? local-object-refr?) + (when (eq? resolve-to-val promise-id) + (return-early + ;; We want to break this because it should be explicitly clear + ;; to everyone that the promise was broken. + (break-promise promise-id + ;; TODO: we need some sort of error type we do + ;; allow to explicitly be shared, this one is a + ;; reasonable candidate + 'cycle-in-promise-resolution))) + (make-mactor:local-link resolve-to-val)] + [(? remote-object-refr?) + ;; Since the captp connection is the one that might break this, + ;; we need to ask it what it uses as its resolver unsealer/tm + ;; @@: ... This doesn't seem like a good solution. + ;; Maybe bears re-examination with the addition of on-sever. + (let* ([connector (remote-refr-captp-connector resolve-to-val)] + [partition-unsealer-tm-cons (connector 'partition-unsealer-tm-cons)]) + ;; TODO: Do we need to notify it that we want to know about + ;; breakage? Presumably... so do it here instead...? + ;; TODO: Do we really need to pattern match against a cons here? + ;; Couldn't we return multiple values? + (match partition-unsealer-tm-cons + [(new-resolver-unsealer . new-resolver-tm?) + (make-mactor:remote-link (make-m~eventual new-resolver-unsealer + new-resolver-tm?) + resolve-to-val)]))] + [(or (? local-promise-refr?) + (? remote-promise-refr?)) + (define new-history + (if (mactor:closer? orig-mactor) + (vseteq-add (mactor:closer-history orig-mactor) + (mactor:closer-point-to orig-mactor)) + (vseteq promise-id))) + ;; Detect cycles! + (when (vseteq-member? new-history resolve-to-val) + ;; not sure we actually need to return anything, but I guess + ;; this is mildly future-proof. + (return-early + ;; We want to break this because it should be explicitly clear + ;; to everyone that the promise was broken. + (break-promise promise-id + ;; TODO: we need some sort of error type we do + ;; allow to explicitly be shared, this one is a + ;; reasonable candidate + 'cycle-in-promise-resolution))) + + ;; Make a new set of resolver sealers for this. + ;; However, we don't use the general ^resolver because we're + ;; explicitly using the fulfilled-handler/broken-handler things + (let*-values ([(new-resolver-sealer new-resolver-unsealer new-resolver-tm?) + (make-sealer-triplet 'fulfill-promise)] + [(new-resolver) + (_spawn ^resolver (list promise-id new-resolver-sealer) + '^resolver)]) + ;; Now subscribe to the promise... + (_send-listen resolve-to-val new-resolver #t) + (let* ([new-listeners + ;; inform those who want partial resolution and gather those who don't + (let lp ([listeners orig-listeners] + [new-listeners '()]) + (match listeners + ['() new-listeners] + [(listener-info . rest-listeners) + (if (listener-info-wants-partial? listener-info) + ;; resolve and drop out of listeners + (begin + ;; resolve + (_<-np (listener-info-resolve-me listener-info) + (list 'fulfill resolve-to-val)) + ;; recurse and drop out + (lp rest-listeners new-listeners)) + ;; recurse with this one present + (lp rest-listeners + (cons listener-info new-listeners)))]))] + [new-eventual (make-m~eventual new-resolver-unsealer + new-resolver-tm?)] + [new-unresolved (make-m~unresolved new-eventual + new-listeners)]) + ;; Now we become "closer" to this promise + (make-mactor:closer new-unresolved + resolve-to-val new-history + new-waiting-messages)))] + ;; anything else is an encased value + [_ (make-mactor:encased resolve-to-val)])) + + ;; - Now actually switch to the new mactor state + (actormap-set! actormap promise-id + next-mactor-state) + + ;; Resolve listeners, if appropriate (ie, if not mactor:closer) + (unless (mactor:unresolved? next-mactor-state) + (for-each (lambda (listener-info) + (_<-np (listener-info-resolve-me listener-info) + (list 'fulfill resolve-to-val))) + orig-listeners))))) + + ;; TODO: Add support for broken-because-of-network-partition support + ;; even for mactor:remote-link + (define (break-promise promise-id sealed-problem) + (match (actormap-ref actormap promise-id) + ;; TODO: Not just local-promise, anything that can + ;; break + [(? mactor:unresolved? unresolved-mactor) + (define problem + (unseal-mactor-resolution unresolved-mactor sealed-problem)) + (define unresolved-listeners + (mactor:unresolved-listeners unresolved-mactor)) + (define waiting-messages + (match unresolved-mactor + [(? mactor:naive?) + (mactor:naive-waiting-messages unresolved-mactor)] + [(? mactor:closer?) + (mactor:closer-waiting-messages unresolved-mactor)] + [_ '()])) + ;; Combine together the unresolved-listeners with the resolvers + ;; of waiting-messages. + (define all-interested-listeners + (append (map message-resolve-me waiting-messages) + (map listener-info-resolve-me unresolved-listeners))) + ;; Inform all listeners of the resolution + (for-each (lambda (listener) + (_<-np listener (list 'break problem))) + all-interested-listeners) + ;; Now we "become" broken with that problem + (actormap-set! actormap promise-id + (make-mactor:broken problem))] + [(? mactor:remote-link?) + (error "TODO: Implement breaking on captp disconnect!")] + [#f (error "no actor with this id")] + [_ (error "can only resolve eventual references")])) + + ;; Note that _handle-message is really, seriously for handling *toplevel* + ;; messages... ie, turns. + ;; This is the bulk of what's called and handled by actormap-turn-message. + ;; (As opposed to actormap-turn*, which only supports calling, this also + ;; handles any toplevel invocation of an actor, probably via message send.) + (define (_handle-message msg) + (define to-refr (message-to msg)) + (define resolve-me (message-resolve-me msg)) + (define args (message-args msg)) + + (unless (near-refr? to-refr) + (error 'not-a-near-refr "Not a near refr:" to-refr)) + + ;; Prevent someone trying to throw this vat into an infinite loop + (when (eq? to-refr resolve-me) + (error 'same-recipient-and-resolver + "Recipient and resolver are the same:" to-refr)) + + (let ([call-with-resolution + (lambda (proc) + (define (do-call) + (define call-result + (proc)) + (when resolve-me + (_<-np resolve-me (list 'fulfill call-result))) + call-result) + (do-call))] + [orig-mactor (actormap-ref-or-die to-refr)]) + (match orig-mactor + ;; If it's callable, we just use the call behavior, because + ;; that's effectively the same code we'd be running anyway. + ;; However, we do want to handle the resolution. + [(or (? mactor:object?) + (? mactor:encased?)) + (call-with-resolution + (lambda () (_$ to-refr args)))] + [(? mactor:local-link?) + (let ((point-to (mactor:local-link-point-to orig-mactor))) + (cond + [(near-refr? point-to) + (call-with-resolution + (lambda () (_$ point-to args)))] + ;; it's not near so we need to pass this along + [else + (_send-message point-to resolve-me args) + *unspecified*]))] + [(? mactor:broken?) + (_<-np resolve-me (list 'break (mactor:broken-problem orig-mactor))) + *unspecified*] + [(? mactor:remote-link?) + (let ([point-to (mactor:remote-link-point-to orig-mactor)]) + (call-with-resolution + (lambda () + ;; Pass along the message. + ;; Only produce a promise if we have a resolver. + ((if resolve-me _<- _<-np) point-to args))))] + ;; Messages sent to a promise that is "closer" are a kind of + ;; intermediate state; we build a queue. + [(? mactor:closer?) + (match (mactor:closer-point-to orig-mactor) + ;; If we're pointing at another near promise then we recurse + ;; to _handle-messages with the next promise... + [(? local-promise-refr? point-to) + ;; Now we need to see if it's in the same vat... + (cond + [(near-refr? point-to) + ;; (We don't use call-with-resolution because the next one will!) + (_handle-message (make-message vat-connector point-to resolve-me args))] + [else + ;; Otherwise, we need to forward this message to the appropriate + ;; vat + (_send-message point-to resolve-me args) + *unspecified*])] + ;; But if it's a remote promise then we queue it in the waiting + ;; messages because we prefer to have messages "swim as close + ;; as possible to the CapTP barrier where possible", with + ;; the exception of questions/answers which always cross over + ;; (see mactor:question handling later in this procedure) + [(? remote-promise-refr? point-to) + (let ((unresolved (mactor:closer-unresolved orig-mactor)) + (point-to (mactor:closer-point-to orig-mactor)) + (history (mactor:closer-history orig-mactor)) + (waiting-messages (mactor:closer-waiting-messages orig-mactor))) + ;; Since we're queueing to send the message until it resolves + ;; we don't resolve the problem here... hence we don't + ;; use call-with-resolution here either. + (actormap-set! actormap to-refr + (make-mactor:closer + unresolved point-to history + (cons msg waiting-messages)))) + *unspecified*])] + ;; Similar to the above w/ remote promises, except that we really + ;; just don't know where things go *at all* yet, so no swimming + ;; occurs. + [(? mactor:naive?) + (let ((unresolved (mactor-get-m~unresolved orig-mactor)) + (waiting-messages (mactor:naive-waiting-messages orig-mactor))) + (actormap-set! actormap to-refr + (make-mactor:naive unresolved + (cons msg waiting-messages))) + *unspecified*)] + ;; Questions should forward their messages to the captp thread + ;; to deal with using the relevant question-finder. + [(? mactor:question?) + (call-with-resolution + (lambda () + (define to-question-finder + (mactor:question-question-finder orig-mactor)) + (define captp-connector + (mactor:question-captp-connector orig-mactor)) + (cond + ;; If we're being asked to resolve something, this is a + ;; "followup question" + [resolve-me + (let*-values ([(followup-question-finder) + (captp-connector 'new-question-finder)] + [(followup-question-promise followup-question-resolver) + (_spawn-promise-values #:question-finder + followup-question-finder + #:captp-connector + captp-connector)]) + (queue-new-msg! (make-forward-to-captp + (make-questioned (make-message vat-connector + to-question-finder + followup-question-resolver + args) + followup-question-finder) + captp-connector)) + followup-question-promise)] + ;; Otherwise, we can just send it without any question and return + ;; void + [else + (queue-new-msg! (make-forward-to-captp + (make-message vat-connector to-question-finder #f args) + captp-connector)) + *unspecified*])))]))) + + ;; helper to the below two methods + (define* (_send-message to-refr resolve-me args + #:key [answer-this-question #f]) + (unless (live-refr? to-refr) + (error 'send-message + "Don't know how to send a message to:" to-refr)) + (let* ((base-message (make-message vat-connector to-refr resolve-me args)) + (new-message + (if answer-this-question + (make-questioned base-message answer-this-question) + base-message))) + (queue-new-msg! new-message))) + + (define (_<-np to-refr args) + (_send-message to-refr #f args) + *unspecified*) + + ;; Well, this does do a bit more heavy lifting than *just* call + ;; _send-message. + ;; + ;; It also constructs a promise (including, possibly, a question promise) + (define (_<- to-refr args) + (match to-refr + [(? local-refr?) + (let-values ([(promise resolver) + (_spawn-promise-values)]) + (_send-message to-refr resolver args) + promise)] + [(? remote-refr?) + (let*-values (((captp-connector) + (remote-refr-captp-connector to-refr)) + ((question-finder) + (captp-connector 'new-question-finder)) + ((promise resolver) + (_spawn-promise-values #:question-finder + question-finder + #:captp-connector + captp-connector))) + (_send-message to-refr resolver args + #:answer-this-question question-finder) + promise)] + [to-refr + (error 'send-message + "Don't know how to send a message to:" to-refr)])) + + (define* (_send-listen to-refr listener #:optional [wants-partial? #f]) + (match to-refr + [(? live-refr?) + (let ([listen-req + (make-listen-request vat-connector to-refr listener wants-partial?)]) + (set! new-msgs (cons listen-req new-msgs)))] + [val (<-np listener 'fulfill val)])) + + (define (_handle-listen to-refr listener wants-partial?) + (define (do-call) + (unless (near-refr? to-refr) + (error 'not-a-near-refr "Not a near refr:" to-refr)) + (define mactor + (actormap-ref-or-die to-refr)) + (match mactor + [(? mactor:local-link?) + (let ((point-to + (mactor:local-link-point-to mactor))) + (if (near-refr? point-to) + (_handle-listen (mactor:local-link-point-to mactor) + listener wants-partial?) + (_send-listen point-to listener wants-partial?)))] + ;; This object is a local promise, so we should handle it. + [(? mactor:unresolved?) + ;; Set a new version of the local-promise with this + ;; object as a listener + (actormap-set! actormap to-refr + (mactor:unresolved-add-listener mactor listener + wants-partial?))] + ;; In the following cases we can resolve the listener immediately... + [(? mactor:broken? mactor) + (_<-np listener (list 'break (mactor:broken-problem mactor)))] + [(? mactor:encased? mactor) + (_<-np listener (list 'fulfill (mactor:encased-val mactor)))] + [(? mactor:object? mactor) + (_<-np listener (list 'fulfill to-refr))] + ;; For remote links, we resolve directly to that reference + [(? mactor:remote-link? mactor) + (_<-np listener (list 'fulfill (mactor:remote-link-point-to mactor)))]) + *unspecified*) + (do-call)) + + ;; At THIS stage, fulfilled-handler, broken-handler, finally-handler should + ;; be actors or #f. That's not the case in the user-facing + ;; `on' procedure. + (define* (_on on-refr fulfilled-handler broken-handler finally-handler promise?) + (define-values (return-promise return-p-resolver) + (if promise? + (spawn-promise-values) + (values #f #f))) + + ;; These two procedures are called once the fulfillment + ;; or break of the on-refr has actually occurred. + (define (handle-resolution on-resolution + resolve-fulfill-command) + (lambda (val) + (cond [on-resolution + ;; We can't use _send-message directly, because this may + ;; be in a separate syscaller at the time it's resolved. + (let ((syscaller (get-syscaller-or-die))) + ;; But anyway, we want to resolve the return-p-resolver with + ;; whatever the on-resolution is, which is why we do this goofier + ;; roundabout + (syscaller 'send-message + on-resolution + ;; Which may be #f! + return-p-resolver + (list val)) + (when finally-handler + (<-np finally-handler)))] + ;; There's no on-resolution, which means we can just fulfill + ;; the promise immediately! + [else + (when finally-handler + (<-np finally-handler)) + (when return-p-resolver + (<-np return-p-resolver resolve-fulfill-command val))]))) + + (define handle-fulfilled + (handle-resolution fulfilled-handler 'fulfill)) + (define handle-broken + (handle-resolution broken-handler 'break)) + + ;; The purpose of this listener is that the promise + ;; *hasn't resolved yet*. Because of that we need to + ;; queue something to happen *once* it resolves. + (define (^on-listener bcom) + (lambda args + (match args + [('fulfill val) + (handle-fulfilled val) + *unspecified*] + [('break problem) + (handle-broken problem) + *unspecified*]))) + (define listener + (_spawn ^on-listener '() '^on-listener)) + (_send-listen on-refr listener) + (when promise? + return-promise)) + + ;; TODO: We only really seem to need/use new-msgs now, so simplify + ;; to just hand that back. + (define (get-internals) + (list actormap new-msgs)) + + (define (set-closed! val) + (set! closed? val)) + + (values this-syscaller get-internals set-closed!)) + +(define (call-with-fresh-syscaller am proc) + (define-values (sys get-sys-internals set-closed!) + (fresh-syscaller am)) + ;; The purpose of closing things is to detect certain kinds of errors + ;; where the syscaller is captured and remains open post-execution. + ;; However, it's kind of probabalistic to do this at all, since the + ;; open/closed nature is temporal... still, this has helped identify + ;; some bugs so it's probably worth keeping. + ;; However, we now not only close on leaving the dynamic wind, we also + ;; open on entering. The reason is that suspending to the event loop + ;; in fibers will close it, even before a turn is over (due to completion + ;; or due to an exception). So we need to re-open on the way back in. + (dynamic-wind + (lambda () + (set-closed! #f)) + (lambda () + (parameterize ([current-syscaller sys]) + (proc sys get-sys-internals))) + (lambda () + (set-closed! #t)))) + +(define (get-syscaller-or-die) + (define sys (current-syscaller)) + (unless sys + (error "No current syscaller")) + sys) + + + +;; Core API (spawn, $, <-, <-np, on) +;; ================================= + +;; System calls +(define (spawn constructor . args) + "Construct and return a reference to the actor described by +CONSTRUCTOR, passing it ARGS. + +Type: Constructor Any ... -> Actor" + (define sys (get-syscaller-or-die)) + (sys 'spawn constructor args (actor-name constructor))) + +(define (spawn-named name constructor . args) + "Construct and return a reference to an actor with the debug name +NAME described by CONSTRUCTOR, passing it ARGS. + +Type: Symbol Constructor Any ... -> Actor" + (define sys (get-syscaller-or-die)) + (sys 'spawn constructor args name)) + +(define ($ refr . args) + "Synchronously invoke REFR with ARGS; return the result. + +Type: Actor Any ... -> Any" + (define sys (get-syscaller-or-die)) + (sys '$ refr args)) + +(define (<- refr . args) + "Asynchronously invoke REFR with ARGS; return a promise. + +Type: Actor Any ... -> Promise" + (define sys (get-syscaller-or-die)) + (sys '<- refr args)) + +(define (<-np refr . args) + "Asynchronously invoke REFR with ARGS; return nothing. + +Type: Actor Any ... -> Void" + (define sys (get-syscaller-or-die)) + (sys '<-np refr args)) + +(define (<-np-extern to-refr . args) + "Asynchronously invoke the far REFR with ARGS; return nothing. + +Type: Actor Any ... -> Void" + (match to-refr + [(? local-refr?) + (let ((vat-connector (local-refr-vat-connector to-refr))) + (unless vat-connector + (error "Can't use <-np-extern on local-refr with no vat-connector")) + (vat-connector 'handle-message 0 + (make-message vat-connector to-refr #f args)) + *unspecified*)] + [(? remote-refr?) + (let ((captp-connector (remote-refr-captp-connector to-refr))) + (captp-connector 'handle-message + (make-message captp-connector to-refr #f args)) + *unspecified*)])) + + +;; Listen to a promise +(define* (listen-to to-refr listener #:key [wants-partial? #f]) + "Wait for TO-REFR to resolve then inform LISTENER. If WANTS-PARTIAL? +is #t, return updates rather than waiting for full promise resolution. +Return nothing. + +Type: Promise Actor -> Void" + (define sys (get-syscaller-or-die)) + (sys 'send-listen to-refr listener wants-partial?)) + +(define* (on vow #:optional (fulfilled-handler #f) + #:key + [catch #f] + [finally #f] + [promise? #f]) + "Resolve the promise VOW, pass the result to FULFILLED-HANDLER if it +is provided, and return the result. If the procedure CATCH is +provided, it is called on the exception object of any errors. If +FINALLY is provided, it is run after FULFILLED-HANDLER and/or CATCH. +If PROMISE? is #t, the returned value is a promise. + +Type: Promise (Optional (Any -> Any)) +(Optional (#:catch (Exception -> Any))) +(Optional (#:finally (-> Any))) (Optional Boolean) -> (U Any Promise)" + (define broken-handler catch) + (define finally-handler finally) + (define sys (get-syscaller-or-die)) + (define (maybe-actorize obj proc-name) + (match obj + ;; if it's a reference, it's already fine + [(? live-refr?) + obj] + ;; if it's a procedure, let's spawn it + [(? procedure?) + (let ((already-ran + (lambda _ + (error "Already ran for automatically generated listener")))) + (spawn-named + proc-name + (lambda (bcom) + (lambda args + (bcom already-ran (apply obj args))))))] + ;; If it's #f, leave it as #f + [#f #f] + ;; Otherwise, this doesn't belong here + [_ (error "Invalid handler for on:" obj)])) + (sys 'on vow (maybe-actorize fulfilled-handler 'fulfilled-handler) + (maybe-actorize broken-handler 'broken-handler) + (maybe-actorize finally-handler 'finally-handler) + promise?)) + +;; Note that this is on severance of the *connection of this reference*, +;; and if it's a promise, does not follow the promise to its resolution. +;; It will naively treat it as the connection of the *promise*. +;; If you need a more precise object, use `on` to get the fully resolved +;; object. +;; +;; The thing that gets returned is the ability to cancel interest. +(define (on-sever remote-object-refr sever-handler) + "Register `sever-handler' when connection for `remote-object-refr' is severed" + (define-values (sever-vow sever-resolver) + (spawn-promise-values)) + (define captp-connector + (remote-refr-captp-connector remote-object-refr)) + (define connector-obj + (captp-connector 'connector-obj)) + (define connector-cancel-vow + (<- connector-obj 'resolve-on-sever sever-resolver)) + + (on sever-vow + (lambda (val) + (match val + ['canceled *unspecified*] + [('severed shutdown-type reason) + (match sever-handler + [(? procedure?) + (sever-handler shutdown-type reason)] + [(? live-refr?) + (<-np sever-handler shutdown-type reason)])]))) + + + ;; Notifies the captp connector we're no longer interested and cancels + ;; the handler here locally too. + (define (^cancel-interest bcom) + (lambda () + (<-np connector-obj 'cancel-sever-interest sever-resolver) + (<-np sever-resolver 'resolve 'canceled) + (bcom (lambda _ *unspecified*)))) + (spawn ^cancel-interest)) + + + +;; Coroutine support +;; ================= + +(define *actor-await-prompt* (make-prompt-tag 'await-prompt)) + +;; We default to `promise? #f' to avoid accidental infinite promise +;; chains for things that might otherwise loop... is this the right +;; thing to do? +(define* (await* fulfill-proc + #:key [promise? #f]) + (define-values (resume-flag val-or-err) + (abort-to-prompt *actor-await-prompt* fulfill-proc promise?)) + (match resume-flag + ['resume + ;; it's a value, so let's return it + val-or-err] + ['error + ;; it's an error, so let's raise it + (error "Won't resume coroutine; got an *error* as a reply" + val-or-err)])) + +(define* (await vow + #:key + [promise? #f]) + (define (fulfill-await resolver) + (<-np resolver 'fulfill vow)) + (await* fulfill-await #:promise? promise?)) + +(define (<<- actor . args) + (await (apply <- actor args))) + + +;; Spawning promises +;; ================= + +;; We've made the decision +(define already-resolved + (lambda _ #f)) + +(define (^resolver bcom promise sealer) + (lambda args + (match args + [('fulfill val) + (define sys (get-syscaller-or-die)) + (sys 'fulfill-promise promise (sealer val)) + (bcom already-resolved)] + [('break problem) + (define sys (get-syscaller-or-die)) + (sys 'break-promise promise (sealer problem)) + (bcom already-resolved)]))) + +(define* (_spawn-promise-values #:key + (question-finder #f) + (captp-connector #f)) + (define-values (sealer unsealer tm?) + (make-sealer-triplet 'fulfill-promise)) + (define sys (get-syscaller-or-die)) + (define m-eventual + (make-m~eventual unsealer tm?)) + (define m-unresolved + (make-m~unresolved m-eventual '())) + (define promise + (sys 'spawn-mactor + (if question-finder + (begin + (unless captp-connector + (error 'question-finder-without-captp-connector)) + (make-mactor:question m-unresolved + captp-connector + question-finder)) + (make-mactor:naive m-unresolved '())) + #f)) + (define resolver + (spawn-named 'resolver ^resolver promise sealer)) + (values promise resolver)) + +;; We don't want to expose the keyword arguments of the parent +;; procedure to just everyone, hence this indirection +(define (spawn-promise-values) + "Return a promise and its associated resolver as a values object. + +Type: -> (Values Promise Resolver)" + (_spawn-promise-values)) + +;; Convenient, sometimes +(define (spawn-promise-cons) + "Return a promise and its associated resolver as a cons pair. + +Type: -> (Promise . Resolver)" + (call-with-values spawn-promise-values cons)) + + + +;; Spawning +;; ======== + +;; This is the internally used version of actormap-spawn, +;; also used by the syscaller. It doesn't set up a syscaller +;; if there isn't currently one. +(define* (actormap-spawn!* actormap maybe-constructor + args + #:optional + [debug-name (actor-name maybe-constructor)]) + (define vat-connector + (actormap-vat-connector actormap)) + (define-values (become become-unseal become?) + (make-become-sealer-triplet)) + (define-values (constructor constructor-refr) + (values maybe-constructor + #; + (if (redefinable-object? maybe-constructor) ; ; + (redefinable-object-constructor maybe-constructor) ; ; + maybe-constructor) + maybe-constructor)) + (define actor-handler + (apply constructor become args)) + (define* (handler->refr handler #:optional maybe-self-portrait) + (match handler + ;; We can't use match record unpacking because of goblin's $ function. + [(? procedure?) + (let ((actor-refr + (make-local-object-refr debug-name vat-connector))) + (actormap-set! actormap actor-refr + (make-mactor:object handler constructor-refr + constructor + maybe-self-portrait + become-unseal become?)) + actor-refr)] + [(? live-refr? pre-existing-refr) + pre-existing-refr] + [_ + (error 'invalid-actor-handler "Not a procedure, aurie or live refr:" handler)])) + (handler->refr actor-handler)) + +;; These two are user-facing procedures. Thus, they set up +;; their own syscaller. + +;; non-committal version of actormap-spawn +(define (actormap-spawn actormap actor-constructor . args) + "Create and return a reference to ACTOR-CONSTRUCTOR inside ACTORMAP, +passing in ARGS; do not commit the transaction. + +Type: Actormap Constructor Any ... -> Actor" + (define new-actormap + (make-transactormap actormap)) + (call-with-fresh-syscaller + new-actormap + (lambda (sys get-sys-internals) + (define actor-refr + (actormap-spawn!* new-actormap actor-constructor + args)) + (values actor-refr new-actormap)))) + +(define (actormap-spawn! actormap actor-constructor . args) + "Create and return a reference to ACTOR-CONSTRUCTOR inside ACTORMAP, +passing in ARGS; commit the transaction. + +Type: Actormap Constructor Any ... -> Actor" + (define new-actormap + (make-transactormap actormap)) + (define actor-refr + (call-with-fresh-syscaller + new-actormap + (lambda (sys get-sys-internals) + (actormap-spawn!* new-actormap actor-constructor args)))) + (transactormap-merge! new-actormap) + actor-refr) + +(define* (actormap-spawn-mactor! actormap mactor + #:optional + [debug-name #f]) + (define vat-connector + (actormap-vat-connector actormap)) + (define actor-refr + (if (mactor:object? mactor) + (make-local-object-refr debug-name vat-connector) + (make-local-promise-refr vat-connector))) + (actormap-set! actormap actor-refr mactor) + actor-refr) + + + +;;; actormap turning and utils +;;; ========================== + +(define (actormap-turn* actormap to-refr args) + "Invoke TO-REFR with ARGS in ACTORMAP, without creating a new +generation. Return the result of the invoked behavior, a new Actormap, +and a list of new Messages. + +Type: Actormap Actor Any ... -> +(Values Any Actormap (List Message ...))" + (call-with-fresh-syscaller + actormap + (lambda (sys get-sys-internals) + (define result-val + (sys '$ to-refr args)) + (apply values result-val + (get-sys-internals))))) ; actormap new-msgs + +(define (actormap-turn actormap to-refr . args) + "Invoke TO-REFR with ARGS in a new Actormap whose parent is +ACTORMAP. Return the result of the invoked behavior, a reference to +the new Actormap, and a list of new Messages. + +Type: Actormap Actor Any ... -> +(Values Any Actormap (List Message ...))" + (define new-actormap + (make-transactormap actormap)) + (actormap-turn* new-actormap to-refr args)) + +;; run a turn but only for getting the result. +;; we're not interested in committing the result +;; so we discard everything but the result. +(define (actormap-peek actormap to-refr . args) + "Invoke TO-REFR with ARGS in ACTORMAP only to return the results; +do not commit the transaction to the transaction history. + +Type: Actormap Actor Any ... -> Any" + (define-values (returned-val _am _nm) + (actormap-turn* (make-transactormap actormap) + to-refr args)) + returned-val) + +;; Note that this does nothing with the messages. +(define (actormap-poke! actormap to-refr . args) + "Invoke TO-REFR with ARGS in ACTORMAP and commit the results, but do +not propagate any messages. Return the results. + +Type: Actormap Actor Any ... -> Any" + (define-values (returned-val transactormap _nm) + (actormap-turn* (make-transactormap actormap) + to-refr args)) + (transactormap-merge! transactormap) + returned-val) + +(define (actormap-reckless-poke! actormap to-refr . args) + "Invoke TO-REFR with ARGS in ACTORMAP, committing the results +directly to ACTORMAP reather than creating a new generation. Return +the results. + +Type: Actormap Actor Any ... -> Any" + (define-values (returned-val transactormap _nm) + (actormap-turn* actormap to-refr args)) + returned-val) + +;; like actormap-run but also returns the new actormap, new-msgs +(define (actormap-run* actormap thunk) + "Evaluate THUNK in ACTORMAP and commit the results. Return the +results, the Actormap representing the latest generation of +transaction, and any messages generated. + +Type: Actormap (-> Any) -> (Values Any Actormap (List Message ...))" + (define-values (actor-refr new-actormap) + (actormap-spawn (make-transactormap actormap) (lambda (bcom) thunk))) + (define-values (returned-val new-actormap2 new-msgs) + (actormap-turn* (make-transactormap new-actormap) actor-refr '())) + (values returned-val new-actormap2 new-msgs)) + +;; non-committal version of actormap-run +(define (actormap-run actormap thunk) + "Evaluate THUNK in ACTORMAP and return the results. Do not commit +the results to the transaction history. + +Type: Actormap (-> Any) -> Any" + (define-values (returned-val _am _nm) + (actormap-run* (make-transactormap actormap) thunk)) + returned-val) + +;; committal version +;; Run, and also commit the results of, the code in the thunk +(define* (actormap-run! actormap thunk + #:key [reckless? #f]) + "Evaluate THUNK in ACTORMAP and return the results. Commit the +results. + +If RECKLESS? is #t, operate directly in ACTORMAP without creating a +new generation. + +Type: Actormap (-> Any) (Optioan (#:reckless? Boolean)) -> Any" + (define actor-refr + (actormap-spawn! actormap + (lambda (bcom) + (lambda () + (call-with-values thunk list))))) + (define actormap-poker! + (if reckless? + actormap-reckless-poke! + actormap-poke!)) + (apply values (actormap-poker! actormap actor-refr))) + + +(define while-handling-header + "While attempting to handle message") +(define before-even-able-to-handle-header + "Before even being able to handle message") +(define while-handling-listen-header + "While handling listen request") + +(define (simple-display-error msg err stack) + (newline (current-error-port)) + (display ";; === Caught error: ===\n" (current-error-port)) + (display ";; message: " (current-error-port)) + (display msg (current-error-port)) (newline (current-error-port)) + (display ";; exception: " (current-error-port)) + (format-exception err (current-error-port)) + (newline (current-error-port)) (flush-output-port (current-error-port))) + +(define (make-no-op msg) + (lambda _ *unspecified*)) + +(define* (actormap-turn-message actormap msg + #:key + [error-handler simple-display-error] + [reckless? #f] + [catch-errors? #t]) + "Invoke MSG in ACTORMAP and return the result. + +If provided, ERROR-HANDLER is a procedure to handle exceptions. +If RECKLESS? is #t, operate directly in ACTORMAP without creating a +new generation; otherwise create a new generation of Actormap. If +CATCH-ERRORS? is #t, capture the stack and abort to a prompt; +otherwise propogate the error. + +Type: Actormap Message (Optional (#:error-handler (Exception -> Any))) +(Optional (#:reckless? Boolean)) (Optional (#:catch-errors? Boolean)) +-> Any" + ;; TODO: Kuldgily reimplements part of actormap-turn*... maybe + ;; there's some opportunity to combine things, dunno. + (call-with-fresh-syscaller + (if reckless? + actormap + (make-transactormap actormap)) + (lambda (sys get-sys-internals) + (define (error-prompt-handler kont err stack-at-exn) + ;; Since we threw an exception, we should inform that this + ;; failed... if anyone cares + (define resolve-me + (message-who-wants-response msg)) + (define new-msgs + (if resolve-me + (list (make-message (sys 'vat-connector) resolve-me #f (list 'break err))) + '())) + ;; Decorate the original exception with an actormap turn error + ;; that captures the stack in which the original exception + ;; occurred. + (define turn-error + (make-exception-with-irritants `(actormap-turn-error ,err))) + (when error-handler + (error-handler msg err stack-at-exn)) + (values `#(fail ,turn-error) actormap new-msgs)) + (define handle-exn-tag (make-prompt-tag 'goblins-turn)) + (define (catch-stack-and-abort-to-prompt err) + (define stack + 'backtraces-unimplemented) + (abort-to-prompt handle-exn-tag err stack)) + (define (do-call) + (define result + (match msg + [(? message?) + (sys 'handle-message msg)] + [(? listen-request? lr) + (sys 'handle-listen + (listen-request-to lr) + (listen-request-listener lr) + (listen-request-wants-partial? lr))])) + (match (get-sys-internals) + [(new-actormap new-msgs) + (values `#(ok ,result) new-actormap new-msgs)])) + (if catch-errors? + ;; We're catching errors? Well, let's capture the stack without + ;; unwinding, *then* abort to a prompt where it's safe to process + ;; it... + (call-with-prompt handle-exn-tag + (lambda () + (with-exception-handler catch-stack-and-abort-to-prompt + do-call + #:unwind? #f)) + error-prompt-handler) + ;; No? Well then, it's much simpler... + (do-call))))) + +(define* (actormap-churn am msg + #:key [catch-errors? #t] + ;; TODO: for consistency, replace with a #:reckless? flag + [make-transactormap? #t]) + "Perform every turn possible in AM to resolve MSG without needing to +send messages to far objects, then dispatch messages to far objects. + +If CATCH-ERRORS is #t, collect the stack and abort to a prompt on +errors; otherwise, propogate errors. + +If MAKE-TRANSACTORMAP? is #t, create a new generation for the +operation; otherwise, act directly in AM. + +Type: Actormap Message (Optional (#:catch-errors? Boolean)) +(Optional (#:make-transactormap? Boolean)) -> Void" + (define churn-q (make-q)) ; message to churn on here + ;; This one doesn't really need to be a queue. Maybe it + ;; makes things easier to think about though, I'm undecided. + ;; TODO: Is our ordering really right for the final set of + ;; things to send? + (define send-far-q (make-q)) ; messages we must still send + (define new-am + (if make-transactormap? + (make-transactormap am) + am)) + (define this-vat-connector (actormap-vat-connector am)) + (define first-one? #t) + (define first-return-val #f) + (define (near-msg? msg) + (define to-refr (message-or-request-to msg)) + (and (local-refr? to-refr) + (eq? (local-refr-vat-connector to-refr) + this-vat-connector))) + ;; Used for both filling the initial queue and after + ;; each turn... also used to queue up the messages to be + ;; sent externally + (define (q-append! q lst) + (match lst + ('() 'done) + ((item . rest) + (q-push! q item) + (q-append! q rest)))) + ;; Queue messages depending on whether they're for this actormap + ;; or if they go somewhere else + ;; TODO: We could probably be faster about this with an append or... + ;; something. + (define (queue-messages-appropriately! msgs) + (match msgs + ('() 'done) + ((msg . next-msgs) + (queue-messages-appropriately! next-msgs) ; last message first + (if (near-msg? msg) + (enq! churn-q msg) + (enq! send-far-q msg))))) + (define (churn!) + (define next-msg (deq! churn-q)) + (define-values (this-result buffer-am new-msgs) + (actormap-turn-message new-am next-msg + #:catch-errors? catch-errors?)) + (when first-one? + (set! first-return-val this-result) + (set! first-one? #f)) + ;; queue messages... + (queue-messages-appropriately! new-msgs) + ;; merge if appropriate... + (match this-result + [#('ok _result) + (transactormap-buffer-merge! buffer-am)] + [#('fail err) 'no-op]) + ;; and loop! + (if (q-empty? churn-q) + 'done + (churn!))) + ;; Put the first message on the queue + (enq! churn-q msg) + ;; Turn as many times as it takes to run this + ;; actormap turn / vat to quiescence + (churn!) + ;; And now let's return everything... + (let ((send-far-msgs (car send-far-q))) + (values first-return-val new-am send-far-msgs))) + +(define* (actormap-churn-run actormap thunk + #:key [catch-errors? #t]) + "Evaluate THUNK in ACTORMAP, performing all possible invocations to +resolve THUNK without sending messages to far objects. Return the +results, a reference to an Actormap representing the new generation, +and any messages generated. + +If CATCH-ERRORS? is #t, capture the stack and abort to a prompt on +error; otherwise, propogate the error. + +Type: Actormap (-> Any) (Optional (#:catch-errors? Boolean)) -> +(Values Any Actormap (List Message))" + (define vat-connector (actormap-vat-connector actormap)) + (define-values (actor-refr new-actormap) + (actormap-spawn actormap (lambda (_bcom) thunk))) + (define-values (returned-val _nam new-msgs) + (actormap-churn new-actormap (make-message vat-connector actor-refr #f '()) + #:catch-errors? catch-errors? + #:make-transactormap? #f)) ; reuses new-actormap + (values returned-val new-actormap new-msgs)) + +(define-record-type + (make-multival-return-kluge vals) + multival-return-kluge? + (vals multival-return-kluge-vals)) + +;; Also sends out relevant messages, and re-raises exceptions if appropriate +(define* (actormap-churn-run! actormap thunk + #:key [catch-errors? #t]) + "Evaluate THUNK in ACTORMAP, performing all possible invocations to +resolve THUNK without sending messages to far objects, then send out +messages. Return the results. + +If CATCH-ERRORS? is #t, capture the stack and abort to a prompt on +error; otherwise, propogate the error. + +Type: Actormap (-> Any) (Optional (#:catch-errors? Boolean)) -> Any" + (define (churn-run-values->list . args) + (call-with-values thunk + (lambda rvals + (make-multival-return-kluge rvals)))) + (define-values (returned-val new-actormap new-msgs) + (actormap-churn-run actormap churn-run-values->list + #:catch-errors? catch-errors?)) + (dispatch-messages new-msgs) + (match returned-val + ;; kluge to handle the coroutine case + [#('ok (? multival-return-kluge? mrk)) + (transactormap-merge! new-actormap) + (apply values (multival-return-kluge-vals mrk))] + [#('ok rval) + (transactormap-merge! new-actormap) + rval] + [#('fail err) + ;; re-raise exception + (raise-exception err)])) + +(define* (dispatch-message msg #:optional (timestamp 0)) + (cond + ;; See the comment above for why we're kind of + ;; duplicating code with the final nested branch of this procedure. + [(forward-to-captp? msg) + ;; oh this is one of those klugey "forward me" things + (let ((real-msg (forward-to-captp-msg msg)) + (captp-connector (forward-to-captp-connector msg))) + (captp-connector 'handle-message real-msg))] + [else + ;; okay guess not + (let ((to-refr (message-or-request-to msg))) + (cond + ;; send locally + [(local-refr? to-refr) + (match (local-refr-vat-connector to-refr) + ;; TODO: When messages aren't going to be possible to deliver, + ;; we should alert the waiting-on-message + [(? procedure? vat-connector) + (vat-connector 'handle-message timestamp msg)] + ;; noplace like nowhere + ;; TODO: Maybe we should give warnings about this, since + ;; delivering messages to actors that can't receive them is... + ;; surprising. + [#f 'no-op])] + ;; send remotely + [else + (let ((captp-connector (remote-refr-captp-connector to-refr))) + (captp-connector 'handle-message msg))]))])) + +(define (dispatch-messages msgs) + (for-each dispatch-message msgs)) + +(define (syscaller-free proc) + (parameterize ([current-syscaller #f]) + (proc))) + +(define (depictable-atom? obj) + (or (number? obj) (boolean? obj) (string? obj) + (symbol? obj) (bytevector? obj))) + +(define (actor-name constructor) + 'procedure-name-unimplemented) diff --git a/modules/goblins/ghash.scm b/modules/goblins/ghash.scm new file mode 100644 index 0000000..0758f45 --- /dev/null +++ b/modules/goblins/ghash.scm @@ -0,0 +1,239 @@ +;;; Copyright 2021-2024 Christine Lemmer-Webber +;;; Copyright 2024 Jessica Tallon +;;; +;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;; you may not use this file except in compliance with the License. +;;; You may obtain a copy of the License at +;;; +;;; http://www.apache.org/licenses/LICENSE-2.0 +;;; +;;; Unless required by applicable law or agreed to in writing, software +;;; distributed under the License is distributed on an "AS IS" BASIS, +;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;; See the License for the specific language governing permissions and +;;; limitations under the License. + +;; An immutable hashtable with specific set/ref conventions. Refrs +;; are hashed by eq?, everything else is hashed by equal?. +;; +;; TODO: Really presently built on top of vhashes. Might be built on +;; top of something else, like fashes, in the future. Especially since +;; vhashes are not thread safe... + + +(define-module (goblins ghash) + ;; NOTE: Do not depend on core because it depends on us. + #:use-module (goblins core-types) + #:use-module (ice-9 vlist) + #:use-module (hoot hashtables) + #:use-module ((hoot lists) #:select (fold)) + #:use-module (ice-9 match) + #:use-module (scheme write) + #:export (make-ghash + ghash? + + ghash-set + ghash-ref + ghash-remove + ghash-null + ghash-length + ghash-has-key? + + ghash-fold + ghash-fold-right + ghash-for-each + + hashtable->ghash + + make-gset + gset? + gset-add + gset-remove + gset-length + gset->list + gset-member? + + gset-fold + gset-for-each)) + +;; hoot hacks + +(define (hashtable-fold proc init table) + (let ((acc init)) + (hashtable-for-each + (lambda (k v) + (set! acc (proc k v acc))) + table))) + +(define-record-type + (_make-ghash vhash) + ghash? + (vhash ghash-vhash)) + +(define (vhash-length vhash) + (vhash-fold (lambda (_k _v count) (+ count 1)) + 0 vhash)) + +(define (print-ghash vhash port) + (display + (string-append + "#") + port)) + +(define ghash-null (_make-ghash vlist-null)) + +(define (make-ghash . key-vals) + (_make-ghash + (let lp ((key-vals key-vals) + (vh vlist-null)) + (match key-vals + [() vh] + [(key val . rest) + (lp rest + (_vh-set vh key val))])))) + +(define (_vh-set vh key val) + (define conser + (if (or (live-refr? key) (symbol? key)) + vhash-consq + vhash-cons)) + (conser key val vh)) + +(define (ghash-set ghash key val) + (define vh (ghash-vhash ghash)) + (_make-ghash (_vh-set vh key val))) + +(define* (ghash-ref ghash key #:optional [dflt #f]) + (define vh (ghash-vhash ghash)) + (define assoc + (if (or (live-refr? key) (symbol? key)) + vhash-assq + vhash-assoc)) + (match (assoc key vh) + ((_k . val) val) + (#f dflt))) + +(define (ghash-has-key? ghash key) + (define vh (ghash-vhash ghash)) + (define assoc + (if (or (live-refr? key) (symbol? key)) + vhash-assq + vhash-assoc)) + (match (assoc key vh) + ((_k . val) #t) + (#f #f))) + +(define (ghash-remove ghash key) + (define vh (ghash-vhash ghash)) + (define del + (if (or (live-refr? key) (symbol? key)) + vhash-delq + vhash-delete)) + (_make-ghash (del key vh))) + +(define (ghash-length ghash) + (vlist-length (ghash-vhash ghash))) + +(define (ghash-fold proc init ghash) + (vhash-fold proc init (ghash-vhash ghash))) +(define (ghash-fold-right proc init ghash) + (vhash-fold-right proc init (ghash-vhash ghash))) + +(define (ghash-for-each proc ghash) + (vhash-fold + (lambda (k v _p) + (proc k v)) + #f + (ghash-vhash ghash))) + +(define (hashtable->ghash table) + (_make-ghash + (hashtable-fold + (lambda (key val vh) + (_vh-set vh key val)) + vlist-null + table))) + +;;; Sets +(define-record-type + (_make-gset ht) + gset? + (ht _set-ht)) + +(define (print-set set port) + (define items + (vhash-fold + (lambda (k _v prev) + (cons k prev)) + '() + (_set-ht set))) + (display (string-append "#") port)) + +(define (make-gset . items) + (define vh + (fold + (lambda (item vh) + (define-values (add assoc) + (if (or (live-refr? item) (symbol? item)) + (values vhash-consq vhash-assoc) + (values vhash-cons vhash-assq))) + ;; Ensure it's unique to the set + (if (assoc item vh) + vh + (add item #t vh))) + vlist-null items)) + (_make-gset vh)) + +(define (gset-add set item) + (define add + (if (or (live-refr? item) (symbol? item)) + vhash-consq + vhash-cons)) + (if (gset-member? set item) + set + (_make-gset (add item #t (_set-ht set))))) + +(define (gset-remove set item) + (define del + (if (or (live-refr? item) (symbol? item)) + vhash-delq + vhash-delete)) + (_make-gset (del item (_set-ht set)))) + +(define (gset-fold proc init set) + (vhash-fold + (lambda (key _val prev) + (proc key prev)) + init + (_set-ht set))) + +(define (gset-length set) + (vhash-fold + (lambda (_k _v count) + (+ count 1)) + 0 + (_set-ht set))) + +(define (gset->list set) + (vhash-fold + (lambda (key _val prev) + (cons key prev)) + '() + (_set-ht set))) + +(define (gset-member? set key) + (define assoc + (if (or (live-refr? key) symbol? key) + vhash-assq + vhash-assoc)) + + (match (assoc key (_set-ht set)) + [(_val . #t) #t] + [#f #f])) + +(define (gset-for-each proc set) + (vhash-fold + (lambda (k v _p) + (proc k v)) + #f + (_set-ht set))) diff --git a/modules/guile/list.scm b/modules/guile/list.scm new file mode 100644 index 0000000..916fb3c --- /dev/null +++ b/modules/guile/list.scm @@ -0,0 +1,65 @@ +;;; List compatibility procedures/macros for Guile + +;;; Copyright © 2024 Juliana Sims +;;; +;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;; you may not use this file except in compliance with the License. +;;; You may obtain a copy of the License at +;;; +;;; http://www.apache.org/licenses/LICENSE-2.0 +;;; +;;; Unless required by applicable law or agreed to in writing, software +;;; distributed under the License is distributed on an "AS IS" BASIS, +;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;; See the License for the specific language governing permissions and +;;; limitations under the License. + +;;; Commentary: +;;; +;;; These match APIs exposed in Guile's environment but not yet available in +;;; Hoot. + +;;; Code: + +(define-module (guile list) + #:export (delete delq delq! last-pair)) + +(define (fold proc acc lst) + (if (null? lst) + acc + (fold proc + (proc (car lst) acc) + (cdr lst)))) + +(define (fold-right proc acc lst) + (fold proc acc (reverse lst))) + +(define (last-pair lst) + (if (null? (cdr lst)) + lst + (last-pair (cdr lst)))) + +(define (delete item lst . eq-pair) + (define eq (if (pair? eq-pair) (car eq-pair) equal?)) + (fold-right (lambda (i acc) + (if (eq i item) + acc + (cons i acc))) + '() lst)) + +(define (delq item lst) + (delete item lst eq?)) + +;; This matches the semantics of Guile's delq!, but using set-car! means we +;; could actually improve delq! by ensuring eq? between an original list +;; starting with ITEM and a delq! removing ITEM from that list. Guile's delq! +;; does not provide this functionality because it does not destructively +;; remove the list's car +(define (delq! item lst) + (let ((delqd-lst (delq item lst))) + (if (eq? (car lst) item) + (and (set-cdr! lst delqd-lst) + delqd-lst) + (and (set-cdr! lst (cdr delqd-lst)) + (set-car! lst (car delqd-lst)) + lst)))) diff --git a/modules/ice-9/control.scm b/modules/ice-9/control.scm new file mode 100644 index 0000000..38717dd --- /dev/null +++ b/modules/ice-9/control.scm @@ -0,0 +1,48 @@ +;;; Copyright (C) 2010, 2011, 2013, 2024 Free Software Foundation, Inc. +;;; +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 3 of the License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; This is a convenience module for porting Goblins to Hoot while Guile support +;;; is incomplete. It simply re-exports some extant Hoot prompt functionality +;;; and adds call-with-escape-continuation and call/ec. +;;; +;;; Code: + +(define-module (ice-9 control) + #:use-module (hoot control) + #:export (make-prompt-tag + default-prompt-tag + call-with-prompt + abort-to-prompt + + % + default-prompt-handler + + call-with-escape-continuation + call/ec)) + +(define (call-with-escape-continuation proc) + "Call PROC with an escape continuation." + (let ((tag (list 'call/ec))) + (call-with-prompt tag + (lambda () + (proc (lambda args + (apply abort-to-prompt tag args)))) + (lambda (_ . args) + (apply values args))))) + +(define call/ec call-with-escape-continuation) diff --git a/modules/ice-9/q.scm b/modules/ice-9/q.scm new file mode 100644 index 0000000..b300e08 --- /dev/null +++ b/modules/ice-9/q.scm @@ -0,0 +1,171 @@ +;;; Guile's (ice-9 q) module modified for Hoot + +;;;; Copyright (C) 1995, 2001, 2004, 2006 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; Guile's q module for use with Hoot +;;; +;;; This is exactly the code from Guile, including comments, using error instead +;;; of throw for erroring. It also pulls in other Guile compatibility modules +;;; and uses R6RS-style library declarations. +;;; +;;; Original commentary: +;;; +;;; Q: Based on the interface to +;;; +;;; "queue.scm" Queues/Stacks for Scheme +;;; Written by Andrew Wilcox (awilcox@astro.psu.edu) on April 1, 1992. + +;;; {Q} +;;; +;;; A list is just a bunch of cons pairs that follows some constrains, +;;; right? Association lists are the same. Hash tables are just +;;; vectors and association lists. You can print them, read them, +;;; write them as constants, pun them off as other data structures +;;; etc. This is good. This is lisp. These structures are fast and +;;; compact and easy to manipulate arbitrarily because of their +;;; simple, regular structure and non-disjointedness (associations +;;; being lists and so forth). +;;; +;;; So I figured, queues should be the same -- just a "subtype" of cons-pair +;;; structures in general. +;;; +;;; A queue is a cons pair: +;;; ( . ) +;;; +;;; is a list of things in the q. New elements go at the end +;;; of that list. +;;; +;;; is #f if the q is empty, and otherwise is the last +;;; pair of . +;;; +;;; q's print nicely, but alas, they do not read well because the +;;; eq?-ness of and (last-pair ) is lost by read. +;;; +;;; All the functions that aren't explicitly defined to return +;;; something else (a queue element; a boolean value) return the queue +;;; object itself. + +;;; Code: + +(define-module (ice-9 q) + #:use-module (guile list) + #:export (deq! + enq! + make-q + q? + q-empty? + q-empty-check + q-front + q-length + q-pop! + q-push! + q-rear + q-remove! + sync-q!)) + +;;; sync-q! +;;; The procedure +;;; +;;; (sync-q! q) +;;; +;;; recomputes and resets the component of a queue. +;;; +(define (sync-q! q) + (set-cdr! q (if (pair? (car q)) (last-pair (car q)) + #f)) + q) + +;;; make-q +;;; return a new q. +;;; +(define (make-q) (cons '() #f)) + +;;; q? obj +;;; Return true if obj is a Q. +;;; An object is a queue if it is equal? to '(() . #f) +;;; or it is a pair P with (list? (car P)) +;;; and (eq? (cdr P) (last-pair (car P))). +;;; +(define (q? obj) + (and (pair? obj) + (if (pair? (car obj)) + (eq? (cdr obj) (last-pair (car obj))) + (and (null? (car obj)) + (not (cdr obj)))))) + +;;; q-empty? obj +;;; +(define (q-empty? obj) (null? (car obj))) + +;;; q-empty-check q +;;; Throw a q-empty exception if Q is empty. +(define (q-empty-check q) (if (q-empty? q) (error "empty queue" q))) + +;;; q-front q +;;; Return the first element of Q. +(define (q-front q) (q-empty-check q) (caar q)) + +;;; q-rear q +;;; Return the last element of Q. +(define (q-rear q) (q-empty-check q) (cadr q)) + +;;; q-remove! q obj +;;; Remove all occurences of obj from Q. +(define (q-remove! q obj) + (set-car! q (delq! obj (car q))) + (sync-q! q)) + +;;; q-push! q obj +;;; Add obj to the front of Q +(define (q-push! q obj) + (let ((h (cons obj (car q)))) + (set-car! q h) + (or (cdr q) (set-cdr! q h))) + q) + +;;; enq! q obj +;;; Add obj to the rear of Q +(define (enq! q obj) + (let ((h (cons obj '()))) + (if (null? (car q)) + (set-car! q h) + (set-cdr! (cdr q) h)) + (set-cdr! q h)) + q) + +;;; q-pop! q +;;; Take the front of Q and return it. +(define (q-pop! q) + (q-empty-check q) + (let ((it (caar q)) + (next (cdar q))) + (if (null? next) + (set-cdr! q #f)) + (set-car! q next) + it)) + +;;; deq! q +;;; Take the front of Q and return it. +(define deq! q-pop!) + +;;; q-length q +;;; Return the number of enqueued elements. +;;; +(define (q-length q) (length (car q))) +;;; q.scm ends here diff --git a/modules/ice-9/vlist.scm b/modules/ice-9/vlist.scm new file mode 100644 index 0000000..cdcb8cf --- /dev/null +++ b/modules/ice-9/vlist.scm @@ -0,0 +1,595 @@ +;;; -*- mode: scheme; coding: utf-8; -*- +;;; +;;; Copyright (C) 2009, 2010, 2011, 2012, 2024 Free Software Foundation, Inc. +;;; +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 3 of the License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Author: Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; This is a port of Guile's (ice-9 vlist) for Hoot. It is derived from the +;;; upstream module and differs only as necessary to work with Hoot. The +;;; original developer's commentary continues below. +;;; +;;; This module provides an implementations of vlists, a functional list-like +;;; data structure described by Phil Bagwell in "Fast Functional Lists, +;;; Hash-Lists, Dequeues and Variable-Length Arrays", EPFL Technical Report, +;;; 2002. +;;; +;;; The idea is to store vlist elements in increasingly large contiguous blocks +;;; (implemented as vectors here). These blocks are linked to one another using +;;; a pointer to the next block (called `block-base' here) and an offset within +;;; that block (`block-offset' here). The size of these blocks form a geometric +;;; series with ratio `block-growth-factor'. +;;; +;;; In the best case (e.g., using a vlist returned by `list->vlist'), +;;; elements from the first half of an N-element vlist are accessed in O(1) +;;; (assuming `block-growth-factor' is 2), and `vlist-length' takes only +;;; O(ln(N)). Furthermore, the data structure improves data locality since +;;; vlist elements are adjacent, which plays well with caches. +;;; +;;; Code: + +(define-module (ice-9 vlist) + #:use-module (hoot fluids) + #:use-module (hoot hashtables) + #:use-module ((hoot lists) #:select (fold)) + #:export (vlist? vlist-cons vlist-head vlist-tail vlist-null? + vlist-null list->vlist vlist-ref vlist-drop vlist-take + vlist-length vlist-fold vlist-fold-right vlist-map + vlist-unfold vlist-unfold-right vlist-append + vlist-reverse vlist-filter vlist-delete vlist->list + vlist-for-each + block-growth-factor + + vhash? vhash-cons vhash-consq vhash-consv + vhash-assoc vhash-assq vhash-assv + vhash-delete vhash-delq vhash-delv + vhash-fold vhash-fold-right + vhash-fold* vhash-foldq* vhash-foldv* + alist->vhash)) + + ;;; Hoot Hacks™ (not really ™) + +;; XXX hashes using equal? and eqv? have not been defined; use only eq? +(define equal? eq?) +(define eqv? eq?) +(define hash hashq) +(define hashv hashq) +(define (fold-right proc init lst) + (fold proc init (reverse lst))) + + +;;; +;;; VList Blocks and Block Descriptors. +;;; + +(define block-growth-factor + (make-fluid 2)) + +(define (make-block base offset size hash-tab?) + ;; Return a block (and block descriptor) of SIZE elements pointing to + ;; BASE at OFFSET. If HASH-TAB? is true, we also reserve space for a + ;; "hash table". Note: We use `next-free' instead of `last-used' as + ;; suggested by Bagwell. + (if hash-tab? + (vector (make-vector (* size 3) #f) + base offset size 0) + (vector (make-vector size) + base offset size 0))) + +(define-syntax define-block-accessor + (syntax-rules () + ((_ name index) + (define (name block) + (vector-ref block index))))) + +(define-block-accessor block-content 0) +(define-block-accessor block-base 1) +(define-block-accessor block-offset 2) +(define-block-accessor block-size 3) +(define-block-accessor block-next-free 4) + +(define (block-hash-table? block) + (< (block-size block) (vector-length (block-content block)))) + +(define (set-block-next-free! block next-free) + (vector-set! block 4 next-free)) + +(define (block-append! block value offset) + ;; This is not thread-safe. To fix it, see Section 2.8 of the paper. + (and (< offset (block-size block)) + (= offset (block-next-free block)) + (begin + (set-block-next-free! block (+ offset 1)) + (vector-set! (block-content block) offset value) + #t))) + +;; Return the item at slot OFFSET. +(define (block-ref content offset) + (vector-ref content offset)) + +;; Return the offset of the next item in the hash bucket, after the one +;; at OFFSET. +(define (block-hash-table-next-offset content size offset) + (vector-ref content (+ size size offset))) + +;; Save the offset of the next item in the hash bucket, after the one +;; at OFFSET. +(define (block-hash-table-set-next-offset! content size offset + next-offset) + (vector-set! content (+ size size offset) next-offset)) + +;; Returns the index of the last entry stored in CONTENT with +;; SIZE-modulo hash value KHASH. +(define (block-hash-table-ref content size khash) + (vector-ref content (+ size khash))) + +(define (block-hash-table-set! content size khash offset) + (vector-set! content (+ size khash) offset)) + +;; Add hash table information for the item recently added at OFFSET, +;; with SIZE-modulo hash KHASH. +(define (block-hash-table-add! content size khash offset) + (block-hash-table-set-next-offset! content size offset + (block-hash-table-ref content size khash)) + (block-hash-table-set! content size khash offset)) + +(define block-null + ;; The null block. + (make-block #f 0 0 #f)) + + +;;; +;;; VLists. +;;; + +(define-record-type + ;; A vlist is just a base+offset pair pointing to a block. + + ;; XXX: Allocating a record in addition to the block at each + ;; `vlist-cons' call is inefficient. However, Bagwell's hack to avoid it + ;; (Section 2.2) would require GC_ALL_INTERIOR_POINTERS, which would be a + ;; performance hit for everyone. + (make-vlist base offset) + vlist? + (base vlist-base) + (offset vlist-offset)) + +(define vlist-null + ;; The empty vlist. + (make-vlist block-null 0)) + +;; Asserting that something is a vlist is actually a win if your next +;; step is to call record accessors, because that causes CSE to +;; eliminate the type checks in those accessors. +;; +(define (assert-vlist val) + (unless (vlist? val) + (error "Not a vlist: " (list val)))) + +(define (block-cons item vlist hash-tab?) + (let ((base (vlist-base vlist)) + (offset (+ (vlist-offset vlist) 1))) + (cond + ((block-append! base item offset) + ;; Fast path: We added the item directly to the block. + (make-vlist base offset)) + (else + ;; Slow path: Allocate a new block. + (let* ((size (block-size base)) + (base (make-block + base + (- offset 1) + (cond + ((zero? size) 1) + ((< offset size) 1) ;; new vlist head + (else (* (fluid-ref block-growth-factor) size))) + hash-tab?))) + (set-block-next-free! base 1) + (vector-set! (block-content base) 0 item) + (make-vlist base 0)))))) + +(define (vlist-cons item vlist) + "Return a new vlist with ITEM as its head and VLIST as its +tail." + ;; Note: Although the result of `vlist-cons' on a vhash is a valid + ;; vlist, it is not a valid vhash. The new item does not get a hash + ;; table entry. If we allocate a new block, the new block will not + ;; have a hash table. Perhaps we can do something more sensible here, + ;; but this is a hot function, so there are performance impacts. + (assert-vlist vlist) + (block-cons item vlist #f)) + +(define (vlist-head vlist) + "Return the head of VLIST." + (assert-vlist vlist) + (let ((base (vlist-base vlist)) + (offset (vlist-offset vlist))) + (block-ref (block-content base) offset))) + +(define (vlist-tail vlist) + "Return the tail of VLIST." + (assert-vlist vlist) + (let ((base (vlist-base vlist)) + (offset (vlist-offset vlist))) + (if (> offset 0) + (make-vlist base (- offset 1)) + (make-vlist (block-base base) + (block-offset base))))) + +(define (vlist-null? vlist) + "Return true if VLIST is empty." + (assert-vlist vlist) + (let ((base (vlist-base vlist))) + (and (not (block-base base)) + (= 0 (block-size base))))) + + +;;; +;;; VList Utilities. +;;; + +(define (list->vlist lst) + "Return a new vlist whose contents correspond to LST." + (vlist-reverse (fold vlist-cons vlist-null lst))) + +(define (vlist-fold proc init vlist) + "Fold over VLIST, calling PROC for each element." + ;; FIXME: Handle multiple lists. + (assert-vlist vlist) + (let loop ((base (vlist-base vlist)) + (offset (vlist-offset vlist)) + (result init)) + (if (eq? base block-null) + result + (let* ((next (- offset 1)) + (done? (< next 0))) + (loop (if done? (block-base base) base) + (if done? (block-offset base) next) + (proc (block-ref (block-content base) offset) result)))))) + +(define (vlist-fold-right proc init vlist) + "Fold over VLIST, calling PROC for each element, starting from +the last element." + (assert-vlist vlist) + (let loop ((index (- (vlist-length vlist) 1)) + (result init)) + (if (< index 0) + result + (loop (- index 1) + (proc (vlist-ref vlist index) result))))) + +(define (vlist-reverse vlist) + "Return a new VLIST whose content are those of VLIST in reverse +order." + (vlist-fold vlist-cons vlist-null vlist)) + +(define (vlist-map proc vlist) + "Map PROC over the elements of VLIST and return a new vlist." + (vlist-fold (lambda (item result) + (vlist-cons (proc item) result)) + vlist-null + (vlist-reverse vlist))) + +(define (vlist->list vlist) + "Return a new list whose contents match those of VLIST." + (vlist-fold-right cons '() vlist)) + +(define (vlist-ref vlist index) + "Return the element at index INDEX in VLIST." + (assert-vlist vlist) + (let loop ((index index) + (base (vlist-base vlist)) + (offset (vlist-offset vlist))) + (if (<= index offset) + (block-ref (block-content base) (- offset index)) + (loop (- index offset 1) + (block-base base) + (block-offset base))))) + +(define (vlist-drop vlist count) + "Return a new vlist that does not contain the COUNT first elements of +VLIST." + (assert-vlist vlist) + (let loop ((count count) + (base (vlist-base vlist)) + (offset (vlist-offset vlist))) + (if (<= count offset) + (make-vlist base (- offset count)) + (loop (- count offset 1) + (block-base base) + (block-offset base))))) + +(define (vlist-take vlist count) + "Return a new vlist that contains only the COUNT first elements of +VLIST." + (let loop ((count count) + (vlist vlist) + (result vlist-null)) + (if (= 0 count) + (vlist-reverse result) + (loop (- count 1) + (vlist-tail vlist) + (vlist-cons (vlist-head vlist) result))))) + +(define (vlist-filter pred vlist) + "Return a new vlist containing all the elements from VLIST that +satisfy PRED." + (vlist-fold-right (lambda (e v) + (if (pred e) + (vlist-cons e v) + v)) + vlist-null + vlist)) + +(define* (vlist-delete x vlist #:optional (equal? equal?)) + "Return a new vlist corresponding to VLIST without the elements +EQUAL? to X." + (vlist-filter (lambda (e) + (not (equal? e x))) + vlist)) + +(define (vlist-length vlist) + "Return the length of VLIST." + (assert-vlist vlist) + (let loop ((base (vlist-base vlist)) + (len (vlist-offset vlist))) + (if (eq? base block-null) + len + (loop (block-base base) + (+ len 1 (block-offset base)))))) + +(define* (vlist-unfold p f g seed + #:optional (tail-gen (lambda (x) vlist-null))) + "Return a new vlist. See the description of SRFI-1 `unfold' for details." + (let uf ((seed seed)) + (if (p seed) + (tail-gen seed) + (vlist-cons (f seed) + (uf (g seed)))))) + +(define* (vlist-unfold-right p f g seed #:optional (tail vlist-null)) + "Return a new vlist. See the description of SRFI-1 `unfold-right' for +details." + (let uf ((seed seed) (lis tail)) + (if (p seed) + lis + (uf (g seed) (vlist-cons (f seed) lis))))) + +(define (vlist-append . vlists) + "Append the given lists." + (if (null? vlists) + vlist-null + (fold-right (lambda (vlist result) + (vlist-fold-right (lambda (e v) + (vlist-cons e v)) + result + vlist)) + vlist-null + vlists))) + +(define (vlist-for-each proc vlist) + "Call PROC on each element of VLIST. The result is unspecified." + (vlist-fold (lambda (item x) + (proc item)) + (if #f #f) + vlist)) + + +;;; +;;; Hash Lists, aka. `VHash'. +;;; + +;; Assume keys K1 and K2, H = hash(K1) = hash(K2), and two values V1 and V2 +;; associated with K1 and K2, respectively. The resulting layout is a +;; follows: +;; +;; ,--------------------. +;; 0| ,-> (K1 . V1) | Vlist array +;; 1| | | +;; 2| | (K2 . V2) | +;; 3| | | +;; size +-|------------------+ +;; 0| | | Hash table +;; 1| | | +;; 2| +-- O <------------- H +;; 3| | | +;; size * 2 +-|------------------+ +;; 0| `-> 2 | Chain links +;; 1| | +;; 2| #f | +;; 3| | +;; size * 3 `--------------------' +;; +;; The backing store for the vhash is partitioned into three areas: the +;; vlist part, the hash table part, and the chain links part. In this +;; example we have a hash H which, when indexed into the hash table +;; part, indicates that a value with this hash can be found at offset 0 +;; in the vlist part. The corresponding index (in this case, 0) of the +;; chain links array holds the index of the next element in this block +;; with this hash value, or #f if we reached the end of the chain. +;; +;; This API potentially requires users to repeat which hash function and +;; which equality predicate to use. This can lead to unpredictable +;; results if they are used in consistenly, e.g., between `vhash-cons' +;; and `vhash-assoc', which is undesirable, as argued in +;; http://savannah.gnu.org/bugs/?22159 . OTOH, two arguments can be +;; made in favor of this API: +;; +;; - It's consistent with how alists are handled in SRFI-1. +;; +;; - In practice, users will probably consistenly use either the `q', +;; the `v', or the plain variant (`vlist-cons' and `vlist-assoc' +;; without any optional argument), i.e., they will rarely explicitly +;; pass a hash function or equality predicate. + +(define (vhash? obj) + "Return true if OBJ is a hash list." + (and (vlist? obj) + (block-hash-table? (vlist-base obj)))) + +(define* (vhash-cons key value vhash #:optional (hash hash)) + "Return a new hash list based on VHASH where KEY is associated +with VALUE. Use HASH to compute KEY's hash." + (assert-vlist vhash) + ;; We should also assert that it is a hash table. Need to check the + ;; performance impacts of that. Also, vlist-null is a valid hash + ;; table, which does not pass vhash?. A bug, perhaps. + (let* ((vhash (block-cons (cons key value) vhash #t)) + (base (vlist-base vhash)) + (offset (vlist-offset vhash)) + (size (block-size base)) + (khash (hash key size)) + (content (block-content base))) + (block-hash-table-add! content size khash offset) + vhash)) + +(define (vhash-consq key value vhash) + (vhash-cons key value vhash hashq)) +(define (vhash-consv key value vhash) + (vhash-cons key value vhash hashv)) + +(define (%vhash-fold* proc init key vhash equal? hash) + ;; Fold over all the values associated with KEY in VHASH. + (define (visit-block base max-offset result) + (let* ((size (block-size base)) + (content (block-content base)) + (khash (hash key size))) + (let loop ((offset (block-hash-table-ref content size khash)) + (result result)) + (if offset + (loop (block-hash-table-next-offset content size offset) + (if (and (<= offset max-offset) + (equal? key (car (block-ref content offset)))) + (proc (cdr (block-ref content offset)) result) + result)) + (let ((next-block (block-base base))) + (if (> (block-size next-block) 0) + (visit-block next-block (block-offset base) result) + result)))))) + + (assert-vlist vhash) + (if (> (block-size (vlist-base vhash)) 0) + (visit-block (vlist-base vhash) + (vlist-offset vhash) + init) + init)) + +(define* (vhash-fold* proc init key vhash + #:optional (equal? equal?) (hash hash)) + "Fold over all the values associated with KEY in VHASH, with each +call to PROC having the form ‘(proc value result)’, where +RESULT is the result of the previous call to PROC and INIT the +value of RESULT for the first call to PROC." + (%vhash-fold* proc init key vhash equal? hash)) + +(define (vhash-foldq* proc init key vhash) + "Same as ‘vhash-fold*’, but using ‘hashq’ and ‘eq?’." + (%vhash-fold* proc init key vhash eq? hashq)) + +(define (vhash-foldv* proc init key vhash) + "Same as ‘vhash-fold*’, but using ‘hashv’ and ‘eqv?’." + (%vhash-fold* proc init key vhash eqv? hashv)) + +(define (%vhash-assoc key vhash equal? hash) + ;; A specialization of `vhash-fold*' that stops when the first value + ;; associated with KEY is found or when the end-of-list is reached. Inline to + ;; make sure `vhash-assq' gets to use the `eq?' instruction instead of calling + ;; the `eq?' subr. + (define (visit-block base max-offset) + (let* ((size (block-size base)) + (content (block-content base)) + (khash (hash key size))) + (let loop ((offset (block-hash-table-ref content size khash))) + (if offset + (if (and (<= offset max-offset) + (equal? key (car (block-ref content offset)))) + (block-ref content offset) + (loop (block-hash-table-next-offset content size offset))) + (let ((next-block (block-base base))) + (and (> (block-size next-block) 0) + (visit-block next-block (block-offset base)))))))) + + (assert-vlist vhash) + (and (> (block-size (vlist-base vhash)) 0) + (visit-block (vlist-base vhash) + (vlist-offset vhash)))) + +(define* (vhash-assoc key vhash #:optional (equal? equal?) (hash hash)) + "Return the first key/value pair from VHASH whose key is equal to +KEY according to the EQUAL? equality predicate." + (%vhash-assoc key vhash equal? hash)) + +(define (vhash-assq key vhash) + "Return the first key/value pair from VHASH whose key is ‘eq?’ to +KEY." + (%vhash-assoc key vhash eq? hashq)) + +(define (vhash-assv key vhash) + "Return the first key/value pair from VHASH whose key is ‘eqv?’ to +KEY." + (%vhash-assoc key vhash eqv? hashv)) + +(define* (vhash-delete key vhash #:optional (equal? equal?) (hash hash)) + "Remove all associations from VHASH with KEY, comparing keys +with EQUAL?." + (if (vhash-assoc key vhash equal? hash) + (vlist-fold (lambda (k+v result) + (let ((k (car k+v)) + (v (cdr k+v))) + (if (equal? k key) + result + (vhash-cons k v result hash)))) + vlist-null + vhash) + vhash)) + +(define (vhash-delq key vhash) + (vhash-delete key vhash eq? hashq)) +(define (vhash-delv key vhash) + (vhash-delete key vhash eqv? hashv)) + +(define (vhash-fold proc init vhash) + "Fold over the key/pair elements of VHASH from left to right, with +each call to PROC having the form ‘(PROC key value result)’, +where RESULT is the result of the previous call to PROC and +INIT the value of RESULT for the first call to PROC." + (vlist-fold (lambda (key+value result) + (proc (car key+value) (cdr key+value) + result)) + init + vhash)) + +(define (vhash-fold-right proc init vhash) + "Fold over the key/pair elements of VHASH from right to left, with +each call to PROC having the form ‘(PROC key value result)’, +where RESULT is the result of the previous call to PROC and +INIT the value of RESULT for the first call to PROC." + (vlist-fold-right (lambda (key+value result) + (proc (car key+value) (cdr key+value) + result)) + init + vhash)) + +(define* (alist->vhash alist #:optional (hash hash)) + "Return the vhash corresponding to ALIST, an association list." + (fold-right (lambda (pair result) + (vhash-cons (car pair) (cdr pair) result hash)) + vlist-null + alist)) + +;;; vlist.scm ends here diff --git a/modules/math.scm b/modules/math.scm index 2f8c4f9..d1f6529 100644 --- a/modules/math.scm +++ b/modules/math.scm @@ -18,21 +18,6 @@ ;;; ;;; Code: -;; (library (math) -;; (export random -;; clamp) -;; (import (scheme base) -;; (hoot ffi)) - -;; (define-foreign random -;; "math" "random" -;; -> f64) - -;; (define (clamp x min max) -;; (cond ((< x min) min) -;; ((> x max) max) -;; (else x)))) - (define-module (math) #:pure #:use-module (scheme base)