Commit dfef9224 authored by  Hayley Patton's avatar Hayley Patton 🐢

Put loop into discriminator function, and add 'checkpointing' to objects

parent 42f05e78
(in-package :netfarm)
;;; A kind of "checkpointing" system where we can ask if an object has been
;;; updated since it was last saved, and update the last hash it had when it
;;; gets updated.
(defun object-changed-p (object)
(check-type object object)
(or (null (object-last-hash object))
(some #'/=
(hash-object object)
(object-last-hash object))))
(defun object-set-checkpoint (object)
(setf (object-last-hash object)
(hash-object object)))
......@@ -39,7 +39,9 @@
((signatures :initarg :signatures :initform nil :accessor object-signatures)
(metadata :initform (mht) :initarg :metadata :reader object-metadata)
(computed-values :initform (mht) :reader object-computed-values-table)
(source :initarg :source :initform nil :accessor object-source))))
(source :initarg :source :initform nil :accessor object-source)
(last-hash :initform nil
:accessor object-last-hash))))
(defmethod closer-mop:class-direct-superclasses ((class netfarm-class))
(append (remove (find-class 'standard-object) (call-next-method))
......
......@@ -6,7 +6,8 @@
;;; This dispatch is expected to be faster on machines with slower memory than
;;; registers; as it replaces one table lookup with binary search that can be
;;; performed entirely in a register set.
;;; performed entirely in a register set. It also avoids a couple of function
;;; calls per cycle, which yields very impressive performance gains.
(defvar *discriminator-function* nil)
(defun ensure-discriminator-function ()
......@@ -42,17 +43,25 @@
(defun make-discriminator-function ()
(compile nil
`(lambda (interpreter)
(declare (optimize (speed 3) (safety 1))
(interpreter interpreter))
(let ((opcode (aref (interpreter-program interpreter)
(interpreter-program-counter interpreter))))
(declare ((unsigned-byte 8) opcode))
(incf (interpreter-instruction-count interpreter))
(incf (interpreter-program-counter interpreter))
(tagbody
,(make-discriminator-parts *operators* 0 256)
lose
(error "illegal opcode ~d on ~s"
opcode interpreter)
out)))))
`(lambda (interpreter cons-limit cycle-limit)
(declare (optimize (speed 3) (safety 1))
(interpreter interpreter)
((or null fixnum) cons-limit cycle-limit))
(loop
(let ((opcode (aref (interpreter-program interpreter)
(interpreter-program-counter interpreter))))
(declare ((unsigned-byte 8) opcode))
(incf (interpreter-instruction-count interpreter))
(incf (interpreter-program-counter interpreter))
(tagbody
,(make-discriminator-parts *operators* 0 256)
lose
(error "illegal opcode ~d on ~s"
opcode interpreter)
out
(when (and (not (null cons-limit))
(> (interpreter-cons-count interpreter) cons-limit))
(error "exceeded cons limit"))
(when (and (not (null cycle-limit))
(> (interpreter-instruction-count interpreter) cycle-limit))
(error "exceeded cycle limit"))))))))
......@@ -100,43 +100,42 @@
(declare (interpreter interpreter)
((or null fixnum) cons-limit cycle-limit)
(boolean print-cycles step))
#+netfarm-discriminator-function (ensure-discriminator-function)
(ensure-discriminator-function)
(let (#+netfarm-profiling
(opcode-count-table (make-hash-table))
#+netfarm-discriminator-function (discriminator-function *discriminator-function*)
#-netfarm-discriminator-function (operators *operators*))
#+netfarm-discriminator-function
(declare ((function (interpreter) t) discriminator-function))
(discriminator-function *discriminator-function*)
(operators *operators*))
(declare ((function (interpreter t t) t) discriminator-function))
(handler-case
(loop
#+netfarm-profiling
(incf (gethash (first (aref *opcode-data* (interpreter-read-byte* interpreter))) opcode-count-table 0))
(when print-cycles
(let ((*print-circle* t))
(print
`(:pc ,(interpreter-program-counter interpreter)
:data ,(interpreter-data-stack interpreter)
:env ,(interpreter-environment interpreter))))
(let ((opcode-info (aref *opcode-data* (interpreter-read-byte* interpreter))))
(unless (null opcode-info)
(format t "(~a" (first opcode-info))
(loop for byte-name in (third opcode-info)
for offset from 1
for value = (interpreter-read-byte* interpreter offset)
do (format t " :~a ~d" byte-name value))
(format t ")~%"))))
#+netfarm-discriminator-function
(funcall discriminator-function interpreter)
#-netfarm-discriminator-function
(step-interpreter interpreter operators)
(when (and cons-limit
(> (interpreter-cons-count interpreter) cons-limit))
(error "exceeded cons limit"))
(when (and cycle-limit
(> (interpreter-instruction-count interpreter) cycle-limit))
(error "exceeded cycle limit"))
(when step
(read-line)))
(if (and (not print-cycles) (not step))
(funcall discriminator-function interpreter cons-limit cycle-limit)
(loop
#+netfarm-profiling
(incf (gethash (first (aref *opcode-data* (interpreter-read-byte* interpreter)))
opcode-count-table 0))
(when print-cycles
(let ((*print-circle* t))
(print
`(:pc ,(interpreter-program-counter interpreter)
:data ,(interpreter-data-stack interpreter)
:env ,(interpreter-environment interpreter))))
(let ((opcode-info (aref *opcode-data* (interpreter-read-byte* interpreter))))
(unless (null opcode-info)
(format t "(~a" (first opcode-info))
(loop for byte-name in (third opcode-info)
for offset from 1
for value = (interpreter-read-byte* interpreter offset)
do (format t " :~a ~d" byte-name value))
(format t ")~%"))))
(step-interpreter interpreter operators)
(when (and (not (null cons-limit))
(> (interpreter-cons-count interpreter) cons-limit))
(error "exceeded cons limit"))
(when (and (not (null cycle-limit))
(> (interpreter-instruction-count interpreter) cycle-limit))
(error "exceeded cycle limit"))
(when step
(read-line))))
(done ()
(return-from run-interpreter
(values (interpreter-data-stack interpreter)
......
......@@ -17,7 +17,8 @@
(:file "objects")
(:file "schema")
(:file "type-specifiers")
(:file "inbuilt-schemas")))
(:file "inbuilt-schemas")
(:file "checkpointing")))
(:module "Text-format"
:components ((:file "new-parser")
(:file "new-renderer")))
......
......@@ -32,7 +32,7 @@
#:object-signatures
#:object-metadata #:object-computed-values
#:object-source
#:object-changed-p #:object-set-checkpoint
#:slot-name #:slot-reader-type
#:reference-hash
;; schema
......
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