Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
netfarm
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
0
Issues
0
List
Boards
Labels
Service Desk
Milestones
Merge Requests
0
Merge Requests
0
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Operations
Operations
Incidents
Environments
Analytics
Analytics
CI / CD
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
Hayley Patton
netfarm
Commits
c2974e5e
Commit
c2974e5e
authored
Mar 19, 2020
by
Hayley Patton
🐢
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Speed up the script machine a bunch
parent
764f45ea
Changes
5
Hide whitespace changes
Inline
Side-by-side
Showing
5 changed files
with
100 additions
and
95 deletions
+100
-95
Code/Scripts/Script-machine/case-discriminator-function.lisp
Code/Scripts/Script-machine/case-discriminator-function.lisp
+23
-45
Code/Scripts/Script-machine/control-flow.lisp
Code/Scripts/Script-machine/control-flow.lisp
+18
-18
Code/Scripts/Script-machine/discriminator-function.lisp
Code/Scripts/Script-machine/discriminator-function.lisp
+39
-20
Code/Scripts/Script-machine/environments.lisp
Code/Scripts/Script-machine/environments.lisp
+1
-3
Code/Scripts/Script-machine/script-machine.lisp
Code/Scripts/Script-machine/script-machine.lisp
+19
-9
No files found.
Code/Scripts/Script-machine/case-discriminator-function.lisp
View file @
c2974e5e
...
@@ -3,48 +3,26 @@
...
@@ -3,48 +3,26 @@
;;; scymtym suggested SBCL's CASE might be faster now as it uses perfect
;;; scymtym suggested SBCL's CASE might be faster now as it uses perfect
;;; hashing and a jump table to dispatch.
;;; hashing and a jump table to dispatch.
;;; This is a hair slower than
(
defun
make-discriminator-parts
(
operator-table
start
end
)
`
(
case
opcode
(
defun
make-discriminator-parts
(
operator-table
)
.
,
(
loop
for
position
from
start
below
end
(
loop
for
operator
across
operator-table
for
operator
=
(
aref
operator-table
position
)
for
position
from
0
collect
collect
`
(
,
position
`
(
,
position
,
(
if
(
null
(
aref
*opcode-code*
position
))
,
(
if
(
eq
operator
(
aref
operator-table
255
))
`
(
go
lose
)
`
(
go
lose
)
(
destructuring-bind
((
parts
inputs
bytes
)
declarations
body
)
(
destructuring-bind
((
interpreter
inputs
bytes
)
declarations
body
)
(
aref
*opcode-code*
position
)
(
aref
*opcode-code*
position
)
`
(
with-interpreter-parts-renamed
(
data-stack
%%data-stack
`
(
let
((
,
interpreter
interpreter
))
program-counter
%%program-counter
(
let
(
,@
(
loop
for
input
in
(
reverse
inputs
)
program
%%program
collect
`
(
,
input
(
pop*
(
interpreter-data-stack
,
interpreter
))))
.
,
parts
)
,@
(
loop
for
byte
in
bytes
(
let
(
,@
(
loop
for
input
in
(
reverse
inputs
)
collect
`
(
,
byte
(
interpreter-read-byte
,
interpreter
))))
collect
`
(
,
input
(
pop*
%%data-stack
)))
,@
declarations
,@
(
loop
for
byte
in
bytes
,
body
for
position
from
0
(
go
out
))))))))
collect
`
(
,
byte
(
aref
%%program
(
+
,
position
%%program-counter
)))))
,@
declarations
(
defun
make-discriminator-function
()
(
incf
%%program-counter
,
(
length
bytes
))
; (compile nil
,
body
`
(
lambda
(
interpreter
cons-limit
cycle-limit
)
(
go
out
)))))))))
(
declare
(
optimize
(
speed
3
)
(
safety
1
))
(
interpreter
interpreter
)
((
or
null
fixnum
)
cons-limit
cycle-limit
)
#+
sbcl
(
sb-ext:muffle-conditions
sb-ext:compiler-note
))
(
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
(
case
opcode
.
,
(
make-discriminator-parts
*operators*
))
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/control-flow.lisp
View file @
c2974e5e
(
in-package
:netfarm-scripts
)
(
in-package
:netfarm-scripts
)
(
declaim
(
inline
call-function
))
(
declaim
(
inline
call-function
make-frame
))
(
defun
call-function
(
interpreter
function
argument-count
&key
(
save-current
t
))
(
defun
call-function
(
interpreter
function
argument-count
&key
(
save-current
t
))
(
check-type
function
procedure
)
(
check-type
function
procedure
)
(
assert
(
=
argument-count
(
procedure-arguments
function
))
()
(
assert
(
=
argument-count
(
procedure-arguments
function
))
()
"wanted ~d argument~:p but got ~d"
"wanted ~d argument~:p but got ~d"
(
procedure-arguments
function
)
argument-count
)
(
procedure-arguments
function
)
argument-count
)
(
when
save-current
(
when
save-current
(
push
(
list
(
interpreter-environment
interpreter
)
(
push
(
vector
(
interpreter-environment
interpreter
)
(
interpreter-program-counter
interpreter
))
(
interpreter-program-counter
interpreter
))
(
interpreter-call-stack
interpreter
)))
(
interpreter-call-stack
interpreter
)))
(
setf
(
interpreter-environment
interpreter
)
(
setf
(
interpreter-environment
interpreter
)
(
cons
(
make-frame
interpreter
argument-count
)
(
cons
(
make-frame
interpreter
argument-count
)
...
@@ -16,20 +16,6 @@
...
@@ -16,20 +16,6 @@
(
interpreter-program-counter
interpreter
)
(
interpreter-program-counter
interpreter
)
(
procedure-entry-point
function
)))
(
procedure-entry-point
function
)))
;;; Control flow
;;; 08: (return) --
(
define-opcode*
8
return
((
:call-stack
call-stack
:environment
environment
:program-counter
program-counter
))
()
(
when
(
null
call-stack
)
(
error
"(return) with nowhere to return to"
))
(
destructuring-bind
(
old-environment
old-pc
)
(
pop
call-stack
)
(
setf
environment
old-environment
program-counter
old-pc
))
(
when
(
null
call-stack
)
(
signal
'done
)))
(
declaim
(
inline
make-frame
))
(
defun
make-frame
(
interpreter
frame-size
)
(
defun
make-frame
(
interpreter
frame-size
)
(
let
((
frame
(
make-array
frame-size
)))
(
let
((
frame
(
make-array
frame-size
)))
(
dotimes
(
n
frame-size
)
(
dotimes
(
n
frame-size
)
...
@@ -39,6 +25,20 @@
...
@@ -39,6 +25,20 @@
(
pop
(
interpreter-data-stack
interpreter
))))
(
pop
(
interpreter-data-stack
interpreter
))))
frame
))
frame
))
;;; Control flow
;;; 08: (return) --
(
define-opcode*
8
return
((
:call-stack
call-stack
:environment
environment
:program-counter
program-counter
))
()
(
when
(
null
call-stack
)
(
error
"(return) with nowhere to return to"
))
(
let
((
last-frame
(
pop
call-stack
)))
(
locally
(
declare
(
optimize
(
safety
0
)
(
speed
3
))))
(
setf
environment
(
svref
last-frame
0
)
program-counter
(
svref
last-frame
1
)))
(
when
(
null
call-stack
)
(
signal
'done
)))
;;; 09: (call n) arg-1 ... arg-n function --
;;; 09: (call n) arg-1 ... arg-n function --
(
define-opcode*
9
call
((
:cons-count
cons-count
:data-stack
data-stack
(
define-opcode*
9
call
((
:cons-count
cons-count
:data-stack
data-stack
:call-stack
call-stack
:call-stack
call-stack
...
@@ -51,7 +51,7 @@
...
@@ -51,7 +51,7 @@
(
assert
(
=
argument-count
(
procedure-arguments
function
))
()
(
assert
(
=
argument-count
(
procedure-arguments
function
))
()
"wanted ~d argument~:p but got ~d"
"wanted ~d argument~:p but got ~d"
(
procedure-arguments
function
)
argument-count
)
(
procedure-arguments
function
)
argument-count
)
(
push
(
list
environment
program-counter
)
call-stack
)
(
push
(
vector
environment
program-counter
)
call-stack
)
(
let
((
new-frame
(
make-array
argument-count
)))
(
let
((
new-frame
(
make-array
argument-count
)))
(
dotimes
(
n
argument-count
)
(
dotimes
(
n
argument-count
)
(
when
(
null
data-stack
)
(
when
(
null
data-stack
)
...
...
Code/Scripts/Script-machine/discriminator-function.lisp
View file @
c2974e5e
...
@@ -22,15 +22,16 @@
...
@@ -22,15 +22,16 @@
collect
`
(
,
variable
,
new-name
))
collect
`
(
,
variable
,
new-name
))
,@
body
))
,@
body
))
(
defun
make-discriminator-parts
(
operator-table
start
end
)
(
defun
make-discriminator-parts
(
opcodes
)
(
declare
(
fixnum
start
end
))
(
cond
(
cond
((
=
start
(
1-
end
))
((
null
opcodes
)
(
let
((
operator
(
aref
operator-table
start
)))
(
error
"no opcodes to dispatch on?"
))
(
if
(
eq
operator
(
aref
operator-table
255
))
((
null
(
rest
opcodes
))
`
(
go
lose
)
(
destructuring-bind
(
opcode
)
opcodes
(
if
(
null
(
aref
*opcode-code*
opcode
))
`
(
go
lose
)
(
destructuring-bind
((
parts
inputs
bytes
)
declarations
body
)
(
destructuring-bind
((
parts
inputs
bytes
)
declarations
body
)
(
aref
*opcode-code*
start
)
(
aref
*opcode-code*
opcode
)
`
(
with-interpreter-parts-renamed
(
data-stack
%%data-stack
`
(
with-interpreter-parts-renamed
(
data-stack
%%data-stack
program-counter
%%program-counter
program-counter
%%program-counter
program
%%program
program
%%program
...
@@ -44,15 +45,29 @@
...
@@ -44,15 +45,29 @@
(
incf
%%program-counter
,
(
length
bytes
))
(
incf
%%program-counter
,
(
length
bytes
))
,
body
,
body
(
go
out
)))))))
(
go
out
)))))))
((
every
(
lambda
(
x
)
(
eq
x
(
aref
operator-table
255
)))
((
every
(
lambda
(
opcode
)
(
subseq
operator-table
start
end
))
(
null
(
aref
*opcode-code*
opcode
)))
opcodes
)
'
(
go
lose
))
'
(
go
lose
))
(
t
(
t
(
let
((
middle
(
floor
(
+
start
end
)
2
)))
(
let*
((
middle
(
floor
(
length
opcodes
)
2
))
`
(
progn
(
middle-element
(
nth
middle
opcodes
)))
(
if
(
<
opcode
,
middle
)
`
(
if
(
<
opcode
,
middle-element
)
,
(
make-discriminator-parts
operator-table
start
middle
)
,
(
make-discriminator-parts
(
subseq
opcodes
0
middle
))
,
(
make-discriminator-parts
operator-table
middle
end
)))))))
,
(
make-discriminator-parts
(
subseq
opcodes
middle
)))))))
(
defun
make-discriminator-code
()
(
labels
((
in-bounds?
(
opcode
)
(
<=
0
opcode
255
))
(
exists?
(
opcode
)
(
and
(
in-bounds?
opcode
)
(
not
(
null
(
aref
*opcode-code*
opcode
)))))
(
needed?
(
opcode
)
(
or
(
exists?
opcode
)
(
exists?
(
1+
opcode
))
(
exists?
(
1-
opcode
)))))
(
make-discriminator-parts
(
loop
for
opcode
below
256
when
(
needed?
opcode
)
collect
opcode
))))
(
defmacro
let-interpreter-parts
((
&rest
names
)
&body
body
)
(
defmacro
let-interpreter-parts
((
&rest
names
)
&body
body
)
`
(
let
,
(
loop
for
name
in
names
`
(
let
,
(
loop
for
name
in
names
...
@@ -70,10 +85,11 @@
...
@@ -70,10 +85,11 @@
interpreter
)
interpreter
)
,
name
))))
,
name
))))
(
defun
make-discriminator-function
(
&key
(
top
256
)
)
(
defun
make-discriminator-function
()
(
compile
nil
(
compile
nil
`
(
lambda
(
interpreter
cons-limit
cycle-limit
)
`
(
lambda
(
interpreter
cons-limit
cycle-limit
)
(
declare
(
optimize
(
speed
3
)
(
safety
1
))
(
declare
(
optimize
(
speed
3
)
(
safety
1
)
(
debug
0
))
(
interpreter
interpreter
)
(
interpreter
interpreter
)
((
or
null
fixnum
)
cons-limit
cycle-limit
)
((
or
null
fixnum
)
cons-limit
cycle-limit
)
#+
sbcl
(
sb-ext:muffle-conditions
sb-ext:compiler-note
))
#+
sbcl
(
sb-ext:muffle-conditions
sb-ext:compiler-note
))
...
@@ -82,11 +98,14 @@
...
@@ -82,11 +98,14 @@
environment
environment
entry-points
side-effects
capabilities
entry-points
side-effects
capabilities
instruction-count
cons-count
)
instruction-count
cons-count
)
(
declare
(
reasonably-sized-natural
program-counter
)
(
declare
(
reasonably-sized-natural
program-counter
((
unsigned-byte
30
)
instruction-count
cons-count
)
instruction-count
cons-count
)
(
list
environment
side-effects
capabilities
(
list
environment
side-effects
capabilities
call-stack
data-stack
)
call-stack
data-stack
)
((
simple-array
(
unsigned-byte
8
)
(
*
))
program
))
((
simple-array
(
unsigned-byte
8
)
(
*
))
program
)
((
simple-array
t
(
*
))
variables
)
((
simple-array
procedure-description
(
*
))
entry-points
))
(
unwind-protect
(
unwind-protect
(
loop
(
loop
(
let
((
opcode
(
aref
program
program-counter
)))
(
let
((
opcode
(
aref
program
program-counter
)))
...
@@ -94,7 +113,7 @@
...
@@ -94,7 +113,7 @@
(
incf
instruction-count
)
(
incf
instruction-count
)
(
incf
program-counter
)
(
incf
program-counter
)
(
tagbody
(
tagbody
,
(
make-discriminator-
parts
*operators*
0
top
)
,
(
make-discriminator-
code
)
lose
lose
(
error
"illegal opcode ~d on ~s"
(
error
"illegal opcode ~d on ~s"
opcode
interpreter
)
opcode
interpreter
)
...
...
Code/Scripts/Script-machine/environments.lisp
View file @
c2974e5e
...
@@ -15,9 +15,7 @@
...
@@ -15,9 +15,7 @@
;;; still consume space. get-proc* in a way is to get-proc as tail-call is to call.
;;; still consume space. get-proc* in a way is to get-proc as tail-call is to call.
(
define-opcode
6
get-proc*
((
:entry-points
entry-points
))
(
n
)
(
define-opcode
6
get-proc*
((
:entry-points
entry-points
))
(
n
)
(
let
((
description
(
aref
entry-points
n
)))
(
let
((
description
(
aref
entry-points
n
)))
(
make-procedure
:entry-point
(
procedure-description-entry-point
description
)
(
procedure-description-static-procedure
description
)))
:arguments
(
procedure-description-arguments
description
)
:environment
'
())))
;;; 02: (get-value n) -- value
;;; 02: (get-value n) -- value
(
define-opcode
2
get-value
((
:variables
variables
))
(
n
)
(
define-opcode
2
get-value
((
:variables
variables
))
(
n
)
...
...
Code/Scripts/Script-machine/script-machine.lisp
View file @
c2974e5e
...
@@ -9,27 +9,32 @@
...
@@ -9,27 +9,32 @@
(
deftype
reasonably-sized-natural
()
(
deftype
reasonably-sized-natural
()
"Well, I hope this is a subset of the implementation's FIXNUM type. But still."
"Well, I hope this is a subset of the implementation's FIXNUM type. But still."
'
(
unsigned-byte
2
0
))
'
(
unsigned-byte
3
0
))
(
declaim
(
inline
make-procedure
))
(
declaim
(
inline
make-procedure
))
(
defstruct
procedure
(
defstruct
procedure
(
entry-point
0
:type
reasonably-sized-natural
)
(
entry-point
0
:type
reasonably-sized-natural
)
(
arguments
0
:type
reasonably-sized-natural
)
(
arguments
0
:type
reasonably-sized-natural
)
environment
)
(
environment
'
()
:type
list
)
)
(
defstruct
procedure-description
(
defstruct
procedure-description
(
entry-point
0
:type
reasonably-sized-natural
)
(
entry-point
0
:type
reasonably-sized-natural
)
(
arguments
0
:type
reasonably-sized-natural
))
(
arguments
0
:type
reasonably-sized-natural
)
(
static-procedure
(
make-procedure
:entry-point
0
:arguments
0
:environment
'
())
:type
procedure
))
(
defstruct
interpreter
(
defstruct
interpreter
;; Program state
;; Program state
(
script
'
()
:read-only
t
)
(
script
nil
:read-only
t
)
(
program-counter
0
:type
reasonably-sized-natural
)
(
program-counter
0
:type
reasonably-sized-natural
)
(
variables
#(
)
:read-only
t
)
(
variables
#(
)
:
type
(
simple-array
t
(
*
))
:
read-only
t
)
(
program
(
make-array
0
:element-type
'
(
unsigned-byte
8
))
(
program
(
make-array
0
:element-type
'
(
unsigned-byte
8
))
:type
(
simple-array
(
unsigned-byte
8
)
(
*
)))
:type
(
simple-array
(
unsigned-byte
8
)
(
*
)))
(
call-stack
'
()
:type
list
)
(
call-stack
'
()
:type
list
)
(
data-stack
'
()
:type
list
)
(
data-stack
'
()
:type
list
)
;; Environment
;; Environment
(
environment
'
()
:type
list
)
(
environment
'
()
:type
list
)
(
entry-points
#(
)
:read-only
t
)
(
entry-points
(
make-array
0
:element-type
'procedure-description
)
:type
(
simple-array
procedure-description
(
*
)))
(
side-effects
'
()
:type
list
)
(
side-effects
'
()
:type
list
)
(
capabilities
'
()
:read-only
t
)
(
capabilities
'
()
:read-only
t
)
;; Watchdog limits
;; Watchdog limits
...
@@ -75,8 +80,13 @@
...
@@ -75,8 +80,13 @@
for
n
from
0
for
n
from
0
do
(
destructuring-bind
(
entry-point
arguments
)
entry
do
(
destructuring-bind
(
entry-point
arguments
)
entry
(
setf
(
aref
vector
n
)
(
setf
(
aref
vector
n
)
(
make-procedure-description
:entry-point
entry-point
(
make-procedure-description
:arguments
arguments
))))
:entry-point
entry-point
:arguments
arguments
:static-procedure
(
make-procedure
:entry-point
entry-point
:arguments
arguments
:environment
'
())))))
vector
))
vector
))
(
defun
setup-interpreter
(
script
arguments
&optional
capabilities
)
(
defun
setup-interpreter
(
script
arguments
&optional
capabilities
)
...
...
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