Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
cmucl
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Wiki
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Build
Pipelines
Jobs
Pipeline schedules
Artifacts
Deploy
Releases
Package Registry
Model registry
Operate
Environments
Terraform modules
Monitor
Incidents
Service Desk
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
Community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
Carl Shapiro
cmucl
Commits
15d7839f
Commit
15d7839f
authored
32 years ago
by
ram
Browse files
Options
Downloads
Patches
Plain Diff
Added missing type declarations
parent
39b95647
No related branches found
Branches containing commit
No related tags found
Tags containing commit
No related merge requests found
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
code/byte-interp.lisp
+35
-16
35 additions, 16 deletions
code/byte-interp.lisp
with
35 additions
and
16 deletions
code/byte-interp.lisp
+
35
−
16
View file @
15d7839f
...
@@ -7,7 +7,7 @@
...
@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
;;;
(
ext:file-comment
(
ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/byte-interp.lisp,v 1.
2
1992/0
8
/0
2
1
9:38:47
ram Exp $"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/byte-interp.lisp,v 1.
3
1992/0
9
/0
7
1
6:10:36
ram Exp $"
)
;;;
;;;
;;; **********************************************************************
;;; **********************************************************************
;;;
;;;
...
@@ -75,6 +75,7 @@
...
@@ -75,6 +75,7 @@
value
))
value
))
(
defmacro
multiple-value-pop-eval-stack
((
&rest
vars
)
&body
body
)
(
defmacro
multiple-value-pop-eval-stack
((
&rest
vars
)
&body
body
)
(
declare
(
optimize
(
inhibit-warnings
3
)))
(
let
((
num-vars
(
length
vars
))
(
let
((
num-vars
(
length
vars
))
(
index
-1
)
(
index
-1
)
(
new-sp-var
(
gensym
"NEW-SP-"
))
(
new-sp-var
(
gensym
"NEW-SP-"
))
...
@@ -130,13 +131,6 @@
...
@@ -130,13 +131,6 @@
(
ash
(
component-ref
component
(
1+
pc
))
8
)
(
ash
(
component-ref
component
(
1+
pc
))
8
)
(
component-ref
component
(
+
pc
2
))))
(
component-ref
component
(
+
pc
2
))))
(
declaim
(
inline
component-ref-32
))
(
defun
component-ref-32
(
component
pc
)
(
logior
(
ash
(
component-ref
component
pc
)
24
)
(
ash
(
component-ref
component
(
1+
pc
))
16
)
(
ash
(
component-ref
component
(
+
pc
2
))
8
)
(
component-ref
component
(
+
pc
3
))))
;;;; Debugging support.
;;;; Debugging support.
...
@@ -249,6 +243,7 @@
...
@@ -249,6 +243,7 @@
;;;; Inlines.
;;;; Inlines.
(
defmacro
expand-into-inlines
()
(
defmacro
expand-into-inlines
()
(
declare
(
optimize
(
inhibit-warnings
3
)))
(
labels
((
build-dispatch
(
bit
base
)
(
labels
((
build-dispatch
(
bit
base
)
(
if
(
minusp
bit
)
(
if
(
minusp
bit
)
(
let
((
info
(
nth
base
*inline-functions*
)))
(
let
((
info
(
nth
base
*inline-functions*
)))
...
@@ -345,6 +340,7 @@
...
@@ -345,6 +340,7 @@
;;; *BYTE-XOPS* -- Simple vector of the XOP functions.
;;; *BYTE-XOPS* -- Simple vector of the XOP functions.
;;;
;;;
(
declaim
(
type
(
simple-vector
256
)
*byte-xops*
))
(
defvar
*byte-xops*
(
defvar
*byte-xops*
(
make-array
256
:initial-element
#'
undefined-xop
))
(
make-array
256
:initial-element
#'
undefined-xop
))
...
@@ -417,15 +413,16 @@
...
@@ -417,15 +413,16 @@
(
labels
((
grovel
(
remaining-blocks
block-count-ptr
)
(
labels
((
grovel
(
remaining-blocks
block-count-ptr
)
(
declare
(
type
index
remaining-blocks
)
(
declare
(
type
index
remaining-blocks
)
(
type
stack-pointer
block-count-ptr
))
(
type
stack-pointer
block-count-ptr
))
(
declare
(
values
index
stack-pointer
))
(
let
((
block-count
(
eval-stack-ref
block-count-ptr
)))
(
let
((
block-count
(
eval-stack-ref
block-count-ptr
)))
(
declare
(
type
index
block-count
))
(
if
(
=
remaining-blocks
1
)
(
if
(
=
remaining-blocks
1
)
(
values
block-count
block-count-ptr
)
(
values
block-count
block-count-ptr
)
(
let
((
src
(
-
block-count-ptr
block-count
)))
(
let
((
src
(
-
block-count-ptr
block-count
)))
(
declare
(
type
index
src
))
(
multiple-value-bind
(
multiple-value-bind
(
values-above
dst
)
(
values-above
dst
)
(
grovel
(
1-
remaining-blocks
)
(
1-
src
))
(
grovel
(
1-
remaining-blocks
)
(
1-
src
))
(
declare
(
type
index
values-above
)
(
type
stack-pointer
dst
))
(
stack-copy
dst
src
block-count
)
(
stack-copy
dst
src
block-count
)
(
values
(
+
values-above
block-count
)
(
values
(
+
values-above
block-count
)
(
+
dst
block-count
))))))))
(
+
dst
block-count
))))))))
...
@@ -469,6 +466,7 @@
...
@@ -469,6 +466,7 @@
(
ignore
pc
)
(
ignore
pc
)
(
type
stack-pointer
fp
))
(
type
stack-pointer
fp
))
(
let
((
num-results
(
pop-eval-stack
)))
(
let
((
num-results
(
pop-eval-stack
)))
(
declare
(
type
index
num-results
))
(
case
num-results
(
case
num-results
(
0
(
0
(
let
((
tag
(
pop-eval-stack
)))
(
let
((
tag
(
pop-eval-stack
)))
...
@@ -513,6 +511,7 @@
...
@@ -513,6 +511,7 @@
(
catch
(
pop-eval-stack
)
(
catch
(
pop-eval-stack
)
(
return
(
byte-interpret
component
(
+
pc
3
)
fp
))))))
(
return
(
byte-interpret
component
(
+
pc
3
)
fp
))))))
(
let
((
num-results
0
))
(
let
((
num-results
0
))
(
declare
(
type
index
num-results
))
(
dolist
(
result
results
)
(
dolist
(
result
results
)
(
push-eval-stack
result
)
(
push-eval-stack
result
)
(
incf
num-results
))
(
incf
num-results
))
...
@@ -544,6 +543,7 @@
...
@@ -544,6 +543,7 @@
(
type
stack-pointer
fp
))
(
type
stack-pointer
fp
))
(
let
((
tag
(
pop-eval-stack
))
(
let
((
tag
(
pop-eval-stack
))
(
num-results
(
pop-eval-stack
)))
(
num-results
(
pop-eval-stack
)))
(
declare
(
type
index
num-results
))
(
case
num-results
(
case
num-results
(
0
(
0
(
with-debugger-info
(
component
old-pc
fp
)
(
with-debugger-info
(
component
old-pc
fp
)
...
@@ -774,10 +774,11 @@
...
@@ -774,10 +774,11 @@
(
type
pc
pc
)
(
type
pc
pc
)
(
type
stack-pointer
fp
)
(
type
stack-pointer
fp
)
(
type
(
unsigned-byte
8
)
byte
))
(
type
(
unsigned-byte
8
)
byte
))
(
when
*byte-trace*
(
locally
(
declare
(
optimize
(
inhibit-warnings
3
)))
(
format
*trace-output*
"pc=~D, fp=~D, sp=~D, byte=#b~8,'0B, frame=~S~%"
(
when
*byte-trace*
pc
fp
(
current-stack-pointer
)
byte
(
format
*trace-output*
"pc=~D, fp=~D, sp=~D, byte=#b~8,'0B, frame=~S~%"
(
subseq
eval::*eval-stack*
fp
(
current-stack-pointer
))))
pc
fp
(
current-stack-pointer
)
byte
(
subseq
eval::*eval-stack*
fp
(
current-stack-pointer
)))))
(
if
(
zerop
(
logand
byte
#x80
))
(
if
(
zerop
(
logand
byte
#x80
))
;; Some stack operation. No matter what, we need the operand,
;; Some stack operation. No matter what, we need the operand,
;; so compute it.
;; so compute it.
...
@@ -809,6 +810,7 @@
...
@@ -809,6 +810,7 @@
(
setf
(
eval-stack-ref
(
+
fp
operand
))
(
pop-eval-stack
))
(
setf
(
eval-stack-ref
(
+
fp
operand
))
(
pop-eval-stack
))
(
if
(
zerop
operand
)
(
if
(
zerop
operand
)
(
let
((
operand
(
pop-eval-stack
)))
(
let
((
operand
(
pop-eval-stack
)))
(
declare
(
type
index
operand
))
(
decf
(
current-stack-pointer
)
operand
))
(
decf
(
current-stack-pointer
)
operand
))
(
decf
(
current-stack-pointer
)
operand
)))))
(
decf
(
current-stack-pointer
)
operand
)))))
(
byte-interpret
component
new-pc
fp
))
(
byte-interpret
component
new-pc
fp
))
...
@@ -886,7 +888,7 @@
...
@@ -886,7 +888,7 @@
(
values
(
component-ref
component
(
+
pc
1
))
(
values
(
component-ref
component
(
+
pc
1
))
(
+
pc
2
))
(
+
pc
2
))
(
values
operand
(
1+
pc
))))
(
values
operand
(
1+
pc
))))
(
funcall
(
svref
*byte-xops*
sub-code
)
(
funcall
(
the
function
(
svref
*byte-xops*
sub-code
)
)
component
pc
new-pc
fp
))))
component
pc
new-pc
fp
))))
;; Random inline function.
;; Random inline function.
(
progn
(
progn
...
@@ -904,6 +906,9 @@
...
@@ -904,6 +906,9 @@
old-fp
))
old-fp
))
(
defun
do-tail-local-call
(
component
pc
fp
num-args
)
(
defun
do-tail-local-call
(
component
pc
fp
num-args
)
(
declare
(
type
code-component
component
)
(
type
pc
pc
)
(
type
stack-pointer
fp
)
(
type
index
num-args
))
(
let
((
old-fp
(
eval-stack-ref
(
-
fp
1
)))
(
let
((
old-fp
(
eval-stack-ref
(
-
fp
1
)))
(
old-sp
(
eval-stack-ref
(
-
fp
2
)))
(
old-sp
(
eval-stack-ref
(
-
fp
2
)))
(
old-pc
(
eval-stack-ref
(
-
fp
3
)))
(
old-pc
(
eval-stack-ref
(
-
fp
3
)))
...
@@ -947,6 +952,7 @@
...
@@ -947,6 +952,7 @@
;;; and restore the SP to the specifier value.
;;; and restore the SP to the specifier value.
;;;
;;;
(
defun
byte-apply
(
function
num-args
restore-sp
)
(
defun
byte-apply
(
function
num-args
restore-sp
)
(
declare
(
function
function
)
(
type
index
num-args
))
(
let
((
start
(
-
(
current-stack-pointer
)
num-args
)))
(
let
((
start
(
-
(
current-stack-pointer
)
num-args
)))
(
declare
(
type
stack-pointer
start
))
(
declare
(
type
stack-pointer
start
))
(
macrolet
((
frob
()
(
macrolet
((
frob
()
...
@@ -1084,6 +1090,7 @@
...
@@ -1084,6 +1090,7 @@
(
defun
invoke-xep
(
old-component
ret-pc
old-sp
old-fp
num-args
xep
(
defun
invoke-xep
(
old-component
ret-pc
old-sp
old-fp
num-args
xep
&optional
closure-vars
)
&optional
closure-vars
)
(
declare
(
type
(
or
null
code-component
)
old-component
)
(
declare
(
type
(
or
null
code-component
)
old-component
)
(
type
index
num-args
)
(
type
return-pc
ret-pc
)
(
type
return-pc
ret-pc
)
(
type
stack-pointer
old-sp
old-fp
)
(
type
stack-pointer
old-sp
old-fp
)
(
type
byte-xep
xep
)
(
type
byte-xep
xep
)
...
@@ -1110,7 +1117,10 @@
...
@@ -1110,7 +1117,10 @@
(
result
nil
(
result
nil
(
cons
(
eval-stack-ref
index
)
(
cons
(
eval-stack-ref
index
)
result
)))
result
)))
((
<
index
more-args-start
)
result
)))))
((
<
index
more-args-start
)
result
)
(
declare
(
type
index
index
))))))
(
declare
(
type
index
more-args-supplied
)
(
type
stack-pointer
more-args-start
))
(
cond
(
cond
((
not
(
byte-xep-keywords-p
xep
))
((
not
(
byte-xep-keywords-p
xep
))
(
assert
restp
)
(
assert
restp
)
...
@@ -1125,6 +1135,8 @@
...
@@ -1125,6 +1135,8 @@
(
temp
(
max
sp
new-sp
))
(
temp
(
max
sp
new-sp
))
(
temp-sp
(
+
temp
more-args-supplied
))
(
temp-sp
(
+
temp
more-args-supplied
))
(
keywords
(
byte-xep-keywords
xep
)))
(
keywords
(
byte-xep-keywords
xep
)))
(
declare
(
type
index
temp
)
(
type
stack-pointer
new-sp
temp-sp
))
(
setf
(
current-stack-pointer
)
temp-sp
)
(
setf
(
current-stack-pointer
)
temp-sp
)
(
stack-copy
temp
more-args-start
more-args-supplied
)
(
stack-copy
temp
more-args-start
more-args-supplied
)
(
when
restp
(
when
restp
...
@@ -1141,6 +1153,7 @@
...
@@ -1141,6 +1153,7 @@
(
allow
(
eq
(
byte-xep-keywords-p
xep
)
:allow-others
))
(
allow
(
eq
(
byte-xep-keywords-p
xep
)
:allow-others
))
(
bogus-key
nil
)
(
bogus-key
nil
)
(
bogus-key-p
nil
))
(
bogus-key-p
nil
))
(
declare
(
type
stack-pointer
index
))
(
loop
(
loop
(
decf
index
2
)
(
decf
index
2
)
(
when
(
<
index
more-args-start
)
(
when
(
<
index
more-args-start
)
...
@@ -1150,6 +1163,7 @@
...
@@ -1150,6 +1163,7 @@
(
if
(
eq
key
:allow-other-keys
)
(
if
(
eq
key
:allow-other-keys
)
(
setf
allow
value
)
(
setf
allow
value
)
(
let
((
target
more-args-start
))
(
let
((
target
more-args-start
))
(
declare
(
type
stack-pointer
target
))
(
dolist
(
keyword
keywords
(
dolist
(
keyword
keywords
(
setf
bogus-key
key
(
setf
bogus-key
key
bogus-key-p
t
))
bogus-key-p
t
))
...
@@ -1174,6 +1188,7 @@
...
@@ -1174,6 +1188,7 @@
closure-vars
)))
closure-vars
)))
(
defun
do-return
(
fp
num-results
)
(
defun
do-return
(
fp
num-results
)
(
declare
(
type
stack-pointer
fp
)
(
type
index
num-results
))
(
let
((
old-component
(
eval-stack-ref
(
-
fp
4
))))
(
let
((
old-component
(
eval-stack-ref
(
-
fp
4
))))
(
typecase
old-component
(
typecase
old-component
(
code-component
(
code-component
...
@@ -1201,9 +1216,11 @@
...
@@ -1201,9 +1216,11 @@
(
error
"function-end breakpoints not supported."
)))))
(
error
"function-end breakpoints not supported."
)))))
(
defun
do-local-return
(
old-component
fp
num-results
)
(
defun
do-local-return
(
old-component
fp
num-results
)
(
declare
(
type
stack-pointer
fp
)
(
type
index
num-results
))
(
let
((
old-fp
(
eval-stack-ref
(
-
fp
1
)))
(
let
((
old-fp
(
eval-stack-ref
(
-
fp
1
)))
(
old-sp
(
eval-stack-ref
(
-
fp
2
)))
(
old-sp
(
eval-stack-ref
(
-
fp
2
)))
(
old-pc
(
eval-stack-ref
(
-
fp
3
))))
(
old-pc
(
eval-stack-ref
(
-
fp
3
))))
(
declare
(
type
(
signed-byte
25
)
old-pc
))
(
if
(
plusp
old-pc
)
(
if
(
plusp
old-pc
)
;; Wants single value.
;; Wants single value.
(
let
((
result
(
if
(
zerop
num-results
)
(
let
((
result
(
if
(
zerop
num-results
)
...
@@ -1227,6 +1244,7 @@
...
@@ -1227,6 +1244,7 @@
;;;; Random testing noise.
;;;; Random testing noise.
(
defun
dump-byte-fun
(
fun
)
(
defun
dump-byte-fun
(
fun
)
(
declare
(
optimize
(
inhibit-warnings
3
)))
(
let*
((
xep
(
system:find-if-in-closure
#'
byte-xep-p
fun
))
(
let*
((
xep
(
system:find-if-in-closure
#'
byte-xep-p
fun
))
(
component
(
byte-xep-component
xep
))
(
component
(
byte-xep-component
xep
))
(
bytes
(
*
(
code-header-ref
component
vm:code-code-size-slot
)
(
bytes
(
*
(
code-header-ref
component
vm:code-code-size-slot
)
...
@@ -1236,6 +1254,7 @@
...
@@ -1236,6 +1254,7 @@
(
defun
disassem-byte-fun
(
fun
)
(
defun
disassem-byte-fun
(
fun
)
(
declare
(
optimize
(
inhibit-warnings
3
)))
(
let*
((
xep
(
system:find-if-in-closure
#'
byte-xep-p
fun
))
(
let*
((
xep
(
system:find-if-in-closure
#'
byte-xep-p
fun
))
(
component
(
byte-xep-component
xep
))
(
component
(
byte-xep-component
xep
))
(
bytes
(
*
(
code-header-ref
component
vm:code-code-size-slot
)
(
bytes
(
*
(
code-header-ref
component
vm:code-code-size-slot
)
...
...
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Save comment
Cancel
Please
register
or
sign in
to comment