Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
7
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Open sidebar
Hayley Patton
netfarm
Commits
dfef9224
Commit
dfef9224
authored
Feb 03, 2020
by
Hayley Patton
🐢
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Put loop into discriminator function, and add 'checkpointing' to objects
parent
42f05e78
Changes
6
Hide whitespace changes
Inline
Side-by-side
Showing
6 changed files
with
79 additions
and
52 deletions
+79
-52
Code/Objects/checkpointing.lisp
Code/Objects/checkpointing.lisp
+16
-0
Code/Objects/mop.lisp
Code/Objects/mop.lisp
+3
-1
Code/Scripts/discriminator-function.lisp
Code/Scripts/discriminator-function.lisp
+24
-15
Code/Scripts/script-machine.lisp
Code/Scripts/script-machine.lisp
+33
-34
Code/netfarm.asd
Code/netfarm.asd
+2
-1
Code/package.lisp
Code/package.lisp
+1
-1
No files found.
Code/Objects/checkpointing.lisp
0 → 100644
View file @
dfef9224
(
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
)))
Code/Objects/mop.lisp
View file @
dfef9224
...
...
@@ -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
))
...
...
Code/Scripts/discriminator-function.lisp
View file @
dfef9224
...
...
@@ -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"
))))))))
Code/Scripts/script-machine.lisp
View file @
dfef9224
...
...
@@ -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-by
te
*
interpreter
)
)))
(
unless
(
null
opcode-info
)
(
format
t
"(~a"
(
first
opcode-info
))
(
l
oop
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-coun
te
r
interpreter
)
:data
,
(
interpreter-data-stack
interpreter
)
:env
,
(
interpreter-environment
interpreter
))
))
(
l
et
((
opcode-info
(
aref
*opcode-data*
(
interpreter-read-byte*
interpreter
)))
)
(
unless
(
null
opcode-info
)
(
for
mat
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
)
...
...
Code/netfarm.asd
View file @
dfef9224
...
...
@@ -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"
)))
...
...
Code/package.lisp
View file @
dfef9224
...
...
@@ -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
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment