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

Last change on this file since 11899 was 11899, checked in by ehuelsmann, 12 years ago

Add structure slot and variable documentation.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 17.4 KB
Line 
1;;; jvm.lisp
2;;;
3;;; Copyright (C) 2003-2008 Peter Graves
4;;; $Id: jvm.lisp 11899 2009-05-19 19:50:30Z ehuelsmann $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
19;;;
20;;; As a special exception, the copyright holders of this library give you
21;;; permission to link this library with independent modules to produce an
22;;; executable, regardless of the license terms of these independent
23;;; modules, and to copy and distribute the resulting executable under
24;;; terms of your choice, provided that you also meet, for each linked
25;;; independent module, the terms and conditions of the license of that
26;;; module.  An independent module is a module which is not derived from
27;;; or based on this library.  If you modify this library, you may extend
28;;; this exception to your version of the library, but you are not
29;;; obligated to do so.  If you do not wish to do so, delete this
30;;; exception statement from your version.
31
32(in-package "JVM")
33
34(export '(compile-defun *catch-errors* jvm-compile jvm-compile-package
35          derive-compiler-type))
36
37(eval-when (:compile-toplevel :load-toplevel :execute)
38  (require "LOOP")
39  (require "FORMAT")
40  (require "CLOS")
41  (require "PRINT-OBJECT")
42  (require "COMPILER-TYPES")
43  (require "KNOWN-FUNCTIONS")
44  (require "KNOWN-SYMBOLS")
45  (require "DUMP-FORM")
46  (require "OPCODES")
47  (require "JAVA")
48  (require "COMPILER-PASS1")
49  (require "COMPILER-PASS2"))
50
51(defvar *closure-variables* nil)
52
53(defvar *enable-dformat* nil)
54
55#+nil
56(defun dformat (destination control-string &rest args)
57  (when *enable-dformat*
58    (apply #'sys::%format destination control-string args)))
59
60(defmacro dformat (&rest ignored)
61  (declare (ignore ignored)))
62
63
64(defmacro with-saved-compiler-policy (&body body)
65  "Saves compiler policy variables, restoring them after evaluating `body'."
66  `(let ((*speed* *speed*)
67         (*space* *space*)
68         (*safety* *safety*)
69         (*debug* *debug*)
70         (*explain* *explain*)
71         (*inline-declarations* *inline-declarations*))
72     ,@body))
73
74
75
76(defvar *compiler-debug* nil)
77
78(defvar *pool* nil)
79(defvar *pool-count* 1)
80(defvar *pool-entries* nil)
81(defvar *fields* ())
82(defvar *static-code* ())
83
84(defvar *declared-symbols* nil)
85(defvar *declared-functions* nil)
86(defvar *declared-strings* nil)
87(defvar *declared-integers* nil)
88(defvar *declared-floats* nil)
89(defvar *declared-doubles* nil)
90
91(defstruct (class-file (:constructor %make-class-file))
92  pathname ; pathname of output file
93  lambda-name
94  class
95  superclass
96  lambda-list ; as advertised
97  pool
98  (pool-count 1)
99  (pool-entries (make-hash-table :test #'equal))
100  fields
101  methods
102  static-code
103  (symbols (make-hash-table :test 'eq))
104  (functions (make-hash-table :test 'equal))
105  (strings (make-hash-table :test 'eq))
106  (integers (make-hash-table :test 'eql))
107  (floats (make-hash-table :test 'eql))
108  (doubles (make-hash-table :test 'eql)))
109
110(defun class-name-from-filespec (filespec)
111  (let* ((name (pathname-name filespec)))
112    (declare (type string name))
113    (dotimes (i (length name))
114      (declare (type fixnum i))
115      (when (char= (char name i) #\-)
116        (setf (char name i) #\_)))
117    (concatenate 'string "org/armedbear/lisp/" name)))
118
119(defun make-class-file (&key pathname lambda-name lambda-list)
120  (aver (not (null pathname)))
121  (let ((class-file (%make-class-file :pathname pathname
122                                      :lambda-name lambda-name
123                                      :lambda-list lambda-list)))
124    (setf (class-file-class class-file) (class-name-from-filespec pathname))
125    class-file))
126
127(defmacro with-class-file (class-file &body body)
128  (let ((var (gensym)))
129    `(let* ((,var ,class-file)
130            (*pool*               (class-file-pool ,var))
131            (*pool-count*         (class-file-pool-count ,var))
132            (*pool-entries*       (class-file-pool-entries ,var))
133            (*fields*             (class-file-fields ,var))
134            (*static-code*        (class-file-static-code ,var))
135            (*declared-symbols*   (class-file-symbols ,var))
136            (*declared-functions* (class-file-functions ,var))
137            (*declared-strings*   (class-file-strings ,var))
138            (*declared-integers*  (class-file-integers ,var))
139            (*declared-floats*    (class-file-floats ,var))
140            (*declared-doubles*   (class-file-doubles ,var)))
141       (progn ,@body)
142       (setf (class-file-pool ,var)         *pool*
143             (class-file-pool-count ,var)   *pool-count*
144             (class-file-pool-entries ,var) *pool-entries*
145             (class-file-fields ,var)       *fields*
146             (class-file-static-code ,var)  *static-code*
147             (class-file-symbols ,var)      *declared-symbols*
148             (class-file-functions ,var)    *declared-functions*
149             (class-file-strings ,var)      *declared-strings*
150             (class-file-integers ,var)     *declared-integers*
151             (class-file-floats ,var)       *declared-floats*
152             (class-file-doubles ,var)      *declared-doubles*))))
153
154(defstruct compiland
155  name
156  lambda-expression
157  arg-vars          ; variables for lambda arguments
158  free-specials     ;
159  arity             ; number of args, or NIL if the number of args can vary.
160  p1-result         ; the parse tree as created in pass 1
161  parent            ; the parent for compilands which defined within another
162  (children 0       ; Number of local functions
163            :type fixnum) ; defined with with FLET, LABELS or LAMBDA
164  argument-register
165  closure-register
166  environment-register
167  class-file ; class-file object
168  (%single-valued-p t))
169
170(defknown compiland-single-valued-p (t) t)
171(defun compiland-single-valued-p (compiland)
172  (unless (compiland-parent compiland)
173    (let ((name (compiland-name compiland)))
174      (when name
175        (let ((result-type
176               (or (function-result-type name)
177                   (and (proclaimed-ftype name)
178                        (ftype-result-type (proclaimed-ftype name))))))
179          (when result-type
180            (return-from compiland-single-valued-p
181                         (cond ((eq result-type '*)
182                                nil)
183                               ((atom result-type)
184                                t)
185                               ((eq (%car result-type) 'VALUES)
186                                (= (length result-type) 2))
187                               (t
188                                t))))))))
189  ;; Otherwise...
190  (compiland-%single-valued-p compiland))
191
192(defvar *current-compiland* nil)
193
194(defvar *this-class* nil)
195
196(defvar *code* ())
197
198;; All tags visible at the current point of compilation, some of which may not
199;; be in the current compiland.
200(defvar *visible-tags* ())
201
202;; The next available register.
203(defvar *register* 0)
204
205;; Total number of registers allocated.
206(defvar *registers-allocated* 0)
207
208(defvar *handlers* ())
209
210(defstruct handler
211  from       ;; label indicating the start of the protected block
212  to         ;; label indicating the end of the protected block
213  code       ;; label to jump to if the specified exception occurs
214  catch-type ;; pool index of the class name of the exception, or 0 (zero)
215             ;; for 'all'
216  )
217
218;; Variables visible at the current point of compilation.
219(defvar *visible-variables* nil
220  "All variables visible to the form currently being
221processed, including free specials.")
222
223;; All variables seen so far.
224(defvar *all-variables* nil
225  "All variables in the lexical scope (thus excluding free specials)
226of the compilands being processed (p1: so far; p2: in total).")
227
228;; Undefined variables that we've already warned about.
229(defvar *undefined-variables* nil)
230
231(defvar *dump-variables* nil)
232
233(defun dump-1-variable (variable)
234  (sys::%format t "  ~S special-p = ~S register = ~S index = ~S declared-type = ~S~%"
235           (variable-name variable)
236           (variable-special-p variable)
237           (variable-register variable)
238           (variable-index variable)
239           (variable-declared-type variable)))
240
241(defun dump-variables (list caption &optional (force nil))
242  (when (or force *dump-variables*)
243    (write-string caption)
244    (if list
245        (dolist (variable list)
246          (dump-1-variable variable))
247        (sys::%format t "  None.~%"))))
248
249(defstruct (variable-info (:conc-name variable-)
250                          (:constructor make-variable)
251                          (:predicate variable-p))
252  name
253  initform
254  (declared-type :none)
255  (derived-type :none)
256  ignore-p
257  ignorable-p
258  representation
259  special-p     ; indicates whether a variable is special
260  register      ; register number for a local variable
261  index         ; index number for a variable in the argument array
262  closure-index ; index number for a variable in the closure context array
263    ;; a variable can be either special-p *or* have a register *or*
264    ;; have an index *or a closure-index
265  (reads 0 :type fixnum)
266  (writes 0 :type fixnum)
267  references
268  used-non-locally-p
269  (compiland *current-compiland*))
270
271(defstruct (var-ref (:constructor make-var-ref (variable)))
272  ;; The variable this reference refers to. Will be NIL if the VAR-REF has been
273  ;; rewritten to reference a constant value.
274  variable
275  ;; True if the VAR-REF has been rewritten to reference a constant value.
276  constant-p
277  ;; The constant value of this VAR-REF.
278  constant-value)
279
280;; obj can be a symbol or variable
281;; returns variable or nil
282(declaim (ftype (function (t) t) unboxed-fixnum-variable))
283(defun unboxed-fixnum-variable (obj)
284  (cond ((symbolp obj)
285         (let ((variable (find-visible-variable obj)))
286           (if (and variable
287                    (eq (variable-representation variable) :int))
288               variable
289               nil)))
290        ((variable-p obj)
291         (if (eq (variable-representation obj) :int)
292             obj
293             nil))
294        (t
295         nil)))
296
297(defvar *child-p* nil
298  "True for local functions created by FLET, LABELS and (NAMED-)LAMBDA")
299
300(defknown find-variable (symbol list) t)
301(defun find-variable (name variables)
302  (dolist (variable variables)
303    (when (eq name (variable-name variable))
304      (return variable))))
305
306(defknown find-visible-variable (t) t)
307(defun find-visible-variable (name)
308  (dolist (variable *visible-variables*)
309    (when (eq name (variable-name variable))
310      (return variable))))
311
312(defknown allocate-register () (integer 0 65535))
313(defun allocate-register ()
314  (let* ((register *register*)
315         (next-register (1+ register)))
316    (declare (type (unsigned-byte 16) register next-register))
317    (setf *register* next-register)
318    (when (< *registers-allocated* next-register)
319      (setf *registers-allocated* next-register))
320    register))
321
322(defknown allocate-register-pair () (integer 0 65535))
323(defun allocate-register-pair ()
324  (let* ((register *register*)
325         (next-register (+ register 2)))
326    (declare (type (unsigned-byte 16) register next-register))
327    (setf *register* next-register)
328    (when (< *registers-allocated* next-register)
329      (setf *registers-allocated* next-register))
330    register))
331
332(defstruct local-function
333  name
334  compiland
335  inline-expansion
336  function  ;; the function loaded through load-compiled-function
337  class-file
338  variable  ;; the variable which contains the loaded compiled function
339            ;; or compiled closure
340  )
341
342(defvar *local-functions* ())
343
344(defknown find-local-function (t) t)
345(defun find-local-function (name)
346  (dolist (local-function *local-functions* nil)
347    (when (equal name (local-function-name local-function))
348        (return local-function))))
349
350(defvar *using-arg-array* nil)
351(defvar *hairy-arglist-p* nil)
352
353(defstruct node
354  ;; Block name or (TAGBODY) or (LET) or (MULTIPLE-VALUE-BIND).
355  name
356  form
357  (compiland *current-compiland*))
358
359;; Used to wrap TAGBODYs, UNWIND-PROTECTs and LET/LET*/M-V-B forms as well as
360;; BLOCKs per se.
361(defstruct (block-node (:conc-name block-)
362                       (:include node)
363                       (:constructor make-block-node (name)))
364  (exit (gensym))
365  target
366  catch-tag
367  ;; True if there is any RETURN from this block.
368  return-p
369  ;; True if there is a non-local RETURN from this block.
370  non-local-return-p
371  ;; True if a tag in this tagbody is the target of a non-local GO.
372  non-local-go-p
373  ;; If non-nil, the TAGBODY contains local blocks which "contaminate" the
374  ;; environment, with GO forms in them which target tags in this TAGBODY
375  ;; Non-nil if and only if the block doesn't modify the environment
376  needs-environment-restoration
377  ;; If non-nil, register containing saved dynamic environment for this block.
378  environment-register
379  ;; Only used in LET/LET*/M-V-B nodes.
380  vars
381  free-specials
382  ;; Only used in TAGBODY
383  tags
384  )
385
386(defvar *blocks* ())
387
388(defun find-block (name)
389  (dolist (block *blocks*)
390    (when (eq name (block-name block))
391      (return block))))
392
393(defknown node-constant-p (t) boolean)
394(defun node-constant-p (object)
395  (cond ((block-node-p object)
396         nil)
397        ((var-ref-p object)
398         nil)
399        ((constantp object)
400         t)
401        (t
402         nil)))
403
404(defknown block-requires-non-local-exit-p (t) boolean)
405(defun block-requires-non-local-exit-p (object)
406  "A block which *always* requires a 'non-local-exit' is a block which
407requires a transfer control exception to be thrown: e.g. Go and Return.
408
409Non-local exits are required by blocks which do more in their cleanup
410than just restore the lastSpecialBinding (= dynamic environment).
411"
412  (let ((name (block-name object)))
413    (or (equal name '(CATCH))
414        (equal name '(UNWIND-PROTECT)))))
415
416
417(defknown enclosed-by-protected-block-p (&optional t) boolean)
418(defun enclosed-by-protected-block-p (&optional outermost-block)
419  "Indicates whether the code being compiled/analyzed is enclosed in
420a block which requires a non-local transfer of control exception to
421be generated.
422"
423  (dolist (enclosing-block *blocks*)
424    (when (eq enclosing-block outermost-block)
425      (return-from enclosed-by-protected-block-p nil))
426    (when (block-requires-non-local-exit-p enclosing-block)
427      (return-from enclosed-by-protected-block-p t))))
428
429(defknown enclosed-by-environment-setting-block-p (&optional t) boolean)
430(defun enclosed-by-environment-setting-block-p (&optional outermost-block)
431  (dolist (enclosing-block *blocks*)
432    (when (eq enclosing-block outermost-block)
433      (return nil))
434    (when (and (block-environment-register enclosing-block)
435               (not (block-needs-environment-restoration enclosing-block)))
436      (return t))))
437
438(defknown environment-register-to-restore (&optional t) t)
439(defun environment-register-to-restore (&optional outermost-block)
440  "Returns the environment register which contains the
441saved environment from the outermost enclosing block:
442
443That's the one which contains the environment used in the outermost block."
444  (flet ((outermost-register (last-register block)
445           (when (eq block outermost-block)
446             (return-from environment-register-to-restore last-register))
447           (or (block-environment-register block)
448               last-register)))
449    (reduce #'outermost-register *blocks*
450            :initial-value nil)))
451
452(defstruct tag
453  ;; The symbol (or integer) naming the tag
454  name
455  ;; The symbol which is the jump target in JVM byte code
456  label
457  ;; The associated TAGBODY
458  block
459  (compiland *current-compiland*)
460  used)
461
462(defknown find-tag (t) t)
463(defun find-tag (name)
464  (dolist (tag *visible-tags*)
465    (when (eql name (tag-name tag))
466      (return tag))))
467
468(defun process-ignore/ignorable (declaration names variables)
469  (when (memq declaration '(IGNORE IGNORABLE))
470    (let ((what (if (eq declaration 'IGNORE) "ignored" "ignorable")))
471      (dolist (name names)
472        (let ((variable (find-variable name variables)))
473          (cond ((null variable)
474                 (compiler-style-warn "Declaring unknown variable ~S to be ~A."
475                                      name what))
476                ((variable-special-p variable)
477                 (compiler-style-warn "Declaring special variable ~S to be ~A."
478                                      name what))
479                ((eq declaration 'IGNORE)
480                 (setf (variable-ignore-p variable) t))
481                (t
482                 (setf (variable-ignorable-p variable) t))))))))
483
484(defvar *file-compilation* nil)
485(defvar *pathnames-generator* #'make-temp-file)
486
487(defun compile (name &optional definition)
488  (let ((*file-compilation* nil)
489        (*pathnames-generator* #'make-temp-file)
490        (sys::*fasl-anonymous-package* (sys::%make-package)))
491    (jvm-compile name definition)))
492
493(defmacro with-file-compilation (&body body)
494  `(let ((*file-compilation* t)
495         (*pathnames-generator* #'sys::next-classfile-name))
496     ,@body))
497
498(defun finalize-generic-functions ()
499  (dolist (sym '(make-instance
500                 initialize-instance
501                 shared-initialize))
502    (let ((gf (and (fboundp sym) (fdefinition sym))))
503      (when (typep gf 'generic-function)
504        (unless (compiled-function-p gf)
505          (mop::finalize-generic-function gf))))))
506
507(finalize-generic-functions)
508
509(provide 'jvm)
Note: See TracBrowser for help on using the repository browser.