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

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

generic-class-file branch merged.

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