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

Don't bother rewriting references if no source was provided, introduce binary format

parent 514a715f
(in-package :netfarm)
(defun read-integer (function)
(let ((byte-count (funcall function))
(accumulator 0))
(dotimes (n byte-count)
(setf accumulator
(logior (funcall function)
(ash accumulator 8))))
(defgeneric binary-parse-from-type-tag (type-tag function)
(:method ((tag (eql 1)) function)
(let* ((byte-length (read-integer function))
(bytes (make-array byte-length :element-type '(unsigned-byte 8))))
(dotimes (n byte-length)
(setf (aref bytes n)
(funcall function)))
(babel:octets-to-string bytes :encoding :utf-8)))
(:method ((tag (eql 2)) function)
(let* ((vector-length (read-integer function))
(vector (make-array vector-length :element-type '(unsigned-byte 8))))
(dotimes (n byte-length)
(setf (aref vector n)
(funcall function)))
(:method ((tag (eql 3)) function)
(read-integer function))
(:method ((tag (eql 4)) function)
(let ((integer (read-integer function)))
(if (zerop integer)
(error "Don't use the negative-integer tag for zeroes")
(- integer))))
(:method ((tag (eql 5)) function)
(let ((length (read-integer function)))
(loop repeat length
collect (binary-parse-from-function function))))
(:method ((tag (eql 6)) function)
(let ((hash (make-array 32 :element-type '(unsigned-byte 8))))
(dotimes (n 32)
(setf (aref hash n) (funcall function)))
(make-instance 'reference :hash hash))))
(defun binary-parse-from-function (function)
(binary-parse-from-type-tag (funcall function) function))
(defun binary-parse (function-or-vector)
(if (vectorp function-or-vector)
(let ((position 0)
(vector function-or-vector))
(lambda ()
(prog1 (aref vector position)
(incf position)))))
(binary-parse-from-function function-or-vector)))
(in-package :netfarm)
(defun write-integer (integer function)
(let ((byte-count (ceiling (integer-length integer) 8)))
(assert (< byte-count 256))
(flet ((get-byte (n)
(ldb (byte 8 (* n 8)) integer)))
(funcall function (vector byte-count))
(loop with buffer = (make-array byte-count
:element-type '(unsigned-byte 8))
for byte-position from (1- byte-count) downto 0
for buffer-position from 0
do (setf (aref buffer buffer-position)
(get-byte byte-position))
finally (funcall function buffer)))))
(defun write-type-tag (tag function)
(funcall function (vector tag)))
(defgeneric binary-render-to-function (object function)
(:method ((s string) function)
(let ((bytes (babel:string-to-octets s :encoding :utf-8)))
(write-type-tag 1 function)
(write-integer (length bytes) function)
(funcall function bytes)))
(:method ((v vector) function)
(write-type-tag 2 function)
(write-integer (length v) function)
(funcall function v))
(:method ((i integer) function)
(write-type-tag (if (minusp i) 4 3)
(write-integer (abs i) function))
(:method ((l list) function)
(write-type-tag 5 function)
(write-integer (length l) function)
(dolist (element l)
(binary-render-to-function element function)))
(:method ((r reference) function)
(write-type-tag 6 function)
(funcall function (reference-hash function))))
(defun binary-render (object &optional function)
(if (null function)
(flexi-streams:with-output-to-sequence (s)
(binary-render-to-function object (lambda (bytes)
(write-sequence bytes s))))
(binary-render-to-function object function)))
......@@ -33,7 +33,8 @@
(defun maybe-rewrite-graph (object graph-cons)
(when (and (not (car graph-cons))
(rewrite-graph (cdr graph-cons) (object-source object))
(unless (null (object-source object))
(rewrite-graph (cdr graph-cons) (object-source object)))
(setf (car graph-cons) t))
(cdr graph-cons))
......@@ -49,9 +49,9 @@
(incf cons-count (length signatures))
(mapcar #'car signatures)))
(define-opcode 135 send ((:capabilities capabilities
:side-effects side-effects)
target message)
(define-opcode* 135 send ((:capabilities capabilities
:side-effects side-effects)
target message)
(if (member :send capabilities)
(push (list 'send :target target
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