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
3438a42f
Commit
3438a42f
authored
34 years ago
by
ram
Browse files
Options
Downloads
Patches
Plain Diff
Added stuff to make DELETE-BLOCK print a note when it seems that we are
deleting code which appeared in the original source.
parent
772658ba
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
compiler/ir1util.lisp
+78
-0
78 additions, 0 deletions
compiler/ir1util.lisp
with
78 additions
and
0 deletions
compiler/ir1util.lisp
+
78
−
0
View file @
3438a42f
...
...
@@ -817,6 +817,83 @@ inlines
(
undefined-value
))
(
defvar
*deletion-ignored-objects*
'
(
t
nil
))
;;; PRESENT-IN-FORM -- Internal
;;;
;;; Return true if we can find Obj in Form, NIL otherwise. We bound our
;;; recursion so that we don't get lost in circular structures. We ignore the
;;; car of forms if they are a symbol (to prevent confusing function
;;; referencess with variables), and we also ignore anything inside ' or #'.
;;;
(
defun
present-in-form
(
obj
form
depth
)
(
declare
(
type
(
integer
0
20
)
depth
))
(
cond
((
=
depth
20
)
nil
)
((
eq
obj
form
)
t
)
((
atom
form
)
nil
)
(
t
(
let
((
first
(
car
form
))
(
depth
(
1+
depth
)))
(
if
(
member
first
'
(
quote
function
))
nil
(
or
(
and
(
not
(
symbolp
first
))
(
present-in-form
obj
first
depth
))
(
do
((
l
(
cdr
form
)
(
cdr
l
))
(
n
0
(
1+
n
)))
((
or
(
atom
l
)
(
>
n
100
))
nil
)
(
declare
(
fixnum
n
))
(
when
(
present-in-form
obj
(
car
l
)
depth
)
(
return
t
)))))))))
;;; NOTE-BLOCK-DELETION -- Internal
;;;
;;; This function is called on a block immediately before we delete it. We
;;; check to see if any of the code about to die appeared in the original
;;; source, and emit a note if so.
;;;
;;; If the block was in a lambda is now deleted, but used to be a
;;; optional-dispatch entry point or XEP, then we ignore the whole block. We
;;; also ignore the deletion of CRETURN nodes, since it is somewhat reasonable
;;; for a function to not return, and there is a different note for that case
;;; anyway.
;;;
;;; If the actual source is an atom, then we use a bunch of heuristics to
;;; guess whether this reference really appeared in the original source:
;;; -- If a symbol, it must be interned.
;;; -- It must not be an easily introduced constant (T or NIL).
;;; -- The atom must be "present" in the original source form, and present in
;;; all intervening actual source forms.
;;;
(
defun
note-block-deletion
(
block
)
(
let
((
home
(
block-home-lambda
block
)))
(
unless
(
and
(
eq
(
functional-kind
home
)
:deleted
)
(
or
(
functional-entry-function
home
)
(
let
((
od
(
lambda-optional-dispatch
home
)))
(
and
od
(
not
(
eq
(
optional-dispatch-main-entry
od
)
home
))))))
(
do-nodes
(
node
cont
block
)
(
let*
((
path
(
node-source-path
node
))
(
first
(
first
path
)))
(
when
(
or
(
eq
first
'original-source-start
)
(
and
(
atom
first
)
(
or
(
not
(
symbolp
first
))
(
symbol-package
first
))
(
not
(
member
first
*deletion-ignored-objects*
))
(
every
#'
(
lambda
(
x
)
(
present-in-form
first
x
0
))
(
source-path-forms
path
))
(
present-in-form
first
(
find-original-source
path
)
0
)))
(
unless
(
return-p
node
)
(
let
((
*compiler-error-context*
node
))
(
compiler-note
"Deleting unreachable code."
)))
(
return
))))))
(
undefined-value
))
;;; Delete-Block -- Interface
;;;
;;; This function does what is necessary to eliminate the code in it from
...
...
@@ -830,6 +907,7 @@ inlines
(
defun
delete-block
(
block
)
(
declare
(
type
cblock
block
))
(
assert
(
block-component
block
)
()
"Block is already deleted."
)
(
note-block-deletion
block
)
(
setf
(
block-delete-p
block
)
t
)
(
let*
((
last
(
block-last
block
))
...
...
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