Changeset 8327


Ignore:
Timestamp:
01/03/05 03:14:48 (17 years ago)
Author:
piso
Message:

Work in progress (tested).

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/j/src/org/armedbear/lisp/jvm.lisp

    r8326 r8327  
    22;;;
    33;;; Copyright (C) 2003-2004 Peter Graves
    4 ;;; $Id: jvm.lisp,v 1.341 2005-01-03 00:52:58 piso Exp $
     4;;; $Id: jvm.lisp,v 1.342 2005-01-03 03:14:48 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    198198         (variable (make-variable :name name :special-p special-p :index index)))
    199199    (push variable *visible-variables*)
    200     (push variable *all-variables*)
     200;;     (push variable *all-variables*)
    201201    (unless special-p
    202202      (add-variable-to-context variable))
     
    216216
    217217(defun allocate-register ()
    218 ;;   (prog1
    219 ;;    *register*
    220 ;;    (incf *register*)
    221 ;;    (when (< *registers-allocated* *register*)
    222 ;;      (setf *registers-allocated* *register*))))
    223218  (let* ((register *register*)
    224219         (next-register (1+ register)))
     
    297292    (setf vars (nreverse vars))
    298293    (dolist (variable vars)
    299       (push variable *visible-variables*))
     294      (push variable *visible-variables*)
     295      (push variable *all-variables*))
    300296    vars))
    301297
     
    308304                    (var (make-variable :name name :initform initform)))
    309305               (push var vars)
    310                (push var *visible-variables*)))
     306               (push var *visible-variables*)
     307               (push var *all-variables*)))
    311308            (t
    312309             (let ((var (make-variable :name varspec)))
    313310               (push var vars)
    314                (push var *visible-variables*)))))
     311               (push var *visible-variables*)
     312               (push var *all-variables*)))))
    315313    (nreverse vars)))
    316314
     
    372370        (let ((var (make-variable :name symbol)))
    373371          (push var vars)
    374           (push var *visible-variables*)))
     372          (push var *visible-variables*)
     373          (push var *all-variables*)))
    375374      ;; Check for globally declared specials.
    376375      (dolist (variable vars)
     
    440439
    441440(defun p1-flet/labels (form)
    442   (dformat t "p1-flet/labels~%")
    443441  (when *current-compiland*
    444442    (incf (compiland-children *current-compiland*) (length (cadr form))))
    445 
    446   ;; FIXME This comment is obsolete! Jan 2 2005 7:45 AM
    447   ;; Do pass 1 on the local definitions, discarding the result (we're just
    448   ;; checking for non-local RETURNs and GOs.)
    449 
    450 
    451 
    452   (let (
    453 ;;         (*current-compiland* nil)
    454         (*current-compiland* *current-compiland*)
    455         (compilands ())
    456         )
     443  (let ((*current-compiland* *current-compiland*)
     444        (compilands ()))
    457445    (dolist (definition (cadr form))
    458446      (let* ((name (car definition))
     
    13851373
    13861374(defun resolve-variables ()
    1387   (dump-variables (reverse *all-variables*)
    1388                   (%format nil "Variables in ~A:~%" (compiland-name *current-compiland*)))
    13891375  (let ((code (nreverse *code*)))
    13901376    (setf *code* nil)
     
    14001386;;            (%format t "variable-representation = ~S~%"
    14011387;;                     (variable-representation variable))
    1402            (dformat t "variable = ~S~%" (variable-name variable))
    1403            (dformat t "level = ~S~%" (variable-level variable))
    1404            (dformat t "*nesting-level* = ~S~%" *nesting-level*)
    14051388           (aver (variable-p variable))
    14061389           (cond
     
    14271410                  (= (variable-level variable) *nesting-level*))
    14281411             (emit 'aload 1)
    1429              (aver (variable-index variable))
    14301412             (emit 'bipush (variable-index variable))
    14311413             (emit 'aaload)
     
    14351417             (emit 'aload *context-register*) ; Array of arrays.
    14361418             (aver (fixnump (variable-level variable)))
    1437              (aver (variable-level variable))
    14381419             (emit 'bipush (variable-level variable))
    14391420             (emit 'aaload) ; Locals array for level in question.
     
    27372718
    27382719(defun compile-local-function-call (form target)
    2739   (let* ((fun (car form))
     2720  (let* ((op (car form))
    27402721         (args (cdr form))
    2741          (local-function (find-local-function fun)))
    2742     (aver (not (null local-function)))
     2722         (local-function (find-local-function op)))
    27432723    (cond ((local-function-variable local-function)
    27442724           ;; LABELS
     
    32193199         (bind-special-p nil)
    32203200         (variables (block-vars block)))
    3221     ;; Process declarations.
    3222 ;;     (dolist (f (cdddr form))
    3223 ;;       (unless (and (consp f) (eq (car f) 'declare))
    3224 ;;         (return))
    3225 ;;       (let ((decls (cdr f)))
    3226 ;;         (dolist (decl decls)
    3227 ;;           (when (eq (car decl) 'special)
    3228 ;;             (setf specials (append (cdr decl) specials))))))
    3229     ;; Process variables and allocate registers for them.
    3230 ;;     (dolist (var vars)
    3231 ;;       (let* ((special-p (if (or (memq var specials) (special-variable-p var)) t nil))
    3232 ;;              (variable
    3233 ;;               (make-variable :name var
    3234 ;;                              :special-p special-p
    3235 ;;                              :index (if special-p nil (length (context-vars *context*)))
    3236 ;;                              :register (if (or special-p *use-locals-vector*) nil (allocate-register)))))
    3237 ;;         (if special-p
    3238 ;;             (setf bind-special-p t)
    3239 ;;             (add-variable-to-context variable))
    3240 ;;         (push variable variables)))
    3241 ;;     (setf variables (nreverse variables))
    32423201    (dolist (variable variables)
    32433202      (let ((special-p (variable-special-p variable)))
     
    33153274    (dolist (variable variables)
    33163275      (push variable *visible-variables*)
    3317       (push variable *all-variables*))
     3276;;       (push variable *all-variables*)
     3277      )
    33183278    ;; Body.
    33193279    (compile-progn-body (cdddr form) target)
     
    34173377  (dolist (variable (block-vars block))
    34183378    (push variable *visible-variables*)
    3419     (push variable *all-variables*)))
     3379;;     (push variable *all-variables*)
     3380    ))
    34203381
    34213382(defun compile-let*-bindings (block)
     
    34743435          (add-variable-to-context variable))
    34753436        (push variable *visible-variables*)
    3476         (push variable *all-variables*)
     3437;;         (push variable *all-variables*)
    34773438        (unless boundp
    34783439          (compile-binding variable))))
     
    38923853    (emit-move-from-stack target)))
    38933854
    3894 ;; (defun p2-local-function (definition local-function)
    38953855(defun p2-local-function (compiland local-function)
    3896   (dformat t "entering p2-local-function~%")
    3897   (aver (compiland-p compiland))
    3898   (let* (;;(name (car definition))
    3899          (name (compiland-name compiland))
    3900          ;;(arglist (cadr definition))
     3856  (let* ((name (compiland-name compiland))
    39013857         (arglist (cadr (compiland-lambda-expression compiland)))
    39023858         form
     
    39133869                            (not (constantp (second arg))))
    39143870                   (error "COMPILE-LOCAL-FUNCTION: can't handle optional argument with non-constant initform.")))))))
    3915 ;;     (multiple-value-bind (body decls)
    3916 ;;         (sys::parse-body (cddr definition))
    3917 ;;       (setf body (list (list* 'BLOCK name body)))
    3918 ;;       (dolist (decl decls)
    3919 ;;         (push decl body))
    3920 ;;       (setf form (list* 'LAMBDA arglist body)))
    3921 
    39223871    (setf form (compiland-lambda-expression compiland))
    3923 
    39243872    (let ((*nesting-level* (1+ *nesting-level*)))
    3925 
    3926 ;;       (setf compiland (make-compiland :name name
    3927 ;;                                       :lambda-expression form
    3928 ;;                                       :parent *current-compiland*))
    3929 
    39303873      (setf classfile (if *compile-file-truename*
    39313874                          (sys::next-classfile-name)
     
    39333876                           (%format nil "local-~D.class" *child-count*)
    39343877                           (incf *child-count*))))
    3935 
    39363878      (setf (compiland-classfile compiland) classfile)
    3937 
    39383879      (let ((*current-compiland* compiland)
    39393880            (*speed* *speed*)
    39403881            (*safety* *safety*)
    39413882            (*debug* *debug*))
    3942         ;; Pass 1.
    3943 ;;         (p1-compiland compiland)
    3944         ;; Pass 2.
    3945         (dformat t "p2-local-function calling p2-compiland~%")
    3946         (p2-compiland compiland)
    3947         (dformat t "p2-local-function back from p2-compiland~%")
    3948         )
    3949 
    3950 
     3883        (p2-compiland compiland))
    39513884      (when (null *compile-file-truename*)
    39523885        (setf function (sys:load-compiled-function classfile))))
     
    39703903  (if *use-locals-vector*
    39713904      (let ((*local-functions* *local-functions*)
    3972 ;;             (definitions (cadr form))
    39733905            (compilands (cadr form))
    39743906            (body (cddr form)))
    3975 ;;         (dolist (definition definitions)
    3976 ;;           (p2-local-function definition nil))
    39773907        (dolist (compiland compilands)
    39783908          (p2-local-function compiland nil))
     
    51545084
    51555085(defun p1-compiland (compiland)
    5156   (aver (compiland-p compiland))
    51575086  (let ((precompiled-form (compiland-lambda-expression compiland)))
    51585087    (aver (eq (car precompiled-form) 'LAMBDA))
     
    51625091           (syms (sys::varlist closure))
    51635092           vars)
    5164 ;;       (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux)
    5165 ;;         (sys::parse-lambda-list lambda-list)
    5166 ;;         (setf syms required)
    5167 ;;         (when optional
    5168 ;;           (setf syms (append syms optional)))
    5169 ;;         (when restp
    5170 ;;           (setf syms (append syms (list rest))))
    5171 ;;         (when keyp
    5172 ;;           (dformat t "keys = ~S~%" keys)
    5173 ;;           (setf syms (append syms keys)))
    5174       (dformat t "syms = ~S~%" syms)
    51755093      (dolist (sym syms)
    5176         (push (make-variable :name sym) vars))
     5094        (let ((var (make-variable :name sym)))
     5095          (push var vars)
     5096          (push var *all-variables*)))
    51775097      (setf (compiland-arg-vars compiland) (nreverse vars)))
    5178     ;; Pass 1.
    51795098    (let ((*visible-variables* *visible-variables*))
    51805099      (dformat t "p1-compiland *visible-variables* = ~S~%"
     
    52325151
    52335152         (*visible-variables* *visible-variables*)
    5234          (*all-variables* *all-variables*)
    52355153         (*undefined-variables* *undefined-variables*)
    52365154
     
    52445162         (*initialize-thread-var* nil))
    52455163
    5246     (dformat t "pass2 *visible-variables* = ~S~%"
    5247              (mapcar #'variable-name *visible-variables*))
    5248 
    5249 ;;     (setf *visible-variables*
    5250 ;;           (append *visible-variables* (compiland-arg-vars compiland)))
     5164;;     (dformat t "pass2 *visible-variables* = ~S~%"
     5165;;              (mapcar #'variable-name *visible-variables*))
     5166
    52515167    (dolist (var (compiland-arg-vars compiland))
    52525168      (push var *visible-variables*))
    52535169
    5254     (dformat t "pass2 *visible-variables* ==> ~S~%"
    5255              (mapcar #'variable-name *visible-variables*))
     5170;;     (dformat t "pass2 *visible-variables* ==> ~S~%"
     5171;;              (mapcar #'variable-name *visible-variables*))
    52565172
    52575173    (dformat t "pass2 *using-arg-array* = ~S~%" *using-arg-array*)
     
    52715187                  (index 0))
    52725188             (dolist (var vars)
    5273 ;;                (let ((variable (make-variable :name var
    5274 ;;                                               :special-p nil ;; FIXME
    5275 ;;                                               :register nil
    5276 ;;                                               :index index)))
    52775189               (let ((variable (find-visible-variable var)))
    52785190                 (when (null variable)
     
    52835195                 (setf (variable-index variable) index)
    52845196
    5285                  (push variable *all-variables*)
    5286 ;;                  (push variable *visible-variables*)
     5197;;                  (push variable *all-variables*)
    52875198                 (push variable parameters)
    52885199                 (add-variable-to-context variable)
     
    52935204             (dolist (arg args)
    52945205               (aver (= index (length (context-vars *context*))))
    5295 ;;                (let ((variable (make-variable :name arg
    5296 ;;                                               :special-p nil ;; FIXME
    5297 ;;                                               :register (if *using-arg-array* nil register)
    5298 ;;                                               :index index)))
    52995206               (let ((variable (find-visible-variable arg)))
    53005207                 (when (null variable)
     
    53065213                 (setf (variable-index variable) index)
    53075214
    5308                  (push variable *all-variables*)
    5309 ;;                  (push variable *visible-variables*)
     5215;;                  (push variable *all-variables*)
    53105216                 (push variable parameters)
    53115217                 (add-variable-to-context variable)
     
    53195225                 (setf variable (make-variable :name name
    53205226                                               :special-p t))
    5321                  (push variable *all-variables*)
     5227;;                  (push variable *all-variables*)
    53225228                 (push variable *visible-variables*))
    53235229                (t
     
    54585364(defun compile-1 (compiland)
    54595365  (dformat t "compile-1 ~S~%" (compiland-name compiland))
    5460   (let ((*current-compiland* compiland)
     5366  (let ((*all-variables* ())
     5367        (*current-compiland* compiland)
    54615368        (*speed* *speed*)
    54625369        (*safety* *safety*)
     
    54645371    ;; Pass 1.
    54655372    (p1-compiland compiland)
     5373    (dformat t "*all-variables* = ~S~%" (mapcar #'variable-name *all-variables*))
    54665374    ;; Pass 2.
    5467     (p2-compiland compiland)))
     5375    (prog1
     5376     (p2-compiland compiland)
     5377     (dformat t "*all-variables* = ~S~%" (mapcar #'variable-name *all-variables*)))
     5378    ))
    54685379
    54695380(defun compile-defun (name form environment &optional (classfile "out.class"))
Note: See TracChangeset for help on using the changeset viewer.