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
d6a1a424
Commit
d6a1a424
authored
31 years ago
by
ram
Browse files
Options
Downloads
Patches
Plain Diff
changed byte functions to be funcallable instances. Added with-debugger-info
various places.
parent
6acc279c
No related branches found
No related tags found
No related merge requests found
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
code/byte-interp.lisp
+111
-102
111 additions, 102 deletions
code/byte-interp.lisp
with
111 additions
and
102 deletions
code/byte-interp.lisp
+
111
−
102
View file @
d6a1a424
...
...
@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(
ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/byte-interp.lisp,v 1.
5
1993/05/11 1
3:47:41
ram Exp $"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/byte-interp.lisp,v 1.
6
1993/05/11 1
7:26:28
ram Exp $"
)
;;;
;;; **********************************************************************
;;;
...
...
@@ -15,9 +15,13 @@
;;;
;;; Written by William Lott
;;;
(
in-package
"C"
)
(
in-package
"KERNEL"
)
(
export
'
(
byte-function
byte-function-name
initialize-byte-function
byte-closure
byte-closure-function
byte-closure-data
byte-function-or-closure
))
(
in-package
"C"
)
;;;; Types.
...
...
@@ -36,18 +40,42 @@
;;;; Byte functions:
(
defstruct
(
byte-function
(
:print-function
%print-byte-function
))
;;; Abstract class represents any type of byte-compiled function.
;;;
(
defstruct
(
byte-function-or-closure
(
:print-function
%print-byte-function
)
(
:alternate-metaclass
kernel:funcallable-instance
kernel:funcallable-structure-class
kernel:make-funcallable-structure-class
)
(
:type
kernel:funcallable-structure
)))
;;; Represents a byte-compiled closure.
;;;
(
defstruct
(
byte-closure
(
:include
byte-function-or-closure
)
(
:constructor
make-byte-closure
function
data
))
;;
;; Debug name of this function.
(
name
nil
)
;; Byte function that we call.
(
function
(
required-argument
)
:type
byte-function
)
;;
;; Closure data vector.
(
data
(
required-argument
)
:type
simple-vector
))
;;; Any non-closure byte function (including the hidden function object for a
;;; closure.)
;;;
(
defstruct
(
byte-function
(
:include
byte-function-or-closure
))
;;
;; The component that this XEP is an entry point into. NIL until
;; LOAD or MAKE-CORE-BYTE-COMPONENT fills it in. We also allow
;; cons so that the dumper can stick in a unique cons cell to
;; identify what component it is trying to dump. What a hack.
(
component
nil
:type
(
or
null
kernel:code-component
cons
)))
;; LOAD or MAKE-CORE-BYTE-COMPONENT fills it in. They count on this being
;; the first slot.
(
component
nil
:type
(
or
null
kernel:code-component
))
;;
;; Debug name of this function.
(
name
nil
))
;;; Fixed-argument byte function.
;;;
(
defstruct
(
simple-byte-function
(
:include
byte-function
))
;;
;; The number of arguments expected.
...
...
@@ -56,6 +84,9 @@
;; The start of the function.
(
entry-point
0
:type
index
))
;;; Variable arg-count byte function.
;;;
(
defstruct
(
hairy-byte-function
(
:include
byte-function
))
;;
;; The minimum and maximum number of args, ignoring &rest and &key.
...
...
@@ -89,7 +120,7 @@
(
print-unreadable-object
(
s
stream
:identity
t
)
(
format
stream
"Byte function ~S"
(
byte-function-name
s
))))
(
declaim
(
freeze-type
byte-function
))
(
declaim
(
freeze-type
byte-function
-or-closure
))
;;;; The stack.
...
...
@@ -263,53 +294,32 @@
;;;; Byte compiled function constructors/extractors.
(
defun
mak
e-byte-compiled-function
(
xep
)
(
defun
initializ
e-byte-compiled-function
(
xep
)
(
declare
(
type
byte-function
xep
))
(
set-function-subtype
#'
(
lambda
(
&rest
args
)
(
let
((
old-sp
(
current-stack-pointer
))
(
num-args
(
length
args
)))
(
declare
(
type
stack-pointer
old-sp
))
(
dolist
(
arg
args
)
(
push-eval-stack
arg
))
(
invoke-xep
nil
0
old-sp
0
num-args
xep
)))
vm:byte-code-function-type
))
(
defun
byte-compiled-function-xep
(
function
)
(
declare
(
type
function
function
)
(
values
byte-function
))
(
or
(
system:find-if-in-closure
#'
byte-function-p
function
)
(
error
"Couldn't find the XEP in ~S"
function
)))
(
setf
(
%funcallable-instance-function
xep
)
#'
(
lambda
(
&rest
args
)
(
let
((
old-sp
(
current-stack-pointer
))
(
num-args
(
length
args
)))
(
declare
(
type
stack-pointer
old-sp
))
(
dolist
(
arg
args
)
(
push-eval-stack
arg
))
(
invoke-xep
nil
0
old-sp
0
num-args
xep
))))
xep
)
(
defun
make-byte-compiled-closure
(
xep
closure-vars
)
(
declare
(
type
byte-function
xep
)
(
type
simple-vector
closure-vars
))
(
set-function-subtype
#'
(
lambda
(
&rest
args
)
(
let
((
old-sp
(
current-stack-pointer
))
(
num-args
(
length
args
)))
(
declare
(
type
stack-pointer
old-sp
))
(
dolist
(
arg
args
)
(
push-eval-stack
arg
))
(
invoke-xep
nil
0
old-sp
0
num-args
xep
closure-vars
)))
vm:byte-code-closure-type
))
(
defun
byte-compiled-closure-xep
(
closure
)
(
declare
(
type
function
closure
)
(
values
byte-function
))
(
or
(
system:find-if-in-closure
#'
byte-function-p
closure
)
(
error
"Couldn't find the XEP in ~S"
closure
)))
(
defun
byte-compiled-closure-closure-vars
(
closure
)
(
declare
(
type
function
closure
)
(
values
simple-vector
))
(
or
(
system:find-if-in-closure
#'
simple-vector-p
closure
)
(
error
"Couldn't find the closure vars in ~S"
closure
)))
(
defun
set-function-subtype
(
function
subtype
)
(
setf
(
function-subtype
function
)
subtype
)
function
)
(
let
((
res
(
make-byte-closure
xep
closure-vars
)))
(
setf
(
%funcallable-instance-function
res
)
#'
(
lambda
(
&rest
args
)
(
let
((
old-sp
(
current-stack-pointer
))
(
num-args
(
length
args
)))
(
declare
(
type
stack-pointer
old-sp
))
(
dolist
(
arg
args
)
(
push-eval-stack
arg
))
(
invoke-xep
nil
0
old-sp
0
num-args
xep
(
byte-closure-data
xep
)))))
res
))
;;;; Inlines.
...
...
@@ -1072,22 +1082,21 @@
(
declare
(
type
stack-pointer
old-sp
)
(
type
(
or
function
fdefn
)
fun-or-fdefn
)
(
type
function
function
))
(
case
(
function-subtype
function
)
(
#.
vm:byte-code-function-type
(
invoke-xep
old-component
ret-pc
old-sp
old-fp
num-args
(
byte-compiled-function-xep
function
)))
(
#.
vm:byte-code-closure-type
(
typecase
function
(
byte-function
(
invoke-xep
old-component
ret-pc
old-sp
old-fp
num-args
function
))
(
byte-closure
(
invoke-xep
old-component
ret-pc
old-sp
old-fp
num-args
(
byte-c
ompiled-closure-xep
function
)
(
byte-c
ompiled-closure-closure-vars
function
)))
(
byte-c
losure-function
function
)
(
byte-c
losure-data
function
)))
(
t
(
cond
((
minusp
ret-pc
)
(
let*
((
ret-pc
(
-
ret-pc
))
(
results
(
multiple-value-list
(
with-debugger-info
(
old-component
ret-pc
old-fp
)
(
byte-apply
function
num-args
old-sp
)))))
(
old-component
ret-pc
old-fp
)
(
byte-apply
function
num-args
old-sp
)))))
(
dolist
(
result
results
)
(
push-eval-stack
result
))
(
push-eval-stack
(
length
results
))
...
...
@@ -1095,8 +1104,8 @@
(
t
(
push-eval-stack
(
with-debugger-info
(
old-component
ret-pc
old-fp
)
(
byte-apply
function
num-args
old-sp
)))
(
old-component
ret-pc
old-fp
)
(
byte-apply
function
num-args
old-sp
)))
(
byte-interpret
old-component
ret-pc
old-fp
)))))))
...
...
@@ -1123,39 +1132,39 @@
(
type
(
or
fdefn
function
)
fun-or-fdefn
)
(
type
function
function
))
(
case
(
function-subtype
function
)
(
#.
vm:byte-cod
e-function
-type
(
byt
e-function
(
stack-copy
old-sp
start-of-args
num-args
)
(
invoke-xep
old-component
old-pc
old-sp
old-fp
num-args
(
byte-compiled-function-xep
function
)))
(
#.
vm:byte-code-closure-type
(
invoke-xep
old-component
old-pc
old-sp
old-fp
num-args
function
))
(
byte-closure
(
stack-copy
old-sp
start-of-args
num-args
)
(
invoke-xep
old-component
old-pc
old-sp
old-fp
num-args
(
byte-c
ompiled-closure-xep
function
)
(
byte-c
ompiled-closure-closure-vars
function
)))
(
byte-c
losure-function
function
)
(
byte-c
losure-data
function
)))
(
t
;; We are tail-calling native code.
(
cond
((
null
old-component
)
;; We were called by native code.
(
byte-apply
function
num-args
old-sp
))
((
minusp
old-pc
)
;; We were called for multiple values. So return multiple
;; values.
(
let
((
results
(
multiple-value-list
(
with-debugger-info
(
old-component
old-pc
old-fp
)
(
byte-apply
function
num-args
old-sp
)))))
(
dolist
(
result
results
)
(
push-eval-stack
result
))
(
push-eval-stack
(
length
results
)))
(
byte-interpret
old-component
old-pc
old-fp
))
(
t
;; We were called for one value. So return one value.
(
push-eval-stack
(
with-debugger-info
(
old-component
old-pc
old-fp
)
(
byte-apply
function
num-args
old-sp
)))
(
byte-interpret
old-component
old-pc
old-fp
)))))))
(
cond
((
null
old-component
)
;; We were called by native code.
(
byte-apply
function
num-args
old-sp
))
((
minusp
old-pc
)
;; We were called for multiple values. So return multiple
;; values.
(
let
((
results
(
multiple-value-list
(
with-debugger-info
(
old-component
old-pc
old-fp
)
(
byte-apply
function
num-args
old-sp
)))))
(
dolist
(
result
results
)
(
push-eval-stack
result
))
(
push-eval-stack
(
length
results
)))
(
byte-interpret
old-component
old-pc
old-fp
))
(
t
;; We were called for one value. So return one value.
(
push-eval-stack
(
with-debugger-info
(
old-component
old-pc
old-fp
)
(
byte-apply
function
num-args
old-sp
)))
(
byte-interpret
old-component
old-pc
old-fp
)))))))
(
defun
invoke-xep
(
old-component
ret-pc
old-sp
old-fp
num-args
xep
&optional
closure-vars
)
...
...
@@ -1169,21 +1178,21 @@
(
cond
((
typep
xep
'simple-byte-function
)
(
unless
(
eql
(
simple-byte-function-num-args
xep
)
num-args
)
;;; ### flame out point.
(
error
"Wrong number of arguments."
))
(
with-debugger-info
(
old-component
ret-pc
old-fp
)
(
error
"Wrong number of arguments."
))
)
(
simple-byte-function-entry-point
xep
))
(
t
(
let
((
min
(
hairy-byte-function-min-args
xep
))
(
max
(
hairy-byte-function-max-args
xep
)))
(
cond
((
<
num-args
min
)
;; ### Flame out point.
(
error
"Not enough arguments."
))
(
with-debugger-info
(
old-component
ret-pc
old-fp
)
(
error
"Not enough arguments."
))
)
((
<=
num-args
max
)
(
nth
(
-
num-args
min
)
(
hairy-byte-function-entry-points
xep
)))
((
null
(
hairy-byte-function-more-args-entry-point
xep
))
;; ### Flame out point.
(
error
"Too many arguments."
))
(
with-debugger-info
(
old-component
ret-pc
old-fp
)
(
error
"Too many arguments."
))
)
(
t
(
let*
((
more-args-supplied
(
-
num-args
max
))
(
sp
(
current-stack-pointer
))
...
...
@@ -1205,8 +1214,8 @@
(
setf
(
eval-stack-ref
more-args-start
)
rest
))
(
t
(
unless
(
evenp
more-args-supplied
)
;; ### Flame out.
(
error
"Odd number of keyword arguments."
))
(
with-debugger-info
(
old-component
ret-pc
old-fp
)
(
error
"Odd number of keyword arguments."
))
)
(
let*
((
num-more-args
(
hairy-byte-function-num-more-args
xep
))
(
new-sp
(
+
more-args-start
num-more-args
))
(
temp
(
max
sp
new-sp
))
...
...
@@ -1255,8 +1264,8 @@
(
t
(
incf
target
))))))))
(
when
(
and
bogus-key-p
(
not
allow
))
;; ### Flame out.
(
error
"Unknown keyword: ~S"
bogus-key
)))
(
with-debugger-info
(
old-component
ret-pc
old-fp
)
(
error
"Unknown keyword: ~S"
bogus-key
)))
)
(
setf
(
current-stack-pointer
)
new-sp
)))))
(
hairy-byte-function-more-args-entry-point
xep
))))))))
(
declare
(
type
pc
entry-point
))
...
...
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