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

Last change on this file since 11820 was 11820, checked in by ehuelsmann, 14 years ago

Make local GO restore the environment of the TAGBODY,
in case it jumps out of blocks setting the environment.
  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 15.6 KB
Line 
1;;; jvm.lisp
2;;;
3;;; Copyright (C) 2003-2008 Peter Graves
4;;; $Id: jvm.lisp 11820 2009-05-03 10:10:21Z 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 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 (char= (char name i) #\-)
116        (setf (char name i) #\_)))
117    (concatenate 'string "org/armedbear/lisp/" name)))
118
119(defun make-class-file (&key pathname lambda-name lambda-list)
120  (aver (not (null pathname)))
121  (let ((class-file (%make-class-file :pathname pathname
122                                      :lambda-name lambda-name
123                                      :lambda-list lambda-list)))
124    (setf (class-file-class class-file) (class-name-from-filespec pathname))
125    class-file))
126
127(defmacro with-class-file (class-file &body body)
128  (let ((var (gensym)))
129    `(let* ((,var ,class-file)
130            (*pool*               (class-file-pool ,var))
131            (*pool-count*         (class-file-pool-count ,var))
132            (*pool-entries*       (class-file-pool-entries ,var))
133            (*fields*             (class-file-fields ,var))
134            (*static-code*        (class-file-static-code ,var))
135            (*declared-symbols*   (class-file-symbols ,var))
136            (*declared-functions* (class-file-functions ,var))
137            (*declared-strings*   (class-file-strings ,var))
138            (*declared-integers*  (class-file-integers ,var))
139            (*declared-floats*    (class-file-floats ,var))
140            (*declared-doubles*   (class-file-doubles ,var)))
141       (progn ,@body)
142       (setf (class-file-pool ,var)         *pool*
143             (class-file-pool-count ,var)   *pool-count*
144             (class-file-pool-entries ,var) *pool-entries*
145             (class-file-fields ,var)       *fields*
146             (class-file-static-code ,var)  *static-code*
147             (class-file-symbols ,var)      *declared-symbols*
148             (class-file-functions ,var)    *declared-functions*
149             (class-file-strings ,var)      *declared-strings*
150             (class-file-integers ,var)     *declared-integers*
151             (class-file-floats ,var)       *declared-floats*
152             (class-file-doubles ,var)      *declared-doubles*))))
153
154(defstruct compiland
155  name
156  (kind :external) ; :INTERNAL or :EXTERNAL
157  lambda-expression
158  arg-vars
159  arity ; NIL if the number of args can vary.
160  p1-result
161  parent
162  (children 0 :type fixnum) ; Number of local functions defined with FLET or LABELS.
163  argument-register
164  closure-register
165  environment-register
166  class-file ; class-file object
167  (%single-valued-p t))
168
169(defknown compiland-single-valued-p (t) t)
170(defun compiland-single-valued-p (compiland)
171  (unless (compiland-parent compiland)
172    (let ((name (compiland-name compiland)))
173      (when name
174        (let ((result-type
175               (or (function-result-type name)
176                   (and (proclaimed-ftype name)
177                        (ftype-result-type (proclaimed-ftype name))))))
178          (when result-type
179            (return-from compiland-single-valued-p
180                         (cond ((eq result-type '*)
181                                nil)
182                               ((atom result-type)
183                                t)
184                               ((eq (%car result-type) 'VALUES)
185                                (= (length result-type) 2))
186                               (t
187                                t))))))))
188  ;; Otherwise...
189  (compiland-%single-valued-p compiland))
190
191(defvar *current-compiland* nil)
192
193(defvar *this-class* nil)
194
195(defvar *code* ())
196
197;; All tags visible at the current point of compilation, some of which may not
198;; be in the current compiland.
199(defvar *visible-tags* ())
200
201;; The next available register.
202(defvar *register* 0)
203
204;; Total number of registers allocated.
205(defvar *registers-allocated* 0)
206
207(defvar *handlers* ())
208
209(defstruct handler
210  from
211  to
212  code
213  catch-type)
214
215;; Variables visible at the current point of compilation.
216(defvar *visible-variables* nil)
217
218;; All variables seen so far.
219(defvar *all-variables* nil)
220
221;; Undefined variables that we've already warned about.
222(defvar *undefined-variables* nil)
223
224(defvar *dump-variables* nil)
225
226(defun dump-1-variable (variable)
227  (sys::%format t "  ~S special-p = ~S register = ~S index = ~S declared-type = ~S~%"
228           (variable-name variable)
229           (variable-special-p variable)
230           (variable-register variable)
231           (variable-index variable)
232           (variable-declared-type variable)))
233
234(defun dump-variables (list caption &optional (force nil))
235  (when (or force *dump-variables*)
236    (write-string caption)
237    (if list
238        (dolist (variable list)
239          (dump-1-variable variable))
240        (sys::%format t "  None.~%"))))
241
242(defstruct (variable-info (:conc-name variable-)
243                          (:constructor make-variable)
244                          (:predicate variable-p))
245  name
246  initform
247  temp-register
248  (declared-type :none)
249  (derived-type :none)
250  ignore-p
251  ignorable-p
252  representation
253  special-p     ; indicates whether a variable is special
254  register      ; register number for a local variable
255  index         ; index number for a variable in the argument array
256  closure-index ; index number for a variable in the closure context array
257    ;; a variable can be either special-p *or* have a register *or*
258    ;; have an index *or a closure-index
259  reserved-register
260  (reads 0 :type fixnum)
261  (writes 0 :type fixnum)
262  references
263  used-non-locally-p
264  (compiland *current-compiland*))
265
266(defstruct (var-ref (:constructor make-var-ref (variable)))
267  ;; The variable this reference refers to. Will be NIL if the VAR-REF has been
268  ;; rewritten to reference a constant value.
269  variable
270  ;; True if the VAR-REF has been rewritten to reference a constant value.
271  constant-p
272  ;; The constant value of this VAR-REF.
273  constant-value)
274
275;; obj can be a symbol or variable
276;; returns variable or nil
277(declaim (ftype (function (t) t) unboxed-fixnum-variable))
278(defun unboxed-fixnum-variable (obj)
279  (cond ((symbolp obj)
280         (let ((variable (find-visible-variable obj)))
281           (if (and variable
282                    (eq (variable-representation variable) :int))
283               variable
284               nil)))
285        ((variable-p obj)
286         (if (eq (variable-representation obj) :int)
287             obj
288             nil))
289        (t
290         nil)))
291
292(defvar *child-p* nil
293  "True for local functions created by FLET, LABELS and (NAMED-)LAMBDA")
294
295(defknown find-variable (symbol list) t)
296(defun find-variable (name variables)
297  (dolist (variable variables)
298    (when (eq name (variable-name variable))
299      (return variable))))
300
301(defknown find-visible-variable (t) t)
302(defun find-visible-variable (name)
303  (dolist (variable *visible-variables*)
304    (when (eq name (variable-name variable))
305      (return variable))))
306
307(defknown allocate-register () (integer 0 65535))
308(defun allocate-register ()
309  (let* ((register *register*)
310         (next-register (1+ register)))
311    (declare (type (unsigned-byte 16) register next-register))
312    (setf *register* next-register)
313    (when (< *registers-allocated* next-register)
314      (setf *registers-allocated* next-register))
315    register))
316
317(defknown allocate-register-pair () (integer 0 65535))
318(defun allocate-register-pair ()
319  (let* ((register *register*)
320         (next-register (+ register 2)))
321    (declare (type (unsigned-byte 16) register next-register))
322    (setf *register* next-register)
323    (when (< *registers-allocated* next-register)
324      (setf *registers-allocated* next-register))
325    register))
326
327(defstruct local-function
328  name
329  compiland
330  inline-expansion
331  function
332  class-file
333  variable)
334
335(defvar *local-functions* ())
336
337(defknown find-local-function (t) t)
338(defun find-local-function (name)
339  (dolist (local-function *local-functions* nil)
340    (when (equal name (local-function-name local-function))
341        (return local-function))))
342
343(defvar *using-arg-array* nil)
344(defvar *hairy-arglist-p* nil)
345
346(defstruct node
347  ;; Block name or (TAGBODY) or (LET) or (MULTIPLE-VALUE-BIND).
348  name
349  form
350  (compiland *current-compiland*))
351
352;; Used to wrap TAGBODYs, UNWIND-PROTECTs and LET/LET*/M-V-B forms as well as
353;; BLOCKs per se.
354(defstruct (block-node (:conc-name block-) (:include node) (:constructor make-block-node (name)))
355  (exit (gensym))
356  target
357  catch-tag
358  ;; True if there is any RETURN from this block.
359  return-p
360  ;; True if there is a non-local RETURN from this block.
361  non-local-return-p
362  ;; True if a tag in this tagbody is the target of a non-local GO.
363  non-local-go-p
364  ;; If non-nil, the TAGBODY contains local blocks which "contaminate" the
365  ;; environment, with GO forms in them which target tags in this TAGBODY
366  needs-environment-restoration
367  ;; If non-nil, register containing saved dynamic environment for this block.
368  environment-register
369  ;; Only used in LET/LET*/M-V-B nodes.
370  vars
371  free-specials
372  )
373
374(defvar *blocks* ())
375
376(defun find-block (name)
377  (dolist (block *blocks*)
378    (when (eq name (block-name block))
379      (return block))))
380
381(defknown node-constant-p (t) boolean)
382(defun node-constant-p (object)
383  (cond ((block-node-p object)
384         nil)
385        ((var-ref-p object)
386         nil)
387        ((constantp object)
388         t)
389        (t
390         nil)))
391
392(defknown block-requires-non-local-exit-p (t) boolean)
393(defun block-requires-non-local-exit-p (object)
394  "A block which *always* requires a 'non-local-exit' is a block which
395requires a transfer control exception to be thrown: e.g. Go and Return.
396
397Non-local exits are required by blocks which do more in their cleanup
398than just restore the lastSpecialBinding (= dynamic environment).
399"
400  (memq (block-name object) '(CATCH UNWIND-PROTECT)))
401
402
403(defknown enclosed-by-protected-block-p (&optional outermost-block) boolean)
404(defun enclosed-by-protected-block-p (&optional outermost-block)
405  "Indicates whether the code being compiled/analyzed is enclosed in
406a block which requires a non-local transfer of control exception to
407be generated.
408"
409  (dolist (enclosing-block *blocks*)
410    (when (eq enclosing-block outermost-block)
411      (return-from enclosed-by-protected-block-p nil))
412    (when (block-requires-non-local-exit-p enclosing-block)
413      (return-from enclosed-by-protected-block-p t))))
414
415(defknown enclosed-by-environment-setting-block-p (&optional outermost-block)
416  boolean)
417(defun enclosed-by-environment-setting-block-p (&optional outermost-block)
418  (dolist (enclosing-block *blocks*)
419    (when (eq enclosing-block outermost-block)
420      (return nil))
421    (when (block-environment-register enclosing-block)
422      (return t))))
423
424(defstruct tag
425  name
426  label
427  block
428  (compiland *current-compiland*))
429
430(defknown find-tag (t) t)
431(defun find-tag (name)
432  (dolist (tag *visible-tags*)
433    (when (eql name (tag-name tag))
434      (return tag))))
435
436(defun process-ignore/ignorable (declaration names variables)
437  (when (memq declaration '(IGNORE IGNORABLE))
438    (let ((what (if (eq declaration 'IGNORE) "ignored" "ignorable")))
439      (dolist (name names)
440        (let ((variable (find-variable name variables)))
441          (cond ((null variable)
442                 (compiler-style-warn "Declaring unknown variable ~S to be ~A."
443                                      name what))
444                ((variable-special-p variable)
445                 (compiler-style-warn "Declaring special variable ~S to be ~A."
446                                      name what))
447                ((eq declaration 'IGNORE)
448                 (setf (variable-ignore-p variable) t))
449                (t
450                 (setf (variable-ignorable-p variable) t))))))))
451
452(defvar *file-compilation* nil)
453(defvar *pathnames-generator* #'make-temp-file)
454
455(defun compile (name &optional definition)
456  (let ((*file-compilation* nil)
457        (*pathnames-generator* #'make-temp-file)
458        (sys::*fasl-anonymous-package* (sys::%make-package)))
459    (jvm-compile name definition)))
460
461(defmacro with-file-compilation (&body body)
462  `(let ((*file-compilation* t)
463         (*pathnames-generator* #'sys::next-classfile-name))
464     ,@body))
465
466(defun finalize-generic-functions ()
467  (dolist (sym '(make-instance
468                 initialize-instance
469                 shared-initialize))
470    (let ((gf (and (fboundp sym) (fdefinition sym))))
471      (when (typep gf 'generic-function)
472        (unless (compiled-function-p gf)
473          (mop::finalize-generic-function gf))))))
474
475(finalize-generic-functions)
476
477(provide 'jvm)
Note: See TracBrowser for help on using the repository browser.