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
d2215ce4
Commit
d2215ce4
authored
34 years ago
by
ram
Browse files
Options
Downloads
Patches
Plain Diff
Added new IR1-FINALIZE function that combines a bunch of stuff previously
being done separately.
parent
f5a4a950
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/ir1final.lisp
+69
-26
69 additions, 26 deletions
compiler/ir1final.lisp
with
69 additions
and
26 deletions
compiler/ir1final.lisp
+
69
−
26
View file @
d2215ce4
...
@@ -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/compiler/ir1final.lisp,v 1.
9
1991/0
2/20 14:57:48
ram Exp $"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1final.lisp,v 1.
10
1991/0
3/11 17:14:09
ram Exp $"
)
;;;
;;;
;;; **********************************************************************
;;; **********************************************************************
;;;
;;;
...
@@ -19,7 +19,7 @@
...
@@ -19,7 +19,7 @@
(
in-package
'c
)
(
in-package
'c
)
;;; Note-Failed-Optimization -- Inter
face
;;; Note-Failed-Optimization -- Inter
nal
;;;
;;;
;;; Give the user grief about optimizations that we weren't able to do. It
;;; Give the user grief about optimizations that we weren't able to do. It
;;; is assumed that they want to hear, or there wouldn't be any entries in the
;;; is assumed that they want to hear, or there wouldn't be any entries in the
...
@@ -52,29 +52,72 @@
...
@@ -52,29 +52,72 @@
~{~6T~?~^~&~}"
~{~6T~?~^~&~}"
(
messages
))))))))))
(
messages
))))))))))
;;; Check-Free-Function -- Interface
;;; Tail-Annotate -- Internal
;;;
;;; Mark all tail-recursive uses of function result continuations with the
;;; corresponding tail-set. Nodes whose type is NIL (i.e. don't return) such
;;; as calls to ERROR are never annotated as tail, so as to preserve debugging
;;; information.
;;;
;;;
;;; If the entry is a functional, then we update the global environment
(
defun
tail-annotate
(
component
)
;;; according to the new definition, checking for inconsistency.
(
declare
(
type
component
component
))
(
dolist
(
fun
(
component-lambdas
component
))
(
let
((
ret
(
lambda-return
fun
)))
(
when
ret
(
let
((
result
(
return-result
ret
))
(
tails
(
lambda-tail-set
fun
)))
(
do-uses
(
use
result
)
(
when
(
and
(
immediately-used-p
result
use
)
(
or
(
not
(
eq
(
node-derived-type
use
)
*empty-type*
))
(
not
(
basic-combination-p
use
))
(
eq
(
basic-combination-kind
use
)
:local
)))
(
setf
(
node-tail-p
use
)
tails
)))))))
(
undefined-value
))
;;; IR1-FINALIZE -- Interface
;;;
;;;
(
proclaim
'
(
function
check-free-function
(
t
leaf
)
void
))
;;; Do miscellaneous things that we want to do once all optimization has
(
defun
check-free-function
(
name
leaf
)
;;; been done:
(
etypecase
leaf
;;; -- Record the derived result type before the back-end trashes the
(
functional
;;; flow graph.
(
let*
((
where
(
info
function
where-from
name
))
;;; -- For each named function with an XEP, note the definition of that name,
(
dtype
(
leaf-type
leaf
))
;;; and add derived type information to the info environment. We also
(
*compiler-error-context*
(
lambda-bind
(
main-entry
leaf
))))
;;; delete the FUNCTIONAL from *FREE-FUNCTIONS* to eliminate the
(
note-name-defined
name
:function
)
;;; possibility that new references might be converted to it.
(
ecase
where
;;; -- Note any failed optimizations.
(
:assumed
;;;
(
let
((
approx-type
(
info
function
assumed-type
name
)))
(
defun
ir1-finalize
(
component
)
(
when
(
and
approx-type
(
function-type-p
dtype
))
(
declare
(
type
component
component
))
(
valid-approximate-type
approx-type
dtype
))
(
tail-annotate
component
)
(
setf
(
info
function
type
name
)
dtype
)
(
setf
(
info
function
assumed-type
name
)
nil
))
(
dolist
(
fun
(
component-lambdas
component
))
(
setf
(
info
function
where-from
name
)
:defined
))
(
case
(
functional-kind
fun
)
(
:declared
)
; No check for now, just keep declared type.
(
:external
(
:defined
(
let*
((
leaf
(
functional-entry-function
fun
))
(
setf
(
info
function
type
name
)
dtype
)))))
(
name
(
leaf-name
leaf
))
(
global-var
)))
(
where
(
info
function
where-from
name
))
(
dtype
(
definition-type
leaf
))
(
*compiler-error-context*
(
lambda-bind
(
main-entry
leaf
))))
(
setf
(
leaf-type
leaf
)
dtype
)
(
when
(
eq
leaf
(
gethash
name
*free-functions*
))
(
note-name-defined
name
:function
)
(
remhash
name
*free-functions*
)
(
ecase
where
(
:assumed
(
let
((
approx-type
(
info
function
assumed-type
name
)))
(
when
(
and
approx-type
(
function-type-p
dtype
))
(
valid-approximate-type
approx-type
dtype
))
(
setf
(
info
function
type
name
)
dtype
)
(
setf
(
info
function
assumed-type
name
)
nil
))
(
setf
(
info
function
where-from
name
)
:defined
))
(
:declared
)
; Just keep declared type.
(
:defined
(
setf
(
info
function
type
name
)
dtype
))))))
((
nil
)
(
setf
(
leaf-type
fun
)
(
definition-type
fun
)))))
(
maphash
#'
note-failed-optimization
*failed-optimizations*
)
(
clrhash
*failed-optimizations*
)
(
undefined-value
))
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