Changeset 8326


Ignore:
Timestamp:
01/03/05 00:52:58 (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

    r8325 r8326  
    22;;;
    33;;; Copyright (C) 2003-2004 Peter Graves
    4 ;;; $Id: jvm.lisp,v 1.340 2005-01-02 04:11:43 piso Exp $
     4;;; $Id: jvm.lisp,v 1.341 2005-01-03 00:52:58 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    443443  (when *current-compiland*
    444444    (incf (compiland-children *current-compiland*) (length (cadr form))))
     445
     446  ;; FIXME This comment is obsolete! Jan 2 2005 7:45 AM
    445447  ;; Do pass 1 on the local definitions, discarding the result (we're just
    446448  ;; checking for non-local RETURNs and GOs.)
    447   (let ((*current-compiland* nil))
     449
     450
     451
     452  (let (
     453;;         (*current-compiland* nil)
     454        (*current-compiland* *current-compiland*)
     455        (compilands ())
     456        )
    448457    (dolist (definition (cadr form))
    449       (setf definition (list* 'BLOCK (car definition) (cadr definition) (cddr definition)))
    450       (p1 definition)))
    451   (list* (car form) (cadr form) (mapcar #'p1 (cddr form))))
     458      (let* ((name (car definition))
     459             (lambda-list (cadr definition))
     460             (body (cddr definition))
     461             (compiland (make-compiland :name name
     462                                        :parent *current-compiland*)))
     463        (multiple-value-bind (body decls)
     464            (sys::parse-body body)
     465          (setf (compiland-lambda-expression compiland)
     466                `(lambda ,lambda-list ,@decls (block ,name ,@body)))
     467          (let ((*visible-variables* *visible-variables*)
     468                (*nesting-level* (1+ *nesting-level*))
     469                (*current-compiland* compiland))
     470            (p1-compiland compiland)))
     471        (push compiland compilands)))
     472
     473;;     (list* (car form) (cadr form) (mapcar #'p1 (cddr form))))
     474  (list* (car form) (nreverse compilands) (mapcar #'p1 (cddr form)))))
    452475
    453476(defun p1-function (form)
     
    462485  (aver (eq (car form) 'LAMBDA))
    463486  (when *current-compiland*
     487    (aver (compiland-p *current-compiland*))
    464488    (unless (or (compiland-contains-lambda *current-compiland*)
    465489                (eq form (compiland-lambda-expression *current-compiland*)))
     
    13761400;;            (%format t "variable-representation = ~S~%"
    13771401;;                     (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*)
    13781405           (aver (variable-p variable))
    13791406           (cond
     
    13931420            ((= (variable-level variable) *nesting-level* 0)
    13941421             (emit 'aload 1)
     1422             (aver (variable-index variable))
    13951423             (emit 'bipush (variable-index variable))
    13961424             (emit 'aaload)
     
    13991427                  (= (variable-level variable) *nesting-level*))
    14001428             (emit 'aload 1)
     1429             (aver (variable-index variable))
    14011430             (emit 'bipush (variable-index variable))
    14021431             (emit 'aaload)
     
    14061435             (emit 'aload *context-register*) ; Array of arrays.
    14071436             (aver (fixnump (variable-level variable)))
     1437             (aver (variable-level variable))
    14081438             (emit 'bipush (variable-level variable))
    14091439             (emit 'aaload) ; Locals array for level in question.
     1440             (aver (variable-index variable))
    14101441             (emit 'bipush (variable-index variable))
    14111442             (emit 'aaload)
     
    14131444            (t
    14141445             (emit 'aload 1)
     1446             (aver (variable-index variable))
    14151447             (emit 'bipush (variable-index variable))
    14161448             (emit 'aaload)
     
    27362768        (emit-clear-values))) ; array left on stack here
    27372769    ;; Stack: template-function args
    2738     (cond ((zerop *nesting-level*)
    2739            ;; Make a vector of size 1.
    2740            (emit 'sipush 1)
    2741            (emit 'anewarray "[Lorg/armedbear/lisp/LispObject;")
    2742            ;; Store args/locals register in slot 0.
    2743            (emit 'dup)
    2744            (emit 'sipush 0)
    2745            (emit 'aload 1) ;; Args/locals register.
    2746            (emit 'aastore))
    2747           ((= *nesting-level* (local-function-nesting-level local-function))
    2748            (emit 'aload 2))
    2749           (t
    2750            ;; This is the general case.
    2751            (emit 'sipush (local-function-nesting-level local-function))
    2752            (emit 'anewarray "[Lorg/armedbear/lisp/LispObject;")
    2753            (dotimes (i (1- (local-function-nesting-level local-function)))
    2754              (emit 'dup)
    2755              (emit 'sipush i)
    2756              (emit 'aload 2)
    2757              (emit 'sipush i)
    2758              (emit 'aaload)
    2759              (emit 'aastore))
    2760            (emit 'dup)
    2761            (emit 'sipush (1- (local-function-nesting-level local-function)))
    2762            (emit 'aload 1) ; Args/locals.
    2763            (emit 'aastore)))
     2770    (cond
     2771     ((zerop *nesting-level*)
     2772      (dformat t "compile-local-function-call zerop *nesting-level* case~%")
     2773      ;; Make a vector of size 1.
     2774      (emit 'sipush 1)
     2775      (emit 'anewarray "[Lorg/armedbear/lisp/LispObject;")
     2776      ;; Store args/locals register in slot 0.
     2777      (emit 'dup)
     2778      (emit 'sipush 0)
     2779      (emit 'aload 1) ;; Args/locals register.
     2780      (emit 'aastore))
     2781     ((= *nesting-level* (local-function-nesting-level local-function))
     2782      (emit 'aload 2))
     2783     (t
     2784      ;; This is the general case.
     2785      (dformat t "compile-local-function-call general case~%")
     2786      (emit 'sipush (local-function-nesting-level local-function))
     2787      (emit 'anewarray "[Lorg/armedbear/lisp/LispObject;")
     2788      (dotimes (i (1- (local-function-nesting-level local-function)))
     2789        (emit 'dup)
     2790        (emit 'sipush i)
     2791        (emit 'aload 2)
     2792        (emit 'sipush i)
     2793        (emit 'aaload)
     2794        (emit 'aastore))
     2795      (emit 'dup)
     2796      (emit 'sipush (1- (local-function-nesting-level local-function)))
     2797      (emit 'aload 1) ; Args/locals.
     2798      (emit 'aastore)))
    27642799    ;; Stack: template-function args context
    27652800    (emit-invokevirtual +lisp-object-class+
     
    38573892    (emit-move-from-stack target)))
    38583893
    3859 (defun compile-local-function (definition local-function)
    3860   (let* ((name (car definition))
    3861          (arglist (cadr definition))
     3894;; (defun p2-local-function (definition local-function)
     3895(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))
     3901         (arglist (cadr (compiland-lambda-expression compiland)))
    38623902         form
    38633903         function
     
    38733913                            (not (constantp (second arg))))
    38743914                   (error "COMPILE-LOCAL-FUNCTION: can't handle optional argument with non-constant initform.")))))))
    3875     (multiple-value-bind (body decls)
    3876         (sys::parse-body (cddr definition))
    3877       (setf body (list (list* 'BLOCK name body)))
    3878       (dolist (decl decls)
    3879         (push decl body))
    3880       (setf form (list* 'LAMBDA arglist body)))
     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
     3922    (setf form (compiland-lambda-expression compiland))
     3923
    38813924    (let ((*nesting-level* (1+ *nesting-level*)))
     3925
     3926;;       (setf compiland (make-compiland :name name
     3927;;                                       :lambda-expression form
     3928;;                                       :parent *current-compiland*))
     3929
    38823930      (setf classfile (if *compile-file-truename*
    38833931                          (sys::next-classfile-name)
    38843932                          (prog1
    3885                               (%format nil "local-~D.class" *child-count*)
    3886                               (incf *child-count*))))
    3887       (compile-1 (make-compiland :name name
    3888                                         :lambda-expression form
    3889                                         :classfile classfile
    3890                                         :parent *current-compiland*))
    3891 ;;       (cond (*compile-file-truename*
    3892 ;; ;;              (setf classfile (sys::next-classfile-name))
    3893 ;; ;;              (compile-1 (make-compiland :name name
    3894 ;; ;;                                         :lambda-expression form
    3895 ;; ;;                                         :classfile classfile
    3896 ;; ;;                                         :parent *current-compiland*))
    3897 ;;              )
    3898 ;;             (t
    3899 ;; ;;              (setf classfile (prog1
    3900 ;; ;;                               (%format nil "local-~D.class" *child-count*)
    3901 ;; ;;                               (incf *child-count*)))
    3902 ;; ;;              (compile-1 (make-compiland :name name
    3903 ;; ;;                                         :lambda-expression form
    3904 ;; ;;                                         :classfile classfile
    3905 ;; ;;                                         :parent *current-compiland*))
    3906 ;;              (setf function (sys:load-compiled-function classfile)))))
     3933                           (%format nil "local-~D.class" *child-count*)
     3934                           (incf *child-count*))))
     3935
     3936      (setf (compiland-classfile compiland) classfile)
     3937
     3938      (let ((*current-compiland* compiland)
     3939            (*speed* *speed*)
     3940            (*safety* *safety*)
     3941            (*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
    39073951      (when (null *compile-file-truename*)
    39083952        (setf function (sys:load-compiled-function classfile))))
     
    39263970  (if *use-locals-vector*
    39273971      (let ((*local-functions* *local-functions*)
    3928             (definitions (cadr form))
     3972;;             (definitions (cadr form))
     3973            (compilands (cadr form))
    39293974            (body (cddr form)))
    3930         (dolist (definition definitions)
    3931           (compile-local-function definition nil))
     3975;;         (dolist (definition definitions)
     3976;;           (p2-local-function definition nil))
     3977        (dolist (compiland compilands)
     3978          (p2-local-function compiland nil))
    39323979        (do ((forms body (cdr forms)))
    39333980            ((null forms))
     
    39353982      (error "COMPILE-FLET: unsupported case.")))
    39363983
    3937 (defun compile-labels (form &key target representation)
     3984(defun p2-labels (form &key target representation)
    39383985  (if *use-locals-vector*
    39393986      (let ((*local-functions* *local-functions*)
    3940             (definitions (cadr form))
     3987;;             (definitions (cadr form))
     3988            (compilands (cadr form))
    39413989            (body (cddr form)))
    3942         (dolist (definition definitions)
    3943           (let* ((name (car definition))
     3990;;         (dolist (definition definitions)
     3991;;           (let* ((name (car definition))
     3992;;                  (variable (push-variable (copy-symbol name) nil)))
     3993;;             (push (make-local-function :name name :variable variable)
     3994;;                   *local-functions*)))
     3995;;         (dolist (definition definitions)
     3996;;           (let* ((name (car definition))
     3997;;                  (local-function (find-local-function name)))
     3998;;             (compile-local-function definition local-function)))
     3999        (dolist (compiland compilands)
     4000          (aver (compiland-p compiland))
     4001          (let* ((name (compiland-name compiland))
    39444002                 (variable (push-variable (copy-symbol name) nil)))
    39454003            (push (make-local-function :name name :variable variable)
    39464004                  *local-functions*)))
    3947         (dolist (definition definitions)
    3948           (let* ((name (car definition))
     4005        (dolist (compiland compilands)
     4006          (aver (compiland-p compiland))
     4007          (let* ((name (compiland-name compiland))
    39494008                 (local-function (find-local-function name)))
    3950             (compile-local-function definition local-function)))
     4009            (p2-local-function compiland local-function)))
    39514010        (do ((forms body (cdr forms)))
    39524011            ((null forms))
     
    39804039
    39814040(defun compile-lambda (form target)
    3982   (let* ((closure-vars *visible-variables*)
     4041  (let* (;;(closure-vars *visible-variables*)
    39834042         (lambda-list (cadr form))
    39844043         (lambda-body (cddr form)))
     
    50955154
    50965155(defun p1-compiland (compiland)
     5156  (aver (compiland-p compiland))
    50975157  (let ((precompiled-form (compiland-lambda-expression compiland)))
    50985158    (aver (eq (car precompiled-form) 'LAMBDA))
    50995159    (process-optimization-declarations (cddr precompiled-form))
    5100     (let ((lambda-list (cadr precompiled-form))
    5101           syms vars)
    5102       (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux)
    5103         (sys::parse-lambda-list lambda-list)
    5104         (setf syms required)
    5105         (when optional
    5106           (setf syms (append syms optional)))
    5107         (when restp
    5108           (setf syms (append syms (list rest))))
    5109         (when keyp
    5110           (setf syms (append syms keys)))
    5111         (dformat t "syms = ~S~%" syms))
     5160    (let* ((lambda-list (cadr precompiled-form))
     5161           (closure (sys::make-closure `(lambda ,lambda-list nil) nil))
     5162           (syms (sys::varlist closure))
     5163           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)
    51125175      (dolist (sym syms)
    51135176        (push (make-variable :name sym) vars))
     
    51155178    ;; Pass 1.
    51165179    (let ((*visible-variables* *visible-variables*))
    5117       (setf *visible-variables*
    5118             (append *visible-variables* (compiland-arg-vars compiland)))
     5180      (dformat t "p1-compiland *visible-variables* = ~S~%"
     5181               (mapcar #'variable-name *visible-variables*))
     5182;;       (setf *visible-variables*
     5183;;             (append *visible-variables* (compiland-arg-vars compiland)))
     5184      (dolist (var (compiland-arg-vars compiland))
     5185        (push var *visible-variables*))
     5186
     5187      (dformat t "p1-compiland *visible-variables* ==> ~S~%"
     5188               (mapcar #'variable-name *visible-variables*))
    51195189      (setf (compiland-p1-result compiland) (p1 precompiled-form)))))
    51205190
    51215191(defun p2-compiland (compiland)
     5192  (dformat t "p2-compiland ~S~%" (compiland-name compiland))
    51225193  (let* ((p1-result (compiland-p1-result compiland))
    51235194         (*declared-symbols* (make-hash-table :test 'eq))
     
    51735244         (*initialize-thread-var* nil))
    51745245
    5175       (setf *visible-variables*
    5176             (append *visible-variables* (compiland-arg-vars compiland)))
    5177 
    5178       (dformat t "pass2 *visible-variables* = ~S~%"
    5179                (mapcar #'variable-name *visible-variables*))
    5180 
    5181       (when (zerop *nesting-level*)
    5182         (setf *child-count* 0))
    5183       (setf *context* (make-context))
    5184       (setf (method-name-index execute-method)
    5185             (pool-name (method-name execute-method)))
    5186       (setf (method-descriptor-index execute-method)
    5187             (pool-name (method-descriptor execute-method)))
    5188       (cond (*hairy-arglist-p*
    5189              (let* ((closure (sys::make-closure p1-result nil))
    5190                     (vars (sys::varlist closure))
    5191                     (index 0))
    5192                (dolist (var vars)
    5193                  (let ((variable (make-variable :name var
    5194                                                 :special-p nil ;; FIXME
    5195                                                 :register nil
    5196                                                 :index index)))
    5197                    (push variable *all-variables*)
    5198                    (push variable *visible-variables*)
    5199                    (push variable parameters)
    5200                    (add-variable-to-context variable)
    5201                    (incf index)))))
    5202             (t
    5203              (let ((register 1)
    5204                    (index 0))
    5205                (dolist (arg args)
    5206                  (aver (= index (length (context-vars *context*))))
    5207                  (let ((variable (make-variable :name arg
    5208                                                 :special-p nil ;; FIXME
    5209                                                 :register (if *using-arg-array* nil register)
    5210                                                 :index index)))
    5211                    (push variable *all-variables*)
    5212                    (push variable *visible-variables*)
    5213                    (push variable parameters)
    5214                    (add-variable-to-context variable)
    5215                    (incf register)
    5216                    (incf index))))))
    5217 
    5218       (let ((specials (process-special-declarations body)))
    5219         (dolist (name specials)
    5220           (let ((variable (find-visible-variable name)))
    5221             (cond ((null variable)
    5222                    (setf variable (make-variable :name name
    5223                                                  :special-p t))
    5224                    (push variable *all-variables*)
    5225                    (push variable *visible-variables*))
    5226                   (t
    5227                    (setf (variable-special-p variable) t))))))
    5228 
    5229       ;; Process type declarations.
    5230       (when *trust-user-type-declarations*
    5231         (unless (or *child-p*
    5232                     (plusp (compiland-children *current-compiland*)))
    5233           (dolist (subform body)
    5234             (unless (and (consp subform) (eq (car subform) 'DECLARE))
    5235               (return))
    5236             (let ((decls (cdr subform)))
    5237               (dolist (decl decls)
    5238                 (case (car decl)
    5239                   (TYPE
    5240                    (dolist (name (cddr decl))
    5241                      (let ((variable (find-visible-variable name)))
    5242                        (when variable
    5243                          (setf (variable-declared-type variable) (cadr decl))
    5244                          (when (and (variable-register variable)
    5245                                     (not (variable-special-p variable))
    5246                                     (subtypep (variable-declared-type variable) 'FIXNUM))
    5247                            (setf (variable-representation variable) :unboxed-fixnum))))))))))))
    5248 
    5249       (dump-variables (reverse parameters)
    5250                       (%format nil "Arguments to ~A:~%" (compiland-name *current-compiland*))
    5251                       )
    5252 
    5253       (allocate-register) ;; "this" pointer
    5254       (if *using-arg-array*
    5255           ;; One slot for arg array.
    5256           (allocate-register)
    5257           ;; Otherwise, one register for each argument.
    5258           (dolist (arg args)
    5259             (allocate-register)))
    5260       (cond (*child-p*
    5261              (setf *context-register* (allocate-register))
    5262              (aver (eql *context-register* 2)))
    5263             (*use-locals-vector*
    5264              (aver *using-arg-array*)
    5265              (setf *context-register* 1)))
    5266       ;; Reserve the next available slot for the value register.
    5267       (setf *val* (allocate-register))
    5268       ;; Reserve the next available slot for the thread register.
    5269       (setf *thread* (allocate-register))
    5270 
    5271       ;; Establish dynamic bindings for any variables declared special.
    5272       (dolist (variable parameters)
    5273         (when (variable-special-p variable)
    5274           (cond ((variable-register variable)
    5275                  (emit-push-current-thread)
    5276                  (emit 'getstatic
    5277                        *this-class*
    5278                        (declare-symbol (variable-name variable))
    5279                        +lisp-symbol+)
    5280                  (emit 'aload (variable-register variable))
    5281                  (emit-invokevirtual +lisp-thread-class+
    5282                                      "bindSpecial"
    5283                                      "(Lorg/armedbear/lisp/Symbol;Lorg/armedbear/lisp/LispObject;)V"
    5284                                      -3)
    5285                  (setf (variable-register variable) nil))
    5286                 ((variable-index variable)
    5287                  (emit-push-current-thread)
    5288                  (emit 'getstatic
    5289                        *this-class*
    5290                        (declare-symbol (variable-name variable))
    5291                        +lisp-symbol+)
    5292                  (emit 'aload 1)
    5293                  (emit 'bipush (variable-index variable))
    5294                  (emit 'aaload)
    5295                  (emit-invokevirtual +lisp-thread-class+
    5296                                      "bindSpecial"
    5297                                      "(Lorg/armedbear/lisp/Symbol;Lorg/armedbear/lisp/LispObject;)V"
    5298                                      -3)
    5299                  (setf (variable-index variable) nil)))))
    5300 
    5301       (compile-progn-body body :stack)
    5302 
    5303       (unless *code*
    5304         (emit-push-nil))
    5305 
    5306       (emit 'areturn)
    5307 
    5308       (resolve-variables)
    5309 
    5310       ;; Go back and fill in prologue.
    5311       (let ((code *code*))
    5312         (setf *code* ())
    5313         (maybe-generate-arg-count-check)
    5314         (maybe-generate-interrupt-check)
    5315         (cond
    5316          ((or *hairy-arglist-p* *use-locals-vector*)
    5317           (emit 'aload_0) ; this
    5318           (emit 'aload_1) ; arg vector
    5319           ; Reserve extra slots for locals if applicable.
    5320           (let ((extra (if *use-locals-vector*
    5321                            (length (context-vars *context*))
    5322                            0)))
    5323             (emit 'sipush extra))
    5324           (emit-invokevirtual *this-class*
    5325                               (if (or (memq '&optional args) (memq '&key args))
    5326                                   "processArgs"
    5327                                   "fastProcessArgs")
    5328                               "([Lorg/armedbear/lisp/LispObject;I)[Lorg/armedbear/lisp/LispObject;"
    5329                               -2)
    5330           (emit 'astore_1))
    5331          ((not *using-arg-array*)
    5332           (dolist (variable (reverse *visible-variables*))
    5333             (when (eq (variable-representation variable) :unboxed-fixnum)
    5334               (emit 'aload (variable-register variable))
    5335               (emit-unbox-fixnum)
    5336               (emit 'istore (variable-register variable))))))
    5337 
    5338         (maybe-initialize-thread-var)
    5339         (setf *code* (append code *code*)))
    5340 
    5341       (finalize-code)
    5342       (optimize-code)
    5343 
    5344       (setf *code* (resolve-instructions *code*))
    5345       (setf (method-max-stack execute-method) (analyze-stack))
    5346       (setf (method-code execute-method) (code-bytes *code*))
    5347 
    5348       ;; Remove handler if its protected range is empty.
    5349       (setf *handlers*
    5350             (delete-if (lambda (handler) (eql (symbol-value (handler-from handler))
    5351                                               (symbol-value (handler-to handler))))
    5352                        *handlers*))
    5353 
    5354       (setf (method-max-locals execute-method) *registers-allocated*)
    5355       (setf (method-handlers execute-method) (nreverse *handlers*))
    5356       (write-class-file args body execute-method classfile)
    5357       classfile))
     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)))
     5251    (dolist (var (compiland-arg-vars compiland))
     5252      (push var *visible-variables*))
     5253
     5254    (dformat t "pass2 *visible-variables* ==> ~S~%"
     5255             (mapcar #'variable-name *visible-variables*))
     5256
     5257    (dformat t "pass2 *using-arg-array* = ~S~%" *using-arg-array*)
     5258    (dformat t "pass2 *use-locals-vector* = ~S~%" *use-locals-vector*)
     5259    (dformat t "pass2 *child-p* = ~S~%" *child-p*)
     5260    (dformat t "pass2 *nesting-level* = ~S~%" *nesting-level*)
     5261    (when (zerop *nesting-level*)
     5262      (setf *child-count* 0))
     5263    (setf *context* (make-context))
     5264    (setf (method-name-index execute-method)
     5265          (pool-name (method-name execute-method)))
     5266    (setf (method-descriptor-index execute-method)
     5267          (pool-name (method-descriptor execute-method)))
     5268    (cond (*hairy-arglist-p*
     5269           (let* ((closure (sys::make-closure p1-result nil))
     5270                  (vars (sys::varlist closure))
     5271                  (index 0))
     5272             (dolist (var vars)
     5273;;                (let ((variable (make-variable :name var
     5274;;                                               :special-p nil ;; FIXME
     5275;;                                               :register nil
     5276;;                                               :index index)))
     5277               (let ((variable (find-visible-variable var)))
     5278                 (when (null variable)
     5279                   (dformat t "unable to find variable ~S~%" var)
     5280                   (aver nil))
     5281                 (aver (null (variable-register variable)))
     5282                 (aver (null (variable-index variable)))
     5283                 (setf (variable-index variable) index)
     5284
     5285                 (push variable *all-variables*)
     5286;;                  (push variable *visible-variables*)
     5287                 (push variable parameters)
     5288                 (add-variable-to-context variable)
     5289                 (incf index)))))
     5290          (t
     5291           (let ((register 1)
     5292                 (index 0))
     5293             (dolist (arg args)
     5294               (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)))
     5299               (let ((variable (find-visible-variable arg)))
     5300                 (when (null variable)
     5301                   (dformat t "unable to find variable ~S~%" arg)
     5302                   (aver nil))
     5303                 (aver (null (variable-register variable)))
     5304                 (setf (variable-register variable) (if *using-arg-array* nil register))
     5305                 (aver (null (variable-index variable)))
     5306                 (setf (variable-index variable) index)
     5307
     5308                 (push variable *all-variables*)
     5309;;                  (push variable *visible-variables*)
     5310                 (push variable parameters)
     5311                 (add-variable-to-context variable)
     5312                 (incf register)
     5313                 (incf index))))))
     5314
     5315    (let ((specials (process-special-declarations body)))
     5316      (dolist (name specials)
     5317        (let ((variable (find-visible-variable name)))
     5318          (cond ((null variable)
     5319                 (setf variable (make-variable :name name
     5320                                               :special-p t))
     5321                 (push variable *all-variables*)
     5322                 (push variable *visible-variables*))
     5323                (t
     5324                 (setf (variable-special-p variable) t))))))
     5325
     5326    ;; Process type declarations.
     5327    (when *trust-user-type-declarations*
     5328      (unless (or *child-p*
     5329                  (plusp (compiland-children *current-compiland*)))
     5330        (dolist (subform body)
     5331          (unless (and (consp subform) (eq (car subform) 'DECLARE))
     5332            (return))
     5333          (let ((decls (cdr subform)))
     5334            (dolist (decl decls)
     5335              (case (car decl)
     5336                (TYPE
     5337                 (dolist (name (cddr decl))
     5338                   (let ((variable (find-visible-variable name)))
     5339                     (when variable
     5340                       (setf (variable-declared-type variable) (cadr decl))
     5341                       (when (and (variable-register variable)
     5342                                  (not (variable-special-p variable))
     5343                                  (subtypep (variable-declared-type variable) 'FIXNUM))
     5344                         (setf (variable-representation variable) :unboxed-fixnum))))))))))))
     5345
     5346    (dump-variables (reverse parameters)
     5347                    (%format nil "Arguments to ~A:~%" (compiland-name *current-compiland*))
     5348                    )
     5349
     5350    (allocate-register) ;; "this" pointer
     5351    (if *using-arg-array*
     5352        ;; One slot for arg array.
     5353        (allocate-register)
     5354        ;; Otherwise, one register for each argument.
     5355        (dolist (arg args)
     5356          (allocate-register)))
     5357    (cond (*child-p*
     5358           (setf *context-register* (allocate-register))
     5359           (aver (eql *context-register* 2)))
     5360          (*use-locals-vector*
     5361           (aver *using-arg-array*)
     5362           (setf *context-register* 1)))
     5363    ;; Reserve the next available slot for the value register.
     5364    (setf *val* (allocate-register))
     5365    ;; Reserve the next available slot for the thread register.
     5366    (setf *thread* (allocate-register))
     5367
     5368    ;; Establish dynamic bindings for any variables declared special.
     5369    (dolist (variable parameters)
     5370      (when (variable-special-p variable)
     5371        (cond ((variable-register variable)
     5372               (emit-push-current-thread)
     5373               (emit 'getstatic
     5374                     *this-class*
     5375                     (declare-symbol (variable-name variable))
     5376                     +lisp-symbol+)
     5377               (emit 'aload (variable-register variable))
     5378               (emit-invokevirtual +lisp-thread-class+
     5379                                   "bindSpecial"
     5380                                   "(Lorg/armedbear/lisp/Symbol;Lorg/armedbear/lisp/LispObject;)V"
     5381                                   -3)
     5382               (setf (variable-register variable) nil))
     5383              ((variable-index variable)
     5384               (emit-push-current-thread)
     5385               (emit 'getstatic
     5386                     *this-class*
     5387                     (declare-symbol (variable-name variable))
     5388                     +lisp-symbol+)
     5389               (emit 'aload 1)
     5390               (emit 'bipush (variable-index variable))
     5391               (emit 'aaload)
     5392               (emit-invokevirtual +lisp-thread-class+
     5393                                   "bindSpecial"
     5394                                   "(Lorg/armedbear/lisp/Symbol;Lorg/armedbear/lisp/LispObject;)V"
     5395                                   -3)
     5396               (setf (variable-index variable) nil)))))
     5397
     5398    (compile-progn-body body :stack)
     5399
     5400    (unless *code*
     5401      (emit-push-nil))
     5402
     5403    (emit 'areturn)
     5404
     5405    (resolve-variables)
     5406
     5407    ;; Go back and fill in prologue.
     5408    (let ((code *code*))
     5409      (setf *code* ())
     5410      (maybe-generate-arg-count-check)
     5411      (maybe-generate-interrupt-check)
     5412      (cond
     5413       ((or *hairy-arglist-p* *use-locals-vector*)
     5414        (dformat t "prologue case 1~%")
     5415        (emit 'aload_0) ; this
     5416        (emit 'aload_1) ; arg vector
     5417        ; Reserve extra slots for locals if applicable.
     5418        (let ((extra (if *use-locals-vector*
     5419                         (length (context-vars *context*))
     5420                         0)))
     5421          (emit 'sipush extra))
     5422        (emit-invokevirtual *this-class*
     5423                            (if (or (memq '&optional args) (memq '&key args))
     5424                                "processArgs"
     5425                                "fastProcessArgs")
     5426                            "([Lorg/armedbear/lisp/LispObject;I)[Lorg/armedbear/lisp/LispObject;"
     5427                            -2)
     5428        (emit 'astore_1))
     5429       ((not *using-arg-array*)
     5430        (dformat t "prologue case 2~%")
     5431        (dolist (variable (reverse *visible-variables*))
     5432          (when (eq (variable-representation variable) :unboxed-fixnum)
     5433            (emit 'aload (variable-register variable))
     5434            (emit-unbox-fixnum)
     5435            (emit 'istore (variable-register variable))))))
     5436
     5437      (maybe-initialize-thread-var)
     5438      (setf *code* (append code *code*)))
     5439
     5440    (finalize-code)
     5441    (optimize-code)
     5442
     5443    (setf *code* (resolve-instructions *code*))
     5444    (setf (method-max-stack execute-method) (analyze-stack))
     5445    (setf (method-code execute-method) (code-bytes *code*))
     5446
     5447    ;; Remove handler if its protected range is empty.
     5448    (setf *handlers*
     5449          (delete-if (lambda (handler) (eql (symbol-value (handler-from handler))
     5450                                            (symbol-value (handler-to handler))))
     5451                     *handlers*))
     5452
     5453    (setf (method-max-locals execute-method) *registers-allocated*)
     5454    (setf (method-handlers execute-method) (nreverse *handlers*))
     5455    (write-class-file args body execute-method classfile)
     5456    classfile))
    53585457
    53595458(defun compile-1 (compiland)
     
    55205619                             go
    55215620                             if
    5522                              labels
    55235621                             length
    55245622                             locally
    5525 ;;                              multiple-value-bind
    55265623                             multiple-value-call
    55275624                             multiple-value-list
     
    55495646(install-p2-handler 'eql    'p2-eql)
    55505647(install-p2-handler 'flet   'p2-flet)
     5648(install-p2-handler 'labels 'p2-labels)
    55515649(install-p2-handler 'logand 'p2-logand)
    55525650(install-p2-handler 'not    'compile-not/null)
Note: See TracChangeset for help on using the changeset viewer.