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

Last change on this file since 11896 was 11896, checked in by ehuelsmann, 9 years ago

Followup to r11892: use the field class too
when caching, the caller assumes that specific
class.

Note to self: this definitely needs cleanup later.

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