source: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp @ 12896

Last change on this file since 12896 was 12896, checked in by ehuelsmann, 13 years ago

Add source file and line number attributes according to the
new generator structure.

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