Commit 2e74e84e authored by  Hayley Patton's avatar Hayley Patton 🐢

Add a reference implementation of side effects, muffle SBCL compiler notes

parent 8e994ec4
......@@ -20,7 +20,8 @@
(inline hash-string))
(defun hash-string (string)
(declare (optimize (speed 3)))
(declare (optimize (speed 3))
#+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note))
(loop with accumulator of-type string-hash-table-index = 0
for char of-type character across string
do (setf accumulator
......@@ -54,7 +55,8 @@
(values nil nil))
(defun string-gethash (table key)
(declare (optimize (speed 3) (debug 1)))
(declare (optimize (speed 3) (debug 1))
#+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note))
(%search-hash table (hash-string key) key))
(define-compiler-macro string-gethash (&whole whole table key)
......@@ -66,6 +68,7 @@
(setf string-gethash))
(inline (setf string-gethash)))
(defun (setf string-gethash) (value table key)
#+sbcl (declare (sb-ext:muffle-conditions sb-ext:compiler-note))
(push (cons (copy-seq key) value)
(aref table (hash-string key)))
(in-package :netfarm-scripts)
(defgeneric apply-side-effect (cause target type &key &allow-other-keys)
(:method (cause target (type (eql 'add-computed-value)) &key name value)
(push (make-instance 'computed-value :cause cause
:value value)
(object-computed-values target name))))
(in-package :netfarm-scripts)
(defvar *initialization-script-instruction-limit* 100000)
(defvar *message-script-instruction-limit* 10000)
(defgeneric filter-effect-against (filter type &key &allow-other-keys)
(:documentation "Is this message provided allowed by the filter and by Netfarm messaging rules?")
(:method (filter (type (eql 'send)) &key target message)
(declare (ignore message))
;; Targets also have to be objects and have to have message scripts.
(and (typep target 'object)
(not (null (netfarm-class-message-script
(class-of target))))
(funcall filter target))))
(defun apply-recipient-filter (effects filter)
"Keep all effects allowed by the filter."
(remove-if-not (lambda (effect)
(apply #'filter-effect-against filter effect))
(defun accumulate-messages (object &key (recipient-filter (constantly t)))
(let ((scripts (netfarm-class-scripts (class-of object)))
(accumulated-messages '()))
(dolist (script scripts)
(multiple-value-bind (stack interpreter)
(run-interpreter (setup-interpreter script
(list object)
(declare (ignore stack))
(setf accumulated-messages
(append (apply-recipient-filter (interpreter-side-effects interpreter)
(defgeneric make-message-interpreter (cause type &key &allow-other-keys)
(:method (cause (type (eql 'send)) &key target message)
(values target
(setup-interpreter (netfarm-class-message-script (class-of target))
(list target cause message)
(defun accumulate-side-effects (cause messages)
"Create a hash table of objects and the side effects their scripts create."
(let ((side-effect-table (make-hash-table)))
(dolist (message messages)
(multiple-value-bind (target interpreter)
(apply #'make-message-interpreter cause message)
(multiple-value-bind (stack interpreter)
(run-interpreter interpreter
:cons-limit *message-script-instruction-limit*
:cycle-limit *message-script-instruction-limit*)
(declare (ignore stack))
(setf (gethash target side-effect-table)
(append (interpreter-side-effects interpreter)
(gethash target side-effect-table))))))
(defun run-script-machines (object &key (apply-side-effects t)
(recipient-filter (constantly t)))
(check-type object object)
(let* ((accumulated-messages (accumulate-messages object
:recipient-filter recipient-filter))
(side-effects (accumulate-side-effects object accumulated-messages)))
(when apply-side-effects
(maphash (lambda (target effects)
(dolist (effect effects)
(apply #'apply-side-effect object target effect)))
(values accumulated-messages side-effects)))
(in-package :netfarm-scripts)
(in-package :netfarm-scripts)
(declaim (inline call-function make-frame))
(defun call-function (interpreter function argument-count &key (save-current t))
......@@ -17,8 +17,12 @@
(define-opcode 64 cons ((:cons-count cons-count) first rest) ()
(incf cons-count)
(kons first rest))
(define-function-opcode 65 car 1)
(define-function-opcode 66 cdr 1)
(define-opcode 65 car (() cons) ()
(check-type cons cons)
(car cons))
(define-opcode 66 cdr (() cons) ()
(check-type cons cons)
(cdr cons))
(define-function-opcode 67 (boolean-wrap null 1) 1 :opcode-name null)
(define-function-opcode 68 consp 1)
(define-opcode 69 append ((:cons-count cons-count) list1 list2) ()
(in-package :netfarm-scripts)
;;; Control flow
;;; 08: (return) --
(define-opcode* 8 return (interpreter) ()
(when (null (interpreter-call-stack interpreter))
(error "(return) with nowhere to return to"))
(destructuring-bind (old-environment old-pc)
(pop (interpreter-call-stack interpreter))
(setf (interpreter-environment interpreter) old-environment
(interpreter-program-counter interpreter) old-pc))
(when (null (interpreter-call-stack interpreter))
(signal 'done)))
(declaim (inline make-frame))
(defun make-frame (interpreter frame-size)
(let ((frame (make-array frame-size)))
(dotimes (n frame-size)
(when (null (interpreter-data-stack interpreter))
(error "out of data when creating frame"))
(setf (aref frame n)
(pop (interpreter-data-stack interpreter))))
(defun call-function (interpreter function argument-count &key (save-current t))
(check-type function procedure)
(assert (= argument-count (procedure-arguments function)) ()
"wanted ~d argument~:p but got ~d"
(procedure-arguments function) argument-count)
(when save-current
(push (list (interpreter-environment interpreter)
(interpreter-program-counter interpreter))
(interpreter-call-stack interpreter)))
(setf (interpreter-environment interpreter)
(cons (make-frame interpreter argument-count)
(procedure-environment function))
(interpreter-program-counter interpreter)
(procedure-entry-point function)))
;;; 09: (call n) arg-1 ... arg-n function --
(define-opcode* 9 call (interpreter function) (n)
(incf (interpreter-cons-count interpreter) n)
(call-function interpreter function n))
;;; 0A: (tail-call n) arg-1 ... arg-n function --
;;; Similar to CALL, but doesn't back up the last state on the stack. This is
;;; therefore only good for tail-calls. It's really good at those though.
(define-opcode* 10 tail-call (interpreter function) (n)
(pop (interpreter-environment interpreter))
(call-function interpreter function n :save-current nil))
(declaim (inline u8-pair->u16))
(defun u8-pair->u16 (high low)
(logior (ash high 8)
;;; 10: (cond-jump then-high then-low else-high else-low) test-value --
;;; Let then = then-high * 256 + then-low,
;;; else = else-high * 256 + else-low
;;; Jump forwards `then` bytes if test-value is true, else jump forwards `else`
;;; bytes.
(define-opcode* 16 jump-cond (interpreter test-value)
(then-high then-low else-high else-low)
(let ((then (u8-pair->u16 then-high then-low))
(else (u8-pair->u16 else-high else-low)))
(if (eql test-value :false)
(incf (interpreter-program-counter interpreter) else)
(incf (interpreter-program-counter interpreter) then))))
(define-opcode* 17 jump (interpreter) (high low)
(incf (interpreter-program-counter interpreter)
(u8-pair->u16 high low)))
;;; 18: (error) message cause --
(define-opcode* 24 error (interpreter message cause) ()
(error 'script-machine-error :message message :cause cause))
......@@ -5,4 +5,5 @@
#:interpreter-instruction-count #:interpreter-cons-count
#:run-interpreter #:setup-interpreter
#:add-computed-value #:send
#:add-object-to-interpreter #:get-object #:get-object-name))
#:add-object-to-interpreter #:get-object #:get-object-name
......@@ -41,7 +41,10 @@
(:file "forthisms")
(:file "objects")
(:file "assemble")
(:file "define-script")))))
(:file "define-script")))
(:module "Reference-side-effects"
:components ((:file "apply-side-effect")
(:file "run-scripts")))))
(:file "Objects/inbuilt-schemas" :depends-on ("Objects"))
(:module "Text-format"
:depends-on ("Codecs" "Objects")
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment