source: trunk/abcl/src/org/armedbear/lisp/jvm.lisp @ 12091

Last change on this file since 12091 was 12091, checked in by ehuelsmann, 12 years ago

Remove condition from another era

(when TAGBODY-s used to store a environment themselves).

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 17.8 KB
Line 
1;;; jvm.lisp
2;;;
3;;; Copyright (C) 2003-2008 Peter Graves
4;;; $Id: jvm.lisp 12091 2009-08-11 11:35:39Z ehuelsmann $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
19;;;
20;;; As a special exception, the copyright holders of this library give you
21;;; permission to link this library with independent modules to produce an
22;;; executable, regardless of the license terms of these independent
23;;; modules, and to copy and distribute the resulting executable under
24;;; terms of your choice, provided that you also meet, for each linked
25;;; independent module, the terms and conditions of the license of that
26;;; module.  An independent module is a module which is not derived from
27;;; or based on this library.  If you modify this library, you may extend
28;;; this exception to your version of the library, but you are not
29;;; obligated to do so.  If you do not wish to do so, delete this
30;;; exception statement from your version.
31
32(in-package "JVM")
33
34(export '(compile-defun *catch-errors* jvm-compile-package
35          derive-compiler-type))
36
37(eval-when (:compile-toplevel :load-toplevel :execute)
38  (require "LOOP")
39  (require "FORMAT")
40  (require "CLOS")
41  (require "PRINT-OBJECT")
42  (require "COMPILER-TYPES")
43  (require "KNOWN-FUNCTIONS")
44  (require "KNOWN-SYMBOLS")
45  (require "DUMP-FORM")
46  (require "OPCODES")
47  (require "JAVA")
48  (require "COMPILER-PASS1")
49  (require "COMPILER-PASS2"))
50
51(defvar *closure-variables* nil)
52
53(defvar *enable-dformat* nil)
54
55#+nil
56(defun dformat (destination control-string &rest args)
57  (when *enable-dformat*
58    (apply #'sys::%format destination control-string args)))
59
60(defmacro dformat (&rest ignored)
61  (declare (ignore ignored)))
62
63
64(defmacro with-saved-compiler-policy (&body body)
65  "Saves compiler policy variables, restoring them after evaluating `body'."
66  `(let ((*speed* *speed*)
67         (*space* *space*)
68         (*safety* *safety*)
69         (*debug* *debug*)
70         (*explain* *explain*)
71         (*inline-declarations* *inline-declarations*))
72     ,@body))
73
74
75
76(defvar *compiler-debug* nil)
77
78(defvar *pool* nil)
79(defvar *pool-count* 1)
80(defvar *pool-entries* nil)
81(defvar *fields* ())
82(defvar *static-code* ())
83
84(defvar *declared-symbols* nil)
85(defvar *declared-functions* nil)
86(defvar *declared-strings* nil)
87(defvar *declared-integers* nil)
88(defvar *declared-floats* nil)
89(defvar *declared-doubles* nil)
90
91(defstruct (class-file (:constructor %make-class-file))
92  pathname ; pathname of output file
93  lambda-name
94  class
95  superclass
96  lambda-list ; as advertised
97  pool
98  (pool-count 1)
99  (pool-entries (make-hash-table :test #'equal))
100  fields
101  methods
102  static-code
103  (symbols (make-hash-table :test 'eq))
104  (functions (make-hash-table :test 'equal))
105  (strings (make-hash-table :test 'eq))
106  (integers (make-hash-table :test 'eql))
107  (floats (make-hash-table :test 'eql))
108  (doubles (make-hash-table :test 'eql)))
109
110(defun class-name-from-filespec (filespec)
111  (let* ((name (pathname-name filespec)))
112    (declare (type string name))
113    (dotimes (i (length name))
114      (declare (type fixnum i))
115      (when (or (char= (char name i) #\-)
116    (char= (char name i) #\Space))
117        (setf (char name i) #\_)))
118    (concatenate 'string "org/armedbear/lisp/" name)))
119
120(defun make-class-file (&key pathname lambda-name lambda-list)
121  (aver (not (null pathname)))
122  (let ((class-file (%make-class-file :pathname pathname
123                                      :lambda-name lambda-name
124                                      :lambda-list lambda-list)))
125    (setf (class-file-class class-file) (class-name-from-filespec pathname))
126    class-file))
127
128(defmacro with-class-file (class-file &body body)
129  (let ((var (gensym)))
130    `(let* ((,var ,class-file)
131            (*pool*               (class-file-pool ,var))
132            (*pool-count*         (class-file-pool-count ,var))
133            (*pool-entries*       (class-file-pool-entries ,var))
134            (*fields*             (class-file-fields ,var))
135            (*static-code*        (class-file-static-code ,var))
136            (*declared-symbols*   (class-file-symbols ,var))
137            (*declared-functions* (class-file-functions ,var))
138            (*declared-strings*   (class-file-strings ,var))
139            (*declared-integers*  (class-file-integers ,var))
140            (*declared-floats*    (class-file-floats ,var))
141            (*declared-doubles*   (class-file-doubles ,var)))
142       (progn ,@body)
143       (setf (class-file-pool ,var)         *pool*
144             (class-file-pool-count ,var)   *pool-count*
145             (class-file-pool-entries ,var) *pool-entries*
146             (class-file-fields ,var)       *fields*
147             (class-file-static-code ,var)  *static-code*
148             (class-file-symbols ,var)      *declared-symbols*
149             (class-file-functions ,var)    *declared-functions*
150             (class-file-strings ,var)      *declared-strings*
151             (class-file-integers ,var)     *declared-integers*
152             (class-file-floats ,var)       *declared-floats*
153             (class-file-doubles ,var)      *declared-doubles*))))
154
155(defstruct compiland
156  name
157  lambda-expression
158  arg-vars          ; variables for lambda arguments
159  free-specials     ;
160  arity             ; number of args, or NIL if the number of args can vary.
161  p1-result         ; the parse tree as created in pass 1
162  parent            ; the parent for compilands which defined within another
163  (children 0       ; Number of local functions
164            :type fixnum) ; defined with with FLET, LABELS or LAMBDA
165  blocks            ; TAGBODY, PROGV, BLOCK, etc. blocks
166  argument-register
167  closure-register
168  environment-register
169  class-file ; class-file object
170  (%single-valued-p t))
171
172(defknown compiland-single-valued-p (t) t)
173(defun compiland-single-valued-p (compiland)
174  (unless (compiland-parent compiland)
175    (let ((name (compiland-name compiland)))
176      (when name
177        (let ((result-type
178               (or (function-result-type name)
179                   (and (proclaimed-ftype name)
180                        (ftype-result-type (proclaimed-ftype name))))))
181          (when result-type
182            (return-from compiland-single-valued-p
183                         (cond ((eq result-type '*)
184                                nil)
185                               ((atom result-type)
186                                t)
187                               ((eq (%car result-type) 'VALUES)
188                                (= (length result-type) 2))
189                               (t
190                                t))))))))
191  ;; Otherwise...
192  (compiland-%single-valued-p compiland))
193
194(defvar *current-compiland* nil)
195
196(defvar *this-class* nil)
197
198(defvar *code* ())
199
200;; All tags visible at the current point of compilation, some of which may not
201;; be in the current compiland.
202(defvar *visible-tags* ())
203
204;; The next available register.
205(defvar *register* 0)
206
207;; Total number of registers allocated.
208(defvar *registers-allocated* 0)
209
210(defvar *handlers* ())
211
212(defstruct handler
213  from       ;; label indicating the start of the protected block
214  to         ;; label indicating the end of the protected block
215  code       ;; label to jump to if the specified exception occurs
216  catch-type ;; pool index of the class name of the exception, or 0 (zero)
217             ;; for 'all'
218  )
219
220;; Variables visible at the current point of compilation.
221(defvar *visible-variables* nil
222  "All variables visible to the form currently being
223processed, including free specials.")
224
225;; All variables seen so far.
226(defvar *all-variables* nil
227  "All variables in the lexical scope (thus excluding free specials)
228of the compilands being processed (p1: so far; p2: in total).")
229
230;; Undefined variables that we've already warned about.
231(defvar *undefined-variables* nil)
232
233(defvar *dump-variables* nil)
234
235(defun dump-1-variable (variable)
236  (sys::%format t "  ~S special-p = ~S register = ~S index = ~S declared-type = ~S~%"
237           (variable-name variable)
238           (variable-special-p variable)
239           (variable-register variable)
240           (variable-index variable)
241           (variable-declared-type variable)))
242
243(defun dump-variables (list caption &optional (force nil))
244  (when (or force *dump-variables*)
245    (write-string caption)
246    (if list
247        (dolist (variable list)
248          (dump-1-variable variable))
249        (sys::%format t "  None.~%"))))
250
251(defstruct (variable-info (:conc-name variable-)
252                          (:constructor make-variable)
253                          (:predicate variable-p))
254  name
255  initform
256  (declared-type :none)
257  (derived-type :none)
258  ignore-p
259  ignorable-p
260  representation
261  special-p     ; indicates whether a variable is special
262  register      ; register number for a local variable
263  index         ; index number for a variable in the argument array
264  closure-index ; index number for a variable in the closure context array
265  environment   ; the environment for the variable, if we're compiling in
266                ; a non-null lexical environment with variables
267    ;; a variable can be either special-p *or* have a register *or*
268    ;; have an index *or* a closure-index *or* an environment
269  (reads 0 :type fixnum)
270  (writes 0 :type fixnum)
271  references
272  (references-allowed-p t) ; NIL if this is a symbol macro in the enclosing
273                           ; lexical environment
274  used-non-locally-p
275  (compiland *current-compiland*)
276  block)
277
278(defstruct (var-ref (:constructor make-var-ref (variable)))
279  ;; The variable this reference refers to. Will be NIL if the VAR-REF has been
280  ;; rewritten to reference a constant value.
281  variable
282  ;; True if the VAR-REF has been rewritten to reference a constant value.
283  constant-p
284  ;; The constant value of this VAR-REF.
285  constant-value)
286
287;; obj can be a symbol or variable
288;; returns variable or nil
289(declaim (ftype (function (t) t) unboxed-fixnum-variable))
290(defun unboxed-fixnum-variable (obj)
291  (cond ((symbolp obj)
292         (let ((variable (find-visible-variable obj)))
293           (if (and variable
294                    (eq (variable-representation variable) :int))
295               variable
296               nil)))
297        ((variable-p obj)
298         (if (eq (variable-representation obj) :int)
299             obj
300             nil))
301        (t
302         nil)))
303
304(defvar *child-p* nil
305  "True for local functions created by FLET, LABELS and (NAMED-)LAMBDA")
306
307(defknown find-variable (symbol list) t)
308(defun find-variable (name variables)
309  (dolist (variable variables)
310    (when (eq name (variable-name variable))
311      (return variable))))
312
313(defknown find-visible-variable (t) t)
314(defun find-visible-variable (name)
315  (dolist (variable *visible-variables*)
316    (when (eq name (variable-name variable))
317      (return variable))))
318
319(defknown allocate-register () (integer 0 65535))
320(defun allocate-register ()
321  (let* ((register *register*)
322         (next-register (1+ register)))
323    (declare (type (unsigned-byte 16) register next-register))
324    (setf *register* next-register)
325    (when (< *registers-allocated* next-register)
326      (setf *registers-allocated* next-register))
327    register))
328
329(defknown allocate-register-pair () (integer 0 65535))
330(defun allocate-register-pair ()
331  (let* ((register *register*)
332         (next-register (+ register 2)))
333    (declare (type (unsigned-byte 16) register next-register))
334    (setf *register* next-register)
335    (when (< *registers-allocated* next-register)
336      (setf *registers-allocated* next-register))
337    register))
338
339(defstruct local-function
340  name
341  compiland
342  inline-expansion
343  function    ;; the function loaded through load-compiled-function
344  class-file  ;; the class file structure for this function
345  variable    ;; the variable which contains the loaded compiled function
346              ;; or compiled closure
347  environment ;; the environment in which the function is stored in
348              ;; case of a function from an enclosing lexical environment
349              ;; which itself isn't being compiled
350  (references-allowed-p t)
351  )
352
353(defvar *local-functions* ())
354
355(defknown find-local-function (t) t)
356(defun find-local-function (name)
357  (dolist (local-function *local-functions* nil)
358    (when (equal name (local-function-name local-function))
359        (return local-function))))
360
361(defvar *using-arg-array* nil)
362(defvar *hairy-arglist-p* nil)
363
364(defstruct node
365  ;; Block name or (TAGBODY) or (LET) or (MULTIPLE-VALUE-BIND).
366  name
367  form
368  (compiland *current-compiland*))
369
370;; Used to wrap TAGBODYs, UNWIND-PROTECTs and LET/LET*/M-V-B forms as well as
371;; BLOCKs per se.
372(defstruct (block-node (:conc-name block-)
373                       (:include node)
374                       (:constructor %make-block-node (name)))
375  (exit (gensym))
376  target
377  catch-tag
378  ;; True if there is any RETURN from this block.
379  return-p
380  ;; True if there is a non-local RETURN from this block.
381  non-local-return-p
382  ;; True if a tag in this tagbody is the target of a non-local GO.
383  non-local-go-p
384  ;; If non-nil, the TAGBODY contains local blocks which "contaminate" the
385  ;; environment, with GO forms in them which target tags in this TAGBODY
386  ;; Non-nil if and only if the block doesn't modify the environment
387  needs-environment-restoration
388  ;; If non-nil, register containing saved dynamic environment for this block.
389  environment-register
390  ;; Only used in LET/LET*/M-V-B nodes.
391  vars
392  free-specials
393  ;; Only used in TAGBODY
394  tags
395  )
396
397(defvar *blocks* ())
398
399(defknown make-block-node (t) t)
400(defun make-block-node (name)
401  (let ((block (%make-block-node name)))
402    (push block (compiland-blocks *current-compiland*))
403    block))
404
405(defun find-block (name)
406  (dolist (block *blocks*)
407    (when (eq name (block-name block))
408      (return block))))
409
410(defknown node-constant-p (t) boolean)
411(defun node-constant-p (object)
412  (cond ((block-node-p object)
413         nil)
414        ((var-ref-p object)
415         nil)
416        ((constantp object)
417         t)
418        (t
419         nil)))
420
421(defknown block-requires-non-local-exit-p (t) boolean)
422(defun block-requires-non-local-exit-p (object)
423  "A block which *always* requires a 'non-local-exit' is a block which
424requires a transfer control exception to be thrown: e.g. Go and Return.
425
426Non-local exits are required by blocks which do more in their cleanup
427than just restore the lastSpecialBinding (= dynamic environment).
428"
429  (let ((name (block-name object)))
430    (or (equal name '(CATCH))
431        (equal name '(UNWIND-PROTECT))
432        (equal name '(THREADS:SYNCHRONIZED-ON)))))
433
434
435(defknown enclosed-by-protected-block-p (&optional t) boolean)
436(defun enclosed-by-protected-block-p (&optional outermost-block)
437  "Indicates whether the code being compiled/analyzed is enclosed in
438a block which requires a non-local transfer of control exception to
439be generated.
440"
441  (dolist (enclosing-block *blocks*)
442    (when (eq enclosing-block outermost-block)
443      (return-from enclosed-by-protected-block-p nil))
444    (when (block-requires-non-local-exit-p enclosing-block)
445      (return-from enclosed-by-protected-block-p t))))
446
447(defknown enclosed-by-environment-setting-block-p (&optional t) boolean)
448(defun enclosed-by-environment-setting-block-p (&optional outermost-block)
449  (dolist (enclosing-block *blocks*)
450    (when (eq enclosing-block outermost-block)
451      (return nil))
452    (when (and (block-environment-register enclosing-block))
453      (return t))))
454
455(defknown environment-register-to-restore (&optional t) t)
456(defun environment-register-to-restore (&optional outermost-block)
457  "Returns the environment register which contains the
458saved environment from the outermost enclosing block:
459
460That's the one which contains the environment used in the outermost block."
461  (flet ((outermost-register (last-register block)
462           (when (eq block outermost-block)
463             (return-from environment-register-to-restore last-register))
464           (or (block-environment-register block)
465               last-register)))
466    (reduce #'outermost-register *blocks*
467            :initial-value nil)))
468
469(defstruct tag
470  ;; The symbol (or integer) naming the tag
471  name
472  ;; The symbol which is the jump target in JVM byte code
473  label
474  ;; The associated TAGBODY
475  block
476  (compiland *current-compiland*)
477  used)
478
479(defknown find-tag (t) t)
480(defun find-tag (name)
481  (dolist (tag *visible-tags*)
482    (when (eql name (tag-name tag))
483      (return tag))))
484
485(defun process-ignore/ignorable (declaration names variables)
486  (when (memq declaration '(IGNORE IGNORABLE))
487    (let ((what (if (eq declaration 'IGNORE) "ignored" "ignorable")))
488      (dolist (name names)
489        (unless (and (consp name) (eq (car name) 'FUNCTION))
490          (let ((variable (find-variable name variables)))
491            (cond ((null variable)
492                   (compiler-style-warn "Declaring unknown variable ~S to be ~A."
493                                        name what))
494                  ((variable-special-p variable)
495                   (compiler-style-warn "Declaring special variable ~S to be ~A."
496                                        name what))
497                  ((eq declaration 'IGNORE)
498                   (setf (variable-ignore-p variable) t))
499                  (t
500                   (setf (variable-ignorable-p variable) t)))))))))
501
502(defun finalize-generic-functions ()
503  (dolist (sym '(make-instance
504                 initialize-instance
505                 shared-initialize))
506    (let ((gf (and (fboundp sym) (fdefinition sym))))
507      (when (typep gf 'generic-function)
508        (unless (compiled-function-p gf)
509          (mop::finalize-generic-function gf))))))
510
511(finalize-generic-functions)
512
513(provide 'jvm)
Note: See TracBrowser for help on using the repository browser.