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

Last change on this file since 13025 was 13025, checked in by astalla, 11 years ago

Added with-code-to-method to pass2 to compile the constructor and, in the future, the static initializer.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 23.8 KB
Line 
1;;; jvm.lisp
2;;;
3;;; Copyright (C) 2003-2008 Peter Graves
4;;; $Id: jvm.lisp 13025 2010-11-16 19:40:03Z astalla $
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 "COMPILER-ERROR")
44  (require "KNOWN-FUNCTIONS")
45  (require "DUMP-FORM")
46  (require "JVM-INSTRUCTIONS")
47  (require "JVM-CLASS-FILE")
48  (require "KNOWN-SYMBOLS")
49  (require "JAVA")
50  (require "COMPILER-PASS1")
51  (require "COMPILER-PASS2"))
52
53(defvar *closure-variables* nil)
54
55(defvar *enable-dformat* nil)
56
57#+nil
58(defun dformat (destination control-string &rest args)
59  (when *enable-dformat*
60    (apply #'sys::%format destination control-string args)))
61
62(defmacro dformat (&rest ignored)
63  (declare (ignore ignored)))
64
65(declaim (inline u2 s1 s2))
66
67(defknown u2 (fixnum) cons)
68(defun u2 (n)
69  (declare (optimize speed))
70  (declare (type (unsigned-byte 16) n))
71  (when (not (<= 0 n 65535))
72    (error "u2 argument ~A out of 65k range." n))
73  (list (logand (ash n -8) #xff)
74        (logand n #xff)))
75
76(defknown s1 (fixnum) fixnum)
77(defun s1 (n)
78  (declare (optimize speed))
79  (declare (type (signed-byte 8) n))
80  (when (not (<= -128 n 127))
81    (error "s2 argument ~A out of 16-bit signed range." n))
82  (if (< n 0)
83      (1+ (logxor (- n) #xFF))
84      n))
85
86
87(defknown s2 (fixnum) cons)
88(defun s2 (n)
89  (declare (optimize speed))
90  (declare (type (signed-byte 16) n))
91  (when (not (<= -32768 n 32767))
92    (error "s2 argument ~A out of 16-bit signed range." n))
93  (u2 (if (< n 0) (1+ (logxor (- n) #xFFFF))
94          n)))
95
96
97
98
99
100(defmacro with-saved-compiler-policy (&body body)
101  "Saves compiler policy variables, restoring them after evaluating `body'."
102  `(let ((*speed* *speed*)
103         (*space* *space*)
104         (*safety* *safety*)
105         (*debug* *debug*)
106         (*explain* *explain*)
107         (*inline-declarations* *inline-declarations*))
108     ,@body))
109
110
111
112(defvar *compiler-debug* nil)
113
114(defvar *pool* nil)
115(defvar *static-code* ())
116(defvar *class-file* nil)
117
118(defvar *externalized-objects* nil)
119(defvar *declared-functions* nil)
120
121(defstruct (abcl-class-file (:include class-file)
122                            (:constructor %make-abcl-class-file))
123  pathname ; pathname of output file
124  class-name
125  lambda-name
126  lambda-list ; as advertised
127  static-initializer
128  constructor
129  objects ;; an alist of externalized objects and their field names
130  (functions (make-hash-table :test 'equal)) ;; because of (SETF ...) functions
131  )
132
133(defun class-name-from-filespec (filespec)
134  (let* ((name (pathname-name filespec)))
135    (declare (type string name))
136    (dotimes (i (length name))
137      (declare (type fixnum i))
138      (when (or (char= (char name i) #\-)
139                (char= (char name i) #\Space))
140        (setf (char name i) #\_)))
141    (make-class-name
142     (concatenate 'string "org.armedbear.lisp." name))))
143
144(defun make-unique-class-name ()
145  "Creates a random class name for use with a `class-file' structure's
146`class' slot."
147  (make-class-name
148   (concatenate 'string "abcl_"
149                (substitute #\_ #\-
150                            (java:jcall (java:jmethod "java.util.UUID"
151                                                      "toString")
152                                        (java:jstatic "randomUUID"
153                                                      "java.util.UUID"))))))
154
155(defun make-abcl-class-file (&key pathname lambda-name lambda-list)
156  "Creates a `class-file' structure. If `pathname' is non-NIL, it's
157used to derive a class name. If it is NIL, a random one created
158using `make-unique-class-name'."
159  (let* ((class-name (if pathname
160                         (class-name-from-filespec  pathname)
161                         (make-unique-class-name)))
162         (class-file (%make-abcl-class-file :pathname pathname
163                                            :class class-name ; to be finalized
164                                            :class-name class-name
165                                            :lambda-name lambda-name
166                                            :lambda-list lambda-list
167                                            :access-flags '(:public :final))))
168    (when *file-compilation*
169      (let ((source-attribute
170             (make-source-file-attribute
171              :filename (file-namestring *compile-file-truename*))))
172        (class-add-attribute class-file source-attribute)))
173    class-file))
174
175(defmacro with-class-file (class-file &body body)
176  (let ((var (gensym)))
177    `(let* ((,var                   ,class-file)
178            (*class-file*           ,var)
179            (*pool*                 (abcl-class-file-constants ,var))
180            (*externalized-objects* (abcl-class-file-objects ,var))
181            (*declared-functions*   (abcl-class-file-functions ,var)))
182       (progn ,@body)
183       (setf (abcl-class-file-objects ,var)      *externalized-objects*
184             (abcl-class-file-functions ,var)    *declared-functions*))))
185
186(defstruct compiland
187  name
188  lambda-expression
189  arg-vars          ; variables for lambda arguments
190  free-specials     ;
191  arity             ; number of args, or NIL if the number of args can vary.
192  p1-result         ; the parse tree as created in pass 1
193  parent            ; the parent for compilands which defined within another
194  (children 0       ; Number of local functions
195            :type fixnum) ; defined with FLET, LABELS or LAMBDA
196  blocks            ; TAGBODY, PROGV, BLOCK, etc. blocks
197  argument-register
198  closure-register
199  environment-register
200  class-file ; class-file object
201  (%single-valued-p t))
202
203(defknown compiland-single-valued-p (t) t)
204(defun compiland-single-valued-p (compiland)
205  (unless (compiland-parent compiland)
206    (let ((name (compiland-name compiland)))
207      (when name
208        (let ((result-type
209               (or (function-result-type name)
210                   (and (proclaimed-ftype name)
211                        (ftype-result-type (proclaimed-ftype name))))))
212          (when result-type
213            (return-from compiland-single-valued-p
214                         (cond ((eq result-type '*)
215                                nil)
216                               ((atom result-type)
217                                t)
218                               ((eq (%car result-type) 'VALUES)
219                                (= (length result-type) 2))
220                               (t
221                                t))))))))
222  ;; Otherwise...
223  (compiland-%single-valued-p compiland))
224
225(defvar *current-compiland* nil)
226
227(defvar *this-class* nil)
228
229;; All tags visible at the current point of compilation, some of which may not
230;; be in the current compiland.
231(defvar *visible-tags* ())
232
233;; The next available register.
234(defvar *register* 0)
235
236;; Total number of registers allocated.
237(defvar *registers-allocated* 0)
238
239;; Variables visible at the current point of compilation.
240(defvar *visible-variables* nil
241  "All variables visible to the form currently being
242processed, including free specials.")
243
244;; All variables seen so far.
245(defvar *all-variables* nil
246  "All variables in the lexical scope (thus excluding free specials)
247of the compilands being processed (p1: so far; p2: in total).")
248
249;; Undefined variables that we've already warned about.
250(defvar *undefined-variables* nil)
251
252(defvar *dump-variables* nil)
253
254(defun dump-1-variable (variable)
255  (sys::%format t "  ~S special-p = ~S register = ~S binding-reg = ~S index = ~S declared-type = ~S~%"
256           (variable-name variable)
257           (variable-special-p variable)
258           (variable-register variable)
259           (variable-binding-register variable)
260           (variable-index variable)
261           (variable-declared-type variable)))
262
263(defun dump-variables (list caption &optional (force nil))
264  (when (or force *dump-variables*)
265    (write-string caption)
266    (if list
267        (dolist (variable list)
268          (dump-1-variable variable))
269        (sys::%format t "  None.~%"))))
270
271(defstruct (variable-info (:conc-name variable-)
272                          (:constructor make-variable)
273                          (:predicate variable-p))
274  name
275  initform
276  (declared-type :none)
277  (derived-type :none)
278  ignore-p
279  ignorable-p
280  representation
281  special-p     ; indicates whether a variable is special
282  register      ; register number for a local variable
283  binding-register ; register number containing the binding reference
284  index         ; index number for a variable in the argument array
285  closure-index ; index number for a variable in the closure context array
286  environment   ; the environment for the variable, if we're compiling in
287                ; a non-null lexical environment with variables
288    ;; a variable can be either special-p *or* have a register *or*
289    ;; have an index *or* a closure-index *or* an environment
290  (reads 0 :type fixnum)
291  (writes 0 :type fixnum)
292  references
293  (references-allowed-p t) ; NIL if this is a symbol macro in the enclosing
294                           ; lexical environment
295  used-non-locally-p
296  (compiland *current-compiland*)
297  block)
298
299(defstruct (var-ref (:constructor make-var-ref (variable)))
300  ;; The variable this reference refers to. Will be NIL if the VAR-REF has been
301  ;; rewritten to reference a constant value.
302  variable
303  ;; True if the VAR-REF has been rewritten to reference a constant value.
304  constant-p
305  ;; The constant value of this VAR-REF.
306  constant-value)
307
308;; obj can be a symbol or variable
309;; returns variable or nil
310(declaim (ftype (function (t) t) unboxed-fixnum-variable))
311(defun unboxed-fixnum-variable (obj)
312  (cond ((symbolp obj)
313         (let ((variable (find-visible-variable obj)))
314           (if (and variable
315                    (eq (variable-representation variable) :int))
316               variable
317               nil)))
318        ((variable-p obj)
319         (if (eq (variable-representation obj) :int)
320             obj
321             nil))
322        (t
323         nil)))
324
325(defvar *child-p* nil
326  "True for local functions created by FLET, LABELS and (NAMED-)LAMBDA")
327
328(defknown find-variable (symbol list) t)
329(defun find-variable (name variables)
330  (dolist (variable variables)
331    (when (eq name (variable-name variable))
332      (return variable))))
333
334(defknown find-visible-variable (t) t)
335(defun find-visible-variable (name)
336  (dolist (variable *visible-variables*)
337    (when (eq name (variable-name variable))
338      (return variable))))
339
340(defknown allocate-register () (integer 0 65535))
341(defun allocate-register ()
342  (let* ((register *register*)
343         (next-register (1+ register)))
344    (declare (type (unsigned-byte 16) register next-register))
345    (setf *register* next-register)
346    (when (< *registers-allocated* next-register)
347      (setf *registers-allocated* next-register))
348    register))
349
350(defknown allocate-register-pair () (integer 0 65535))
351(defun allocate-register-pair ()
352  (let* ((register *register*)
353         (next-register (+ register 2)))
354    (declare (type (unsigned-byte 16) register next-register))
355    (setf *register* next-register)
356    (when (< *registers-allocated* next-register)
357      (setf *registers-allocated* next-register))
358    register))
359
360(defstruct local-function
361  name
362  definition
363  compiland
364  inline-expansion
365  function    ;; the function loaded through load-compiled-function
366  class-file  ;; the class file structure for this function
367  variable    ;; the variable which contains the loaded compiled function
368              ;; or compiled closure
369  environment ;; the environment in which the function is stored in
370              ;; case of a function from an enclosing lexical environment
371              ;; which itself isn't being compiled
372  (references-allowed-p t) ;;whether a reference to the function CAN be captured
373  (references-needed-p nil) ;;whether a reference to the function NEEDS to be
374          ;;captured, because the function name is used in a
375                            ;;(function ...) form. Obviously implies
376                            ;;references-allowed-p.
377  )
378
379(defvar *local-functions* ())
380
381(defknown find-local-function (t) t)
382(defun find-local-function (name)
383  (dolist (local-function *local-functions* nil)
384    (when (equal name (local-function-name local-function))
385        (return local-function))))
386
387(defvar *using-arg-array* nil)
388(defvar *hairy-arglist-p* nil)
389
390(defstruct node
391  form
392  (compiland *current-compiland*))
393;; No need for a special constructor: nobody instantiates
394;; nodes directly
395
396;; control-transferring blocks: TAGBODY, CATCH, to do: BLOCK
397
398(defstruct (control-transferring-node (:include node))
399  ;; If non-nil, the TAGBODY contains local blocks which "contaminate" the
400  ;; environment, with GO forms in them which target tags in this TAGBODY
401  ;; Non-nil if and only if the block doesn't modify the environment
402  needs-environment-restoration
403  )
404;; No need for a special constructor: nobody instantiates
405;; control-transferring-nodes directly
406
407(defstruct (tagbody-node (:conc-name tagbody-)
408                         (:include control-transferring-node)
409       (:constructor %make-tagbody-node ()))
410  ;; True if a tag in this tagbody is the target of a non-local GO.
411  non-local-go-p
412  ;; Tags in the tagbody form; a list of tag structures
413  tags
414  ;; Contains a variable whose value uniquely identifies the
415  ;; lexical scope from this block, to be used by GO
416  id-variable)
417(defknown make-tagbody-node () t)
418(defun make-tagbody-node ()
419  (let ((block (%make-tagbody-node)))
420    (push block (compiland-blocks *current-compiland*))
421    block))
422
423(defstruct (catch-node (:conc-name catch-)
424                       (:include control-transferring-node)
425           (:constructor %make-catch-node ()))
426  ;; The catch tag-form is evaluated, meaning we
427  ;; have no predefined value to store here
428  )
429(defknown make-catch-node () t)
430(defun make-catch-node ()
431  (let ((block (%make-catch-node)))
432    (push block (compiland-blocks *current-compiland*))
433    block))
434
435(defstruct (block-node (:conc-name block-)
436                       (:include control-transferring-node)
437                       (:constructor %make-block-node (name)))
438  name  ;; Block name
439  (exit (gensym))
440  target
441  ;; True if there is a non-local RETURN from this block.
442  non-local-return-p
443  ;; Contains a variable whose value uniquely identifies the
444  ;; lexical scope from this block, to be used by RETURN-FROM
445  id-variable)
446(defknown make-block-node (t) t)
447(defun make-block-node (name)
448  (let ((block (%make-block-node name)))
449    (push block (compiland-blocks *current-compiland*))
450    block))
451
452;; binding blocks: LET, LET*, FLET, LABELS, M-V-B, PROGV, LOCALLY
453;;
454;; Binding blocks can carry references to local (optionally special) variable bindings,
455;;  contain free special bindings or both
456
457(defstruct (binding-node (:include node))
458  ;; number of the register of the saved dynamic env, or NIL if none
459  environment-register
460  ;; Not used for LOCALLY and FLET; LABELS uses vars to store its functions
461  vars
462  free-specials)
463;; nobody instantiates any binding nodes directly, so there's no reason
464;; to create a constructor with the approprate administration code
465
466(defstruct (let/let*-node (:conc-name let-)
467                          (:include binding-node)
468        (:constructor %make-let/let*-node ())))
469(defknown make-let/let*-node () t)
470(defun make-let/let*-node ()
471  (let ((block (%make-let/let*-node)))
472    (push block (compiland-blocks *current-compiland*))
473    block))
474
475(defstruct (flet-node (:conc-name flet-)
476                      (:include binding-node)
477          (:constructor %make-flet-node ())))
478(defknown make-flet-node () t)
479(defun make-flet-node ()
480  (let ((block (%make-flet-node)))
481    (push block (compiland-blocks *current-compiland*))
482    block))
483
484(defstruct (labels-node (:conc-name labels-)
485                        (:include binding-node)
486      (:constructor %make-labels-node ())))
487(defknown make-labels-node () t)
488(defun make-labels-node ()
489  (let ((block (%make-labels-node)))
490    (push block (compiland-blocks *current-compiland*))
491    block))
492
493(defstruct (m-v-b-node (:conc-name m-v-b-)
494                       (:include binding-node)
495           (:constructor %make-m-v-b-node ())))
496(defknown make-m-v-b-node () t)
497(defun make-m-v-b-node ()
498  (let ((block (%make-m-v-b-node)))
499    (push block (compiland-blocks *current-compiland*))
500    block))
501
502(defstruct (progv-node (:conc-name progv-)
503                       (:include binding-node)
504           (:constructor %make-progv-node ())))
505(defknown make-progv-node () t)
506(defun make-progv-node ()
507  (let ((block (%make-progv-node)))
508    (push block (compiland-blocks *current-compiland*))
509    block))
510
511(defstruct (locally-node (:conc-name locally-)
512                         (:include binding-node)
513       (:constructor %make-locally-node ())))
514(defknown make-locally-node () t)
515(defun make-locally-node ()
516  (let ((block (%make-locally-node)))
517    (push block (compiland-blocks *current-compiland*))
518    block))
519
520;; blocks requiring non-local exits: UNWIND-PROTECT, SYS:SYNCHRONIZED-ON
521
522(defstruct (protected-node (:include node)
523         (:constructor %make-protected-node ())))
524(defknown make-protected-node () t)
525(defun make-protected-node ()
526  (let ((block (%make-protected-node)))
527    (push block (compiland-blocks *current-compiland*))
528    block))
529
530(defstruct (unwind-protect-node (:conc-name unwind-protect-)
531                                (:include protected-node)
532        (:constructor %make-unwind-protect-node ())))
533(defknown make-unwind-protect-node () t)
534(defun make-unwind-protect-node ()
535  (let ((block (%make-unwind-protect-node)))
536    (push block (compiland-blocks *current-compiland*))
537    block))
538
539(defstruct (synchronized-node (:conc-name synchronized-)
540                              (:include protected-node)
541            (:constructor %make-synchronized-node ())))
542(defknown make-synchronized-node () t)
543(defun make-synchronized-node ()
544  (let ((block (%make-synchronized-node)))
545    (push block (compiland-blocks *current-compiland*))
546    block))
547
548
549(defvar *blocks* ())
550
551(defun find-block (name)
552  (dolist (block *blocks*)
553    (when (and (block-node-p block)
554               (eq name (block-name block)))
555      (return block))))
556
557(defknown node-constant-p (t) boolean)
558(defun node-constant-p (object)
559  (cond ((node-p object)
560         nil)
561        ((var-ref-p object)
562         nil)
563        ((constantp object)
564         t)
565        (t
566         nil)))
567
568(defknown block-requires-non-local-exit-p (t) boolean)
569(defun block-requires-non-local-exit-p (object)
570  "A block which *always* requires a 'non-local-exit' is a block which
571requires a transfer control exception to be thrown: e.g. Go and Return.
572
573Non-local exits are required by blocks which do more in their cleanup
574than just restore the lastSpecialBinding (= dynamic environment).
575"
576  (or (unwind-protect-node-p object)
577      (catch-node-p object)
578      (synchronized-node-p object)))
579
580(defknown block-creates-runtime-bindings-p (t) boolean)
581(defun block-creates-runtime-bindings-p (block)
582  ;; FIXME: This may be false, if the bindings to be
583  ;; created are a quoted list
584  (progv-node-p block))
585
586(defknown enclosed-by-runtime-bindings-creating-block-p (t) boolean)
587(defun enclosed-by-runtime-bindings-creating-block-p (outermost-block)
588  "Indicates whether the code being compiled/analyzed is enclosed in a
589block which creates special bindings at runtime."
590  (dolist (enclosing-block *blocks*)
591    (when (eq enclosing-block outermost-block)
592      (return-from enclosed-by-runtime-bindings-creating-block-p nil))
593    (when (block-creates-runtime-bindings-p enclosing-block)
594      (return-from enclosed-by-runtime-bindings-creating-block-p t))))
595
596(defknown enclosed-by-protected-block-p (&optional t) boolean)
597(defun enclosed-by-protected-block-p (&optional outermost-block)
598  "Indicates whether the code being compiled/analyzed is enclosed in
599a block which requires a non-local transfer of control exception to
600be generated.
601"
602  (dolist (enclosing-block *blocks*)
603    (when (eq enclosing-block outermost-block)
604      (return-from enclosed-by-protected-block-p nil))
605    (when (block-requires-non-local-exit-p enclosing-block)
606      (return-from enclosed-by-protected-block-p t))))
607
608(defknown enclosed-by-environment-setting-block-p (&optional t) boolean)
609(defun enclosed-by-environment-setting-block-p (&optional outermost-block)
610  (dolist (enclosing-block *blocks*)
611    (when (eq enclosing-block outermost-block)
612      (return nil))
613    (when (and (binding-node-p enclosing-block)
614               (binding-node-environment-register enclosing-block))
615      (return t))))
616
617(defknown environment-register-to-restore (&optional t) t)
618(defun environment-register-to-restore (&optional outermost-block)
619  "Returns the environment register which contains the
620saved environment from the outermost enclosing block:
621
622That's the one which contains the environment used in the outermost block."
623  (flet ((outermost-register (last-register block)
624           (when (eq block outermost-block)
625             (return-from environment-register-to-restore last-register))
626           (or (and (binding-node-p block)
627                    (binding-node-environment-register block))
628               last-register)))
629    (reduce #'outermost-register *blocks*
630            :initial-value nil)))
631
632(defstruct tag
633  ;; The symbol (or integer) naming the tag
634  name
635  ;; The symbol which is the jump target in JVM byte code
636  label
637  ;; The associated TAGBODY
638  block
639  (compiland *current-compiland*)
640  used
641  used-non-locally)
642
643(defknown find-tag (t) t)
644(defun find-tag (name)
645  (dolist (tag *visible-tags*)
646    (when (eql name (tag-name tag))
647      (return tag))))
648
649(defun process-ignore/ignorable (declaration names variables)
650  (when (memq declaration '(IGNORE IGNORABLE))
651    (let ((what (if (eq declaration 'IGNORE) "ignored" "ignorable")))
652      (dolist (name names)
653        (unless (and (consp name) (eq (car name) 'FUNCTION))
654          (let ((variable (find-variable name variables)))
655            (cond ((null variable)
656                   (compiler-style-warn "Declaring unknown variable ~S to be ~A."
657                                        name what))
658                  ((variable-special-p variable)
659                   (compiler-style-warn "Declaring special variable ~S to be ~A."
660                                        name what))
661                  ((eq declaration 'IGNORE)
662                   (setf (variable-ignore-p variable) t))
663                  (t
664                   (setf (variable-ignorable-p variable) t)))))))))
665
666(defun finalize-generic-functions ()
667  (dolist (sym '(make-instance
668                 initialize-instance
669                 shared-initialize))
670    (let ((gf (and (fboundp sym) (fdefinition sym))))
671      (when (typep gf 'generic-function)
672        (unless (compiled-function-p gf)
673          (mop::finalize-generic-function gf))))))
674
675(finalize-generic-functions)
676
677(provide 'jvm)
Note: See TracBrowser for help on using the repository browser.