source: trunk/source/level-1/l1-init.lisp @ 11887

Last change on this file since 11887 was 11373, checked in by gz, 11 years ago

Finish source location and pc -> source mapping support, from working-0711 but with some modifications.

Details:

Source location are recorded in CCL:SOURCE-NOTE's, which are objects with accessors CCL:SOURCE-NOTE-FILENAME, CCL:SOURCE-NOTE-START-POS, CCL:SOURCE-NOTE-END-POS and CCL:SOURCE-NOTE-TEXT. The start and end positions are file positions (not character positions). The text will be NIL unless text recording was on at read-time. If the original file is still available, you can force missing source text to be read from the file at runtime via CCL:ENSURE-SOURCE-NOTE-TEXT.

Source-note's are associated with definitions (via record-source-file) and also stored in function objects (including anonymous and nested functions). The former can be retrieved via CCL:FIND-DEFINITION-SOURCES, the latter via CCL:FUNCTION-SOURCE-NOTE.

The recording behavior is controlled by the new variable CCL:*SAVE-SOURCE-LOCATIONS*:

If NIL, don't store source-notes in function objects, and store only the filename for definitions (the latter only if *record-source-file* is true).
If T, store source-notes, including a copy of the original source text, for function objects and definitions (the latter only if *record-source-file* is true).
If :NO-TEXT, store source-notes, but without saved text, for function objects and defintions (the latter only if *record-source-file* is true). This is the default.

PC to source mapping is controlled by the new variable CCL:*RECORD-PC-MAPPING*. If true (the default), functions store a compressed table mapping pc offsets to corresponding source locations. This can be retrieved by (CCL:FIND-SOURCE-NOTE-AT-PC function pc) which returns a source-note for the source at offset pc in the function.

Currently the only thing that makes use of any of this is the disassembler. ILISP and current version of Slime still use backward-compatible functions that deal with filenames only. The plan is to make Slime, and our IDE, use this eventually.

Known bug: most of this only works through the file compiler. Still need to make it work with loading from source (not hard, just haven't gotten to it yet).

This checkin incidentally includes bits and pieces of support for code coverage, which is still
incomplete and untested. Ignore it.

The PPC version is untested. I need to check it in so I can move to a PPC for testing.

Sizes:

18387152 Nov 16 10:00 lx86cl64.image-no-loc-no-pc
19296464 Nov 16 10:11 lx86cl64.image-loc-no-text-no-pc
20517072 Nov 16 09:58 lx86cl64.image-loc-no-text-with-pc [default]
25514192 Nov 16 09:55 lx86cl64.image-loc-with-text-with-pc

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 11.9 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(in-package "CCL")
18
19(eval-when (:compile-toplevel :execute :load-toplevel)
20
21(defconstant most-positive-short-float (make-short-float-from-fixnums (1- (ash 1 23)) 254 0))
22(defconstant most-negative-short-float (make-short-float-from-fixnums (1- (ash 1 23)) 254 -1))
23(defconstant most-positive-single-float (make-short-float-from-fixnums (1- (ash 1 23)) 254 0))
24(defconstant most-negative-single-float (make-short-float-from-fixnums (1- (ash 1 23)) 254 -1))
25
26
27(defconstant least-positive-short-float (make-short-float-from-fixnums 1 0 0))
28(defconstant least-negative-short-float (make-short-float-from-fixnums 1 0 -1))
29(defconstant least-positive-single-float (make-short-float-from-fixnums 1 0 0))
30(defconstant least-negative-single-float (make-short-float-from-fixnums 1 0 -1))
31
32(defconstant short-float-epsilon (make-short-float-from-fixnums 1 103 0))
33(defconstant short-float-negative-epsilon (make-short-float-from-fixnums 1 102 0))
34(defconstant single-float-epsilon (make-short-float-from-fixnums 1 103 0))
35(defconstant single-float-negative-epsilon (make-short-float-from-fixnums 1 102 0))
36
37(defconstant least-positive-normalized-short-float (make-short-float-from-fixnums 1 1 0))
38(defconstant least-negative-normalized-short-float (make-short-float-from-fixnums 1 1 -1))
39(defconstant least-positive-normalized-single-float (make-short-float-from-fixnums 1 1 0))
40(defconstant least-negative-normalized-single-float (make-short-float-from-fixnums 1 1 -1))
41
42(let ((bigfloat (make-float-from-fixnums #x1ffffff #xfffffff #x7fe 0)))
43  ; do it this way if you want to be able to compile before reading floats works 
44  (defconstant most-positive-double-float bigfloat)
45  (defconstant most-positive-long-float bigfloat)
46  )
47
48(let ((littleposfloat (make-float-from-fixnums 0 1 0 0 )))
49  (defconstant least-positive-double-float littleposfloat)
50  (defconstant least-positive-long-float littleposfloat)
51  )
52
53(let ((littlenegfloat (make-float-from-fixnums 0 1 0 -1))) 
54  (defconstant least-negative-double-float littlenegfloat)
55  (defconstant least-negative-long-float littlenegfloat)
56  )
57
58(let ((bignegfloat (make-float-from-fixnums #x1ffffff #xfffffff #x7fe -1)))
59  (defconstant most-negative-double-float bignegfloat)
60  (defconstant most-negative-long-float bignegfloat)
61  )
62
63(let ((eps (make-float-from-fixnums #x1000000 1 #x3ca 0))) ;was wrong
64  (defconstant double-float-epsilon eps)
65  (defconstant long-float-epsilon eps)
66  )
67
68(let ((eps- (make-float-from-fixnums #x1000000 1 #x3c9 1)))
69  (defconstant double-float-negative-epsilon eps-)
70  (defconstant long-float-negative-epsilon eps-)
71  )
72
73(let ((norm (make-float-from-fixnums 0 0 1 0)))
74  (defconstant least-positive-normalized-double-float norm)
75  (defconstant least-positive-normalized-long-float norm)
76  )
77
78(let ((norm- (make-float-from-fixnums 0 0 1 -1)))
79  (defconstant least-negative-normalized-double-float norm-)
80  (defconstant least-negative-normalized-long-float norm-)
81  )
82
83(defconstant pi (make-float-from-fixnums #x921fb5 #x4442d18 #x400 0))
84
85)
86
87
88
89(defconstant boole-clr 0
90  "Boole function op, makes BOOLE return 0.")
91(defconstant boole-set 1
92  "Boole function op, makes BOOLE return -1.")
93(defconstant boole-1 2
94  "Boole function op, makes BOOLE return integer1.")
95(defconstant boole-2 3
96  "Boole function op, makes BOOLE return integer2.")
97(defconstant boole-c1 4
98  "Boole function op, makes BOOLE return complement of integer1.")
99(defconstant boole-c2 5
100  "Boole function op, makes BOOLE return complement of integer2.")
101(defconstant boole-and 6
102  "Boole function op, makes BOOLE return logand of integer1 and integer2.")
103(defconstant boole-ior 7
104  "Boole function op, makes BOOLE return logior of integer1 and integer2.")
105(defconstant boole-xor 8
106  "Boole function op, makes BOOLE return logxor of integer1 and integer2.")
107(defconstant boole-eqv 9
108  "Boole function op, makes BOOLE return logeqv of integer1 and integer2.")
109(defconstant boole-nand 10
110  "Boole function op, makes BOOLE return log nand of integer1 and integer2.")
111(defconstant boole-nor 11
112  "Boole function op, makes BOOLE return lognor of integer1 and integer2.")
113(defconstant boole-andc1 12
114  "Boole function op, makes BOOLE return logandc1 of integer1 and integer2.")
115(defconstant boole-andc2 13
116  "Boole function op, makes BOOLE return logandc2 of integer1 and integer2.")
117(defconstant boole-orc1 14
118  "Boole function op, makes BOOLE return logorc1 of integer1 and integer2.")
119(defconstant boole-orc2 15
120  "Boole function op, makes BOOLE return logorc2 of integer1 and integer2.")
121
122
123
124(defconstant internal-time-units-per-second #+64-bit-target 1000000 #-64-bit-target 1000
125  "The number of internal time units that fit into a second. See
126  GET-INTERNAL-REAL-TIME and GET-INTERNAL-RUN-TIME.")
127
128(defconstant char-code-limit #.(arch::target-char-code-limit
129                                (backend-target-arch *target-backend*))
130  "the upper exclusive bound on values produced by CHAR-CODE")
131
132(defconstant array-rank-limit (floor #x8000 target::node-size)
133  "the exclusive upper bound on the rank of an array")
134(defconstant multiple-values-limit 200
135  "The exclusive upper bound on the number of multiple VALUES that you can
136  return.")
137(defconstant lambda-parameters-limit (floor #x8000 target::node-size)
138  "The exclusive upper bound on the number of parameters which may be specifed
139  in a given lambda list. This is actually the limit on required and &OPTIONAL
140  parameters. With &KEY and &AUX you can get more.")
141(defconstant call-arguments-limit (floor #x8000 target::node-size)
142  "The exclusive upper bound on the number of arguments which may be passed
143  to a function, including &REST args."
144)
145
146; Currently, vectors can be at most (expt 2 22) bytes, and
147; the largest element (double-float or long-float) is 8 bytes:
148#| to get largest element size...
149(apply #'max (mapcar #'(lambda (type)
150                         (%vect-byte-size (make-array 1 :element-type type)))
151                     *cl-types*))
152|#
153
154(defconstant array-dimension-limit array-total-size-limit
155  "the exclusive upper bound on any given dimension of an array")
156
157(defconstant most-positive-fixnum target::target-most-positive-fixnum
158  "the fixnum closest in value to positive infinity")
159(defconstant most-negative-fixnum target::target-most-negative-fixnum
160  "the fixnum closest in value to negative infinity")
161
162
163(defconstant lambda-list-keywords 
164  '(&OPTIONAL &REST &AUX &KEY &ALLOW-OTHER-KEYS &BODY &ENVIRONMENT &WHOLE)
165  "symbols which are magical in a lambda list")
166
167
168(defparameter %toplevel-catch% ':toplevel)
169
170(defvar *read-default-float-format* 'single-float)
171
172(defvar *read-suppress* nil
173  "Suppress most interpreting in the reader when T.")
174
175(defvar *read-base* 10.
176  "the radix that Lisp reads numbers in")
177
178
179(defparameter *warn-if-redefine-kernel* nil
180  "When true, attempts to redefine (via DEFUN or DEFMETHOD) functions and
181methods that are marked as being predefined signal continuable errors.")
182
183(defvar *next-screen-context-lines* 2 "Number of lines to show of old screen
184  after a scroll-up or scroll-down.")
185
186(defparameter *compiling-file* nil 
187  "Name of outermost file being compiled or NIL if not compiling a file.")
188
189(defvar *eval-fn-name* nil)
190
191
192(defvar *compile-definitions* t
193  "When non-NIL and the evaluator's lexical environment contains no
194  lexical entities, causes FUNCTION and NFUNCTION forms to be compiled.")
195#|
196(defvar *fast-eval* ()
197  "If non-nil, compile-and-call any forms which would be expensive to evaluate.")
198|#
199(defvar *declaration-handlers* ())
200
201
202(defvar *lisp-system-pointer-functions* nil)
203(defvar *lisp-user-pointer-functions* nil)
204(defvar *lisp-cleanup-functions* nil)   ; list of (0-arg) functions to call before quitting Lisp
205(defvar *lisp-startup-functions* nil)   ; list of funs to call after startup.
206(defvar %lisp-system-fixups% nil)
207
208
209(setf (*%saved-method-var%*) nil)
210
211; The GC expects these to be NIL or a function of no args
212(defvar *pre-gc-hook* nil)
213(defvar *post-gc-hook* nil)
214
215; These are used by add-gc-hook, delete-gc-hook
216(defvar *pre-gc-hook-list* nil)
217(defvar *post-gc-hook-list* nil)
218
219(defvar *backtrace-dialogs* nil)
220;(defvar *stepper-running* nil)
221(defparameter *last-mouse-down-time* 0)
222(defparameter *last-mouse-down-position* 0)
223
224(defvar %handlers% ())
225
226
227#|
228(defvar %restarts% (list (list (%cons-restart 'abort
229                                              #'(lambda (&rest ignore)
230                                                  (declare (ignore ignore))
231                                                  (throw :toplevel nil))
232                                              "Restart the toplevel loop."
233                                              nil
234                                              nil))))
235|#
236
237(defvar %restarts% nil)
238
239(defvar ccl::*kernel-restarts* nil)
240(defvar *condition-restarts* nil "explicit mapping between c & r")
241(declaim (type list %handlers% %restarts% ccl::*kernel-restarts* *condition-restarts*))
242
243
244
245
246(defparameter *%periodic-tasks%* nil)
247(defparameter *dribble-stream* nil)
248
249(defconstant *keyword-package* *keyword-package*)
250(defconstant *common-lisp-package* *common-lisp-package*)
251(defconstant *ccl-package* *ccl-package*)
252
253(defparameter *load-print* nil "the default for the :PRINT argument to LOAD")
254(defparameter *loading-files* nil)
255(defparameter *break-level* 0)
256(defparameter *last-break-level* 0)
257(defparameter *warn-if-redefine* nil)
258(defvar *record-source-file*)           ; set in l1-utils.
259(defparameter *level-1-loaded* nil)     ; set t by l1-boot
260(defparameter *save-definitions* nil)
261(defparameter *save-local-symbols* t)
262(defparameter *save-source-locations* :no-text
263  "Controls whether complete source locations is stored, both for definitions (names) and
264in function objects.
265
266If NIL we don't store any source location (other than the filename if *record-source-file* is non-NIL).
267
268If T we store as much source location information as we have available.
269
270If :NO-TEXT we don't store a copy of the original source text.")
271(defparameter *record-pc-mapping* t)
272
273(defvar *modules* nil
274  "This is a list of module names that have been loaded into Lisp so far.
275   The names are case sensitive strings.  It is used by PROVIDE and REQUIRE.")
276
277
278
279
280
281(defparameter *eof-value* (cons nil nil))
282
283(defvar *gc-event-status-bits*)         ; also initialized by kernel
284
285(defparameter *top-listener* nil)
286
287
288
289
290
291
292
293(defvar *listener-indent* nil)
294
295(defparameter *autoload-lisp-package* nil)   ; Make 'em suffer
296(defparameter *apropos-case-sensitive-p* nil)
297
298(defloadvar *total-gc-microseconds* (let* ((timeval-size
299                                            #.(%foreign-type-or-record-size
300                                               :timeval :bytes))
301                                           (p (malloc (* 5 timeval-size))))
302                                      (#_memset p 0 (* 5 timeval-size))
303                                      p))
304
305
306(defloadvar *total-bytes-freed* (let* ((p (malloc 8)))
307                                  (setf (%get-long p 0) 0
308                                        (%get-long p 4) 0)
309                                  p))
310
311
312
313(defvar *terminal-character-encoding-name* nil
314  "NIL (implying :ISO-8859-1), or a keyword which names a defined
315character encoding to be used for *TERMINAL-IO* and other predefined
316initial streams.  The value of *TERMINAL-CHARACTER-ENCODING-NAME*
317persists across calls to SAVE-APPLICATION; it can be specified via
318the command-line argument --terminal-encoding (-K)")
319
320
321(defconstant +null-ptr+ (%null-ptr))
322
323;;; end of L1-init.lisp
324
Note: See TracBrowser for help on using the repository browser.