/[cmucl]/src/compiler/entry.lisp
ViewVC logotype

Contents of /src/compiler/entry.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.14 - (show annotations)
Fri Mar 19 15:19:00 2010 UTC (4 years ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, post-merge-intl-branch, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.13: +2 -1 lines
Merge intl-branch 2010-03-18 to HEAD.  To build, you need to use
boot-2010-02-1 as the bootstrap file.  You should probably also use
the new -P option for build.sh to generate and update the po files
while building.
1 ;;; -*- Package: C; Log: C.Log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/compiler/entry.lisp,v 1.14 2010/03/19 15:19:00 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Code in this file handles VM-independent details of run-time
13 ;;; function representation that primarily concern IR2 conversion and the
14 ;;; dumper/loader.
15 ;;;
16 ;;; Written by Rob MacLachlan
17 ;;;
18 (in-package "C")
19 (intl:textdomain "cmucl")
20
21
22 ;;; Entry-Analyze -- Interface
23 ;;;
24 ;;; This phase runs before IR2 conversion, initializing each XEP's
25 ;;; Entry-Info structure. We call the VM-supplied Select-Component-Format
26 ;;; function to make VM-dependent initializations in the IR2-Component. This
27 ;;; includes setting the IR2-Component-Kind and allocating fixed implementation
28 ;;; overhead in the constant pool. If there was a forward reference to a
29 ;;; function, then the ENTRY-INFO will already exist, but will be
30 ;;; uninitialized.
31 ;;;
32 (defun entry-analyze (component)
33 (let ((2comp (component-info component)))
34 (dolist (fun (component-lambdas component))
35 (when (external-entry-point-p fun)
36 (let ((info (or (leaf-info fun)
37 (setf (leaf-info fun) (make-entry-info)))))
38 (compute-entry-info fun info)
39 (push info (ir2-component-entries 2comp))))))
40
41 (select-component-format component)
42 (undefined-value))
43
44
45 ;;; Simplify-Lambda-List -- Internal
46 ;;;
47 ;;; Remove complex init forms from the debug arglist LAMBDA-LIST so
48 ;;; that we can print it safely.
49 ;;;
50 (defun simplify-lambda-list (lambda-list)
51 (labels ((simplify-lambda-arg (arg)
52 (cond ((symbolp arg) arg)
53 (t (destructuring-bind (name &optional init supplied) arg
54 (declare (ignore supplied))
55 (cond ((simple-init-form-p init 3) arg)
56 ((consp name) (car name))
57 (t name))))))
58 (simple-init-form-p (form level)
59 (and (> level 0)
60 (typecase form
61 ((or symbol number character) t)
62 (cons (and (simple-init-form-p (car form) (1- level))
63 (simple-init-form-p (cdr form) (1- level))))))))
64 (multiple-value-bind (required optional restp rest keyp keys
65 other aux morep morectx morecount)
66 (c::parse-lambda-list lambda-list)
67 (declare (ignore aux))
68 `(,@required
69 ,@(if optional `(&optional . ,(mapcar #'simplify-lambda-arg optional)))
70 ,@(if restp `(&rest ,rest))
71 ,@(if keyp `(&key . ,(mapcar #'simplify-lambda-arg keys)))
72 ,@(if other `(&allow-other-keys))
73 ,@(if morep `(&more ,morectx ,morecount))))))
74
75
76
77 ;;; Make-Arg-Names -- Internal
78 ;;;
79 ;;; Takes the list representation of the debug arglist and turns it into a
80 ;;; string.
81 ;;;
82 (defun make-arg-names (x)
83 (declare (type functional x))
84 (let ((args (functional-arg-documentation x)))
85 (assert (not (eq args :unspecified)))
86 (if (null args)
87 "()"
88 (let ((package *package*))
89 (with-standard-io-syntax
90 (let ((*package* package)
91 (*print-pretty* t)
92 (*print-circle* t)
93 (*print-case* :downcase))
94 ;; Just try to print it. If we can't, simplify the
95 ;; lambda-list and print again. (See cmucl-imp mailing
96 ;; list, 2008/04/14 for examples.)
97 (handler-case
98 (write-to-string args)
99 (print-not-readable ()
100 (write-to-string (simplify-lambda-list args))))))))))
101
102 ;;; Compute-Entry-Info -- Internal
103 ;;;
104 ;;; Initialize Info structure to correspond to the XEP lambda Fun.
105 ;;;
106 (defun compute-entry-info (fun info)
107 (declare (type clambda fun) (type entry-info info))
108 (let ((bind (lambda-bind fun))
109 (internal-fun (functional-entry-function fun)))
110 (setf (entry-info-closure-p info)
111 (not (null (environment-closure (lambda-environment fun)))))
112 (setf (entry-info-offset info) (gen-label))
113 (setf (entry-info-name info)
114 (let ((name (leaf-name internal-fun)))
115 (or name
116 (component-name (block-component (node-block bind))))))
117 (when (policy bind (>= debug 1))
118 (setf (entry-info-arguments info) (make-arg-names internal-fun))
119 (setf (entry-info-type info) (type-specifier (leaf-type internal-fun)))))
120 (undefined-value))
121
122
123 ;;; REPLACE-TOP-LEVEL-XEPS -- Interface
124 ;;;
125 ;;; Replace all references to Component's non-closure XEPS that appear in
126 ;;; top-level components, changing to :TOP-LEVEL-XEP functionals. If the
127 ;;; cross-component ref is not in a :TOP-LEVEL component, or is to a closure,
128 ;;; then substitution is suppressed.
129 ;;;
130 ;;; When a cross-component ref is not substituted, we return T to indicate that
131 ;;; early deletion of this component's IR1 should not be done. We also return
132 ;;; T if this component contains :TOP-LEVEL lambdas (though it is not a
133 ;;; :TOP-LEVEL component.)
134 ;;;
135 ;;; We deliberately don't use the normal reference deletion, since we don't
136 ;;; want to trigger deletion of the XEP (although it shouldn't hurt, since this
137 ;;; is called after Component is compiled.) Instead, we just clobber the
138 ;;; REF-LEAF.
139 ;;;
140 (defun replace-top-level-xeps (component)
141 (let ((res nil))
142 (dolist (lambda (component-lambdas component))
143 (case (functional-kind lambda)
144 (:external
145 (let* ((ef (functional-entry-function lambda))
146 (new (make-functional :kind :top-level-xep
147 :info (leaf-info lambda)
148 :name (leaf-name ef)
149 :lexenv (make-null-environment)))
150 (closure (environment-closure
151 (lambda-environment (main-entry ef)))))
152 (dolist (ref (leaf-refs lambda))
153 (let ((ref-component (block-component (node-block ref))))
154 (cond ((eq ref-component component))
155 ((or (not (eq (component-kind ref-component) :top-level))
156 closure)
157 (setq res t))
158 (t
159 (setf (ref-leaf ref) new)
160 (push ref (leaf-refs new))))))))
161 (:top-level
162 (setq res t))))
163 res))

  ViewVC Help
Powered by ViewVC 1.1.5