source: trunk/j/src/org/armedbear/lisp/jvm.lisp @ 11456

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

Remove superfluous IN-PACKAGE.
Move documentation from comment to document-position in DEFVAR and extend it.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 12.9 KB
Line 
1;;; jvm.lisp
2;;;
3;;; Copyright (C) 2003-2008 Peter Graves
4;;; $Id: jvm.lisp 11456 2008-12-20 14:09:27Z 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
89(defstruct (class-file (:constructor %make-class-file))
90  pathname ; pathname of output file
91  lambda-name
92  class
93  superclass
94  lambda-list ; as advertised
95  pool
96  (pool-count 1)
97  (pool-entries (make-hash-table :test #'equal))
98  fields
99  methods
100  static-code
101  (symbols (make-hash-table :test 'eq))
102  (functions (make-hash-table :test 'equal))
103  (strings (make-hash-table :test 'eq))
104  (integers (make-hash-table :test 'eql)))
105
106(defun class-name-from-filespec (filespec)
107  (let* ((name (pathname-name filespec)))
108    (declare (type string name))
109    (dotimes (i (length name))
110      (declare (type fixnum i))
111      (when (char= (char name i) #\-)
112        (setf (char name i) #\_)))
113    (concatenate 'string "org/armedbear/lisp/" name)))
114
115(defun make-class-file (&key pathname lambda-name lambda-list)
116  (aver (not (null pathname)))
117  (let ((class-file (%make-class-file :pathname pathname
118                                      :lambda-name lambda-name
119                                      :lambda-list lambda-list)))
120    (setf (class-file-class class-file) (class-name-from-filespec pathname))
121    class-file))
122
123(defmacro with-class-file (class-file &body body)
124  (let ((var (gensym)))
125    `(let* ((,var ,class-file)
126            (*pool*               (class-file-pool ,var))
127            (*pool-count*         (class-file-pool-count ,var))
128            (*pool-entries*       (class-file-pool-entries ,var))
129            (*fields*             (class-file-fields ,var))
130            (*static-code*        (class-file-static-code ,var))
131            (*declared-symbols*   (class-file-symbols ,var))
132            (*declared-functions* (class-file-functions ,var))
133            (*declared-strings*   (class-file-strings ,var))
134            (*declared-integers*  (class-file-integers ,var)))
135       (progn ,@body)
136       (setf (class-file-pool ,var)         *pool*
137             (class-file-pool-count ,var)   *pool-count*
138             (class-file-pool-entries ,var) *pool-entries*
139             (class-file-fields ,var)       *fields*
140             (class-file-static-code ,var)  *static-code*
141             (class-file-symbols ,var)      *declared-symbols*
142             (class-file-functions ,var)    *declared-functions*
143             (class-file-strings ,var)      *declared-strings*
144             (class-file-integers ,var)     *declared-integers*))))
145
146(defstruct compiland
147  name
148  (kind :external) ; :INTERNAL or :EXTERNAL
149  lambda-expression
150  arg-vars
151  arity ; NIL if the number of args can vary.
152  p1-result
153  parent
154  (children 0 :type fixnum) ; Number of local functions defined with FLET or LABELS.
155  argument-register
156  closure-register
157  class-file ; class-file object
158  (%single-valued-p t))
159
160(defknown compiland-single-valued-p (t) t)
161(defun compiland-single-valued-p (compiland)
162  (unless (compiland-parent compiland)
163    (let ((name (compiland-name compiland)))
164      (when name
165        (let ((result-type
166               (or (function-result-type name)
167                   (and (proclaimed-ftype name)
168                        (ftype-result-type (proclaimed-ftype name))))))
169          (when result-type
170            (return-from compiland-single-valued-p
171                         (cond ((eq result-type '*)
172                                nil)
173                               ((atom result-type)
174                                t)
175                               ((eq (%car result-type) 'VALUES)
176                                (= (length result-type) 2))
177                               (t
178                                t))))))))
179  ;; Otherwise...
180  (compiland-%single-valued-p compiland))
181
182(defvar *current-compiland* nil)
183
184(defvar *this-class* nil)
185
186(defvar *code* ())
187
188;; All tags visible at the current point of compilation, some of which may not
189;; be in the current compiland.
190(defvar *visible-tags* ())
191
192;; The next available register.
193(defvar *register* 0)
194
195;; Total number of registers allocated.
196(defvar *registers-allocated* 0)
197
198(defvar *handlers* ())
199
200(defstruct handler
201  from
202  to
203  code
204  catch-type)
205
206;; Variables visible at the current point of compilation.
207(defvar *visible-variables* nil)
208
209;; All variables seen so far.
210(defvar *all-variables* nil)
211
212;; Undefined variables that we've already warned about.
213(defvar *undefined-variables* nil)
214
215(defvar *dump-variables* nil)
216
217(defun dump-1-variable (variable)
218  (sys::%format t "  ~S special-p = ~S register = ~S index = ~S declared-type = ~S~%"
219           (variable-name variable)
220           (variable-special-p variable)
221           (variable-register variable)
222           (variable-index variable)
223           (variable-declared-type variable)))
224
225(defun dump-variables (list caption &optional (force nil))
226  (when (or force *dump-variables*)
227    (write-string caption)
228    (if list
229        (dolist (variable list)
230          (dump-1-variable variable))
231        (sys::%format t "  None.~%"))))
232
233(defstruct (variable-info (:conc-name variable-)
234                          (:constructor make-variable)
235                          (:predicate variable-p))
236  name
237  initform
238  temp-register
239  special-p
240  (declared-type :none)
241  (derived-type :none)
242  ignore-p
243  ignorable-p
244  representation
245  register ; register number or NIL
246  index
247  closure-index
248  reserved-register
249  (reads 0 :type fixnum)
250  (writes 0 :type fixnum)
251  references
252  used-non-locally-p
253  (compiland *current-compiland*))
254
255(defstruct (var-ref (:constructor make-var-ref (variable)))
256  ;; The variable this reference refers to. Will be NIL if the VAR-REF has been
257  ;; rewritten to reference a constant value.
258  variable
259  ;; True if the VAR-REF has been rewritten to reference a constant value.
260  constant-p
261  ;; The constant value of this VAR-REF.
262  constant-value)
263
264;; obj can be a symbol or variable
265;; returns variable or nil
266(declaim (ftype (function (t) t) unboxed-fixnum-variable))
267(defun unboxed-fixnum-variable (obj)
268  (cond ((symbolp obj)
269         (let ((variable (find-visible-variable obj)))
270           (if (and variable
271                    (eq (variable-representation variable) :int))
272               variable
273               nil)))
274        ((variable-p obj)
275         (if (eq (variable-representation obj) :int)
276             obj
277             nil))
278        (t
279         nil)))
280
281(defvar *child-p* nil
282  "True for local functions created by FLET, LABELS and (NAMED-)LAMBDA")
283
284(defknown find-variable (symbol list) t)
285(defun find-variable (name variables)
286  (dolist (variable variables)
287    (when (eq name (variable-name variable))
288      (return variable))))
289
290(defknown find-visible-variable (t) t)
291(defun find-visible-variable (name)
292  (dolist (variable *visible-variables*)
293    (when (eq name (variable-name variable))
294      (return variable))))
295
296(defknown allocate-register () (integer 0 65535))
297(defun allocate-register ()
298  (let* ((register *register*)
299         (next-register (1+ register)))
300    (declare (type (unsigned-byte 16) register next-register))
301    (setf *register* next-register)
302    (when (< *registers-allocated* next-register)
303      (setf *registers-allocated* next-register))
304    register))
305
306(defknown allocate-register-pair () (integer 0 65535))
307(defun allocate-register-pair ()
308  (let* ((register *register*)
309         (next-register (+ register 2)))
310    (declare (type (unsigned-byte 16) register next-register))
311    (setf *register* next-register)
312    (when (< *registers-allocated* next-register)
313      (setf *registers-allocated* next-register))
314    register))
315
316(defstruct local-function
317  name
318  compiland
319  inline-expansion
320  function
321  class-file
322  variable)
323
324(defvar *local-functions* ())
325
326(defknown find-local-function (t) t)
327(defun find-local-function (name)
328  (dolist (local-function *local-functions* nil)
329    (when (equal name (local-function-name local-function))
330        (return local-function))))
331
332(defvar *using-arg-array* nil)
333(defvar *hairy-arglist-p* nil)
334
335(defstruct node
336  ;; Block name or (TAGBODY) or (LET) or (MULTIPLE-VALUE-BIND).
337  name
338  form
339  (compiland *current-compiland*))
340
341;; Used to wrap TAGBODYs, UNWIND-PROTECTs and LET/LET*/M-V-B forms as well as
342;; BLOCKs per se.
343(defstruct (block-node (:conc-name block-) (:include node) (:constructor make-block-node (name)))
344  (exit (gensym))
345  target
346  catch-tag
347  ;; True if there is any RETURN from this block.
348  return-p
349  ;; True if there is a non-local RETURN from this block.
350  non-local-return-p
351  ;; True if a tag in this tagbody is the target of a non-local GO.
352  non-local-go-p
353  ;; If non-nil, register containing saved dynamic environment for this block.
354  environment-register
355  ;; Only used in LET/LET*/M-V-B nodes.
356  vars
357  free-specials
358  )
359
360(defknown node-constant-p (t) boolean)
361(defun node-constant-p (object)
362  (cond ((block-node-p object)
363         nil)
364        ((var-ref-p object)
365         nil)
366        ((constantp object)
367         t)
368        (t
369         nil)))
370
371(defvar *blocks* ())
372
373(defun find-block (name)
374  (dolist (block *blocks*)
375    (when (eq name (block-name block))
376      (return block))))
377
378(defstruct tag
379  name
380  label
381  block
382  (compiland *current-compiland*))
383
384(defun process-ignore/ignorable (declaration names variables)
385  (when (memq declaration '(IGNORE IGNORABLE))
386    (let ((what (if (eq declaration 'IGNORE) "ignored" "ignorable")))
387      (dolist (name names)
388        (let ((variable (find-variable name variables)))
389          (cond ((null variable)
390                 (compiler-style-warn "Declaring unknown variable ~S to be ~A."
391                                      name what))
392                ((variable-special-p variable)
393                 (compiler-style-warn "Declaring special variable ~S to be ~A."
394                                      name what))
395                ((eq declaration 'IGNORE)
396                 (setf (variable-ignore-p variable) t))
397                (t
398                 (setf (variable-ignorable-p variable) t))))))))
399
400(defun compile (name &optional definition)
401  (jvm-compile name definition))
402
403(defun finalize-generic-functions ()
404  (dolist (sym '(make-instance
405                 initialize-instance
406                 shared-initialize))
407    (let ((gf (and (fboundp sym) (fdefinition sym))))
408      (when (typep gf 'generic-function)
409        (unless (compiled-function-p gf)
410          (mop::finalize-generic-function gf))))))
411
412(finalize-generic-functions)
413
414(provide 'jvm)
Note: See TracBrowser for help on using the repository browser.