Changeset 8370


Ignore:
Timestamp:
01/19/05 13:02:29 (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

    r8368 r8370  
    22;;;
    33;;; Copyright (C) 2003-2005 Peter Graves
    4 ;;; $Id: jvm.lisp,v 1.355 2005-01-17 16:34:39 piso Exp $
     4;;; $Id: jvm.lisp,v 1.356 2005-01-19 13:02:29 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    406406    block))
    407407
     408(defun p1-unwind-protect (form)
     409  (let* ((block (make-block-node :name '(UNWIND-PROTECT)))
     410         (*blocks* (cons block *blocks*)))
     411    (setf (block-form block) (list* 'UNWIND-PROTECT (mapcar #'p1 (cdr form))))
     412    block))
     413
    408414(defun p1-return-from (form)
    409415  (let* ((name (second form))
    410          (result-form (third form))
    411416         (block (find-block name)))
    412     (cond ((null block)
    413            (error "P1-RETURN-FROM: no block named ~S is currently visible." name))
    414           ((eq (block-compiland block) *current-compiland*)
    415            (setf (block-return-p block) t))
     417    (when (null block)
     418      (error "P1-RETURN-FROM: no block named ~S is currently visible." name))
     419    (dformat t "p1-return-from block = ~S~%" (block-name block))
     420    (setf (block-return-p block) t)
     421    (cond ((eq (block-compiland block) *current-compiland*)
     422           ;; Local case. If the RETURN is nested inside an UNWIND-PROTECT
     423           ;; which is inside the block we're returning from, we'll do a non-
     424           ;; local return anyway so that UNWIND-PROTECT can catch it and run
     425           ;; its cleanup forms.
     426           (dformat t "*blocks* = ~S~%" (mapcar #'block-name *blocks*))
     427           (let ((protected
     428                  (dolist (enclosing-block *blocks*)
     429                    (when (eq enclosing-block block)
     430                      (return nil))
     431                    (when (equal (block-name enclosing-block) '(UNWIND-PROTECT))
     432                      (return t)))))
     433             (dformat t "p1-return-from protected = ~S~%" protected)
     434             (when protected
     435               (setf (block-non-local-return-p block) t))))
    416436          (t
    417            (setf (block-return-p block) t)
    418437           (setf (block-non-local-return-p block) t))))
    419438  (list* 'RETURN-FROM (cadr form) (mapcar #'p1 (cddr form))))
     
    715734(install-p1-handler 'the                  'p1-the)
    716735(install-p1-handler 'throw                'p1-throw)
    717 (install-p1-handler 'unwind-protect       'p1-default)
     736(install-p1-handler 'unwind-protect       'p1-unwind-protect)
    718737
    719738(defun dump-pool ()
     
    14541473                (representation (third instruction-args)))
    14551474           (aver (variable-p variable))
     1475           (dformat t "var-ref variable = ~S " (variable-name variable))
    14561476           (cond
    14571477            ((variable-register variable)
    1458              (dformat t "variable = ~S register = ~S~%"
    1459                       (variable-name variable)
    1460                       (variable-register variable))
     1478             (dformat t "register = ~S~%" (variable-register variable))
    14611479             (emit 'aload (variable-register variable))
    14621480             (emit-move-from-stack target))
    14631481            ((variable-special-p variable)
     1482             (dformat t "soecial~%")
    14641483             (compile-special-reference (variable-name variable) target nil))
    14651484            ((variable-closure-index variable)
    1466              (dformat t "variable = ~S closure-index = ~S~%"
    1467                       (variable-name variable) (variable-closure-index variable))
     1485             (dformat t "closure-index = ~S~%" (variable-closure-index variable))
    14681486             (aver (not (null (compiland-closure-register *current-compiland*))))
    14691487             (emit 'aload (compiland-closure-register *current-compiland*))
    1470              (emit 'bipush (variable-closure-index variable))
     1488             (emit-push-constant-int (variable-closure-index variable))
    14711489             (emit 'aaload)
    14721490             (emit-move-from-stack target))
    14731491            ((variable-index variable)
     1492             (dformat t "index = ~S~%" (variable-index variable))
    14741493             (aver (not (null (compiland-argument-register *current-compiland*))))
    14751494             (emit 'aload (compiland-argument-register *current-compiland*))
     
    14851504        (207 ; VAR-SET
    14861505         (let ((variable (car (instruction-args instruction))))
    1487            (dformat t "var-set var = ~S reg = ~S closure index = ~S~%"
    1488                     (variable-name variable)
    1489                     (variable-register variable)
    1490                     (variable-closure-index variable)
    1491                     )
     1506           (dformat t "var-set variable = ~S " (variable-name variable))
    14921507           (aver (variable-p variable))
    14931508           (aver (not (variable-special-p variable)))
    14941509           (cond ((variable-register variable)
     1510                  (dformat t "register = ~S~%" (variable-register variable))
    14951511                  (emit 'astore (variable-register variable)))
    14961512                 ((variable-closure-index variable)
    1497                   (dformat t "variable = ~S closure-index = ~S~%"
    1498                            (variable-name variable) (variable-closure-index variable))
     1513                  (dformat t "closure-index = ~S~%" (variable-closure-index variable))
    14991514                  (aver (not (null (compiland-closure-register *current-compiland*))))
    15001515                  (emit 'aload (compiland-closure-register *current-compiland*))
     
    27752790  (emit-move-from-stack target))
    27762791
     2792(defun save-variables (variables)
     2793  (let ((saved-vars '()))
     2794    (dolist (variable variables)
     2795      (when (variable-closure-index variable)
     2796        (let ((register (allocate-register)))
     2797          (emit 'aload (compiland-closure-register *current-compiland*))
     2798          (emit-push-constant-int (variable-closure-index variable))
     2799          (emit 'aaload)
     2800          (emit 'astore register)
     2801          (push (cons variable register) saved-vars))))
     2802    saved-vars))
     2803
     2804(defun restore-variables (saved-vars)
     2805  (dolist (saved-var saved-vars)
     2806    (let ((variable (car saved-var))
     2807          (register (cdr saved-var)))
     2808      (emit 'aload (compiland-closure-register *current-compiland*))
     2809      (emit-push-constant-int (variable-closure-index variable))
     2810      (emit 'aload register)
     2811      (emit 'aastore))))
     2812
    27772813(defun compile-local-function-call (form target)
    2778   (dformat t "compile-local-function-call~%")
    27792814  (let* ((op (car form))
    27802815         (args (cdr form))
    2781          (local-function (find-local-function op)))
     2816         (local-function (find-local-function op))
     2817         (*register* *register*)
     2818         (saved-vars '()))
    27822819    (cond
    27832820     ((eq (local-function-compiland local-function) *current-compiland*)
     2821      ;; Recursive call.
     2822      (dformat t "compile-local-function-call recursive case~%")
     2823      (setf saved-vars
     2824            (save-variables (compiland-arg-vars (local-function-compiland local-function))))
    27842825      (emit 'aload_0))
    27852826     ((local-function-variable local-function)
    27862827      ;; LABELS
    27872828      (dformat t "compile-local-function-call LABELS case~%")
     2829      (dformat t "save args here: ~S~%"
     2830               (mapcar #'variable-name
     2831                       (compiland-arg-vars (local-function-compiland local-function))))
     2832      (setf saved-vars
     2833            (save-variables (compiland-arg-vars (local-function-compiland local-function))))
    27882834      (emit 'var-ref (local-function-variable local-function) :stack))
    27892835     (t
     2836      (dformat t "compile-local-function-call default case~%")
    27902837      (let* ((g (if *compile-file-truename*
    27912838                    (declare-local-function local-function)
     
    29022949          (t
    29032950           (%format t "line 1876~%")
    2904            (aver nil)))))
     2951           (aver nil)))
     2952    (when saved-vars
     2953      (restore-variables saved-vars))))
    29052954
    29062955(defparameter java-predicates (make-hash-table :test 'eq))
     
    37643813                                :name (cadr form)
    37653814                                :target target)))
    3766     (compile-block-node block target)
     3815    (p2-block-node block target)
    37673816  ))
    37683817
    3769 (defun compile-block-node (block target)
    3770 ;;   (dformat t "COMPILE-BLOCK-NODE ~S block-return-p = ~S~%"
    3771 ;;            (block-name block) (block-return-p block))
     3818(defun p2-block-node (block target)
    37723819  (unless (block-node-p block)
    37733820    (%format t "type-of block = ~S~%" (type-of block))
     
    38263873         (result-form (third form))
    38273874         (block (find-block name)))
    3828     (cond
    3829      ((null block)
     3875    (when (null block)
    38303876      (error "No block named ~S is currently visible." name))
    3831      ((eq (block-compiland block) *current-compiland*)
     3877
     3878    (dformat t "p2-return-from block = ~S~%" (block-name block))
     3879
     3880    (when (eq (block-compiland block) *current-compiland*)
     3881      (dformat t "p2-return-from *blocks* = ~S~%" (mapcar #'block-name *blocks*))
    38323882      ;; Local case. Is the RETURN nested inside an UNWIND-PROTECT which
    38333883      ;; is inside the block we're returning from?
     
    38383888               (when (equal (block-name enclosing-block) '(UNWIND-PROTECT))
    38393889                 (return t)))))
    3840         (when protected
    3841           (error "COMPILE-RETURN-FROM: enclosing UNWIND-PROTECT")))
    3842       (emit-clear-values)
    3843       (compile-form result-form :target (block-target block))
    3844       (emit 'goto (block-exit block)))
    3845      (t
    3846       ;; Non-local RETURN.
    3847       (setf (block-non-local-return-p block) t)
    3848       (cond ((node-constant-p result-form)
     3890        (dformat t "p2-return-from protected = ~S~%" protected)
     3891        (unless protected
     3892          (emit-clear-values)
     3893          (compile-form result-form :target (block-target block))
     3894          (emit 'goto (block-exit block))
     3895          (return-from p2-return-from))))
     3896
     3897    ;; Non-local RETURN.
     3898    (aver (block-non-local-return-p block))
     3899    (cond ((node-constant-p result-form)
     3900           (emit 'new +lisp-return-class+)
     3901           (emit 'dup)
     3902           (compile-form `',(block-catch-tag block) :target :stack) ; Tag.
     3903           (emit-clear-values)
     3904           (compile-form result-form :target :stack)) ; Result.
     3905          (t
     3906           (let* ((*register* *register*)
     3907                  (temp-register (allocate-register)))
     3908             (emit-clear-values)
     3909             (compile-form result-form :target temp-register) ; Result.
    38493910             (emit 'new +lisp-return-class+)
    38503911             (emit 'dup)
    38513912             (compile-form `',(block-catch-tag block) :target :stack) ; Tag.
    3852              (emit-clear-values)
    3853              (compile-form result-form :target :stack)) ; Result.
    3854             (t
    3855              (let* ((*register* *register*)
    3856                     (temp-register (allocate-register)))
    3857                (emit-clear-values)
    3858                (compile-form result-form :target temp-register) ; Result.
    3859                (emit 'new +lisp-return-class+)
    3860                (emit 'dup)
    3861                (compile-form `',(block-catch-tag block) :target :stack) ; Tag.
    3862                (emit 'aload temp-register))))
    3863       (emit-invokespecial +lisp-return-class+
    3864                           "<init>"
    3865                           "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)V"
    3866                           -3)
    3867       (emit 'athrow)
    3868       ;; Following code will not be reached, but is needed for JVM stack
    3869       ;; consistency.
    3870       (when target
    3871         (emit-push-nil)
    3872         (emit-move-from-stack target))))))
     3913             (emit 'aload temp-register))))
     3914    (emit-invokespecial +lisp-return-class+
     3915                        "<init>"
     3916                        "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)V"
     3917                        -3)
     3918    (emit 'athrow)
     3919    ;; Following code will not be reached, but is needed for JVM stack
     3920    ;; consistency.
     3921    (when target
     3922      (emit-push-nil)
     3923      (emit-move-from-stack target))))
    38733924
    38743925(defun compile-cons (form &key (target *val*) representation)
     
    49735024    (emit-move-from-stack target)))
    49745025
    4975 (defun compile-unwind-protect (form &key (target *val*) representation)
    4976   (when (= (length form) 2) ; (unwind-protect 42)
    4977     (compile-form (second form) :target target)
    4978     (return-from compile-unwind-protect))
    4979   (let* ((protected-form (cadr form))
    4980          (cleanup-forms (cddr form))
    4981          (*register* *register*)
    4982          (exception-register (allocate-register))
    4983          (result-register (allocate-register))
    4984          (values-register (allocate-register))
    4985          (return-address-register (allocate-register))
    4986          (BEGIN-PROTECTED-RANGE (gensym))
    4987          (END-PROTECTED-RANGE (gensym))
    4988          (HANDLER (gensym))
    4989          (EXIT (gensym))
    4990          (CLEANUP (gensym)))
    4991 ;;     (when (contains-return protected-form)
    4992 ;;       (error "COMPILE-UNWIND-PROTECT: unhandled case (RETURN)"))
    4993 ;;     (when (contains-go protected-form)
    4994 ;;       (error "COMPILE-UNWIND-PROTECT: unhandled case (GO)"))
    4995 
    4996     ;; Added Dec 9 2004 3:46 AM
    4997     ;; Make sure there are no leftover values from previous calls.
    4998     (emit-clear-values)
    4999 
    5000     (let* ((block (make-block-node :name '(UNWIND-PROTECT)))
    5001            (*blocks* (cons block *blocks*)))
    5002       (label BEGIN-PROTECTED-RANGE)
    5003       (compile-form protected-form :target result-register)
     5026(defun p2-unwind-protect-node (block target)
     5027  (let ((form (block-form block)))
     5028    (when (= (length form) 2) ; No cleanup form.
     5029      (compile-form (second form) :target target)
     5030      (return-from p2-unwind-protect-node))
     5031    (let* ((protected-form (cadr form))
     5032           (cleanup-forms (cddr form))
     5033           (*register* *register*)
     5034           (exception-register (allocate-register))
     5035           (result-register (allocate-register))
     5036           (values-register (allocate-register))
     5037           (return-address-register (allocate-register))
     5038           (BEGIN-PROTECTED-RANGE (gensym))
     5039           (END-PROTECTED-RANGE (gensym))
     5040           (HANDLER (gensym))
     5041           (EXIT (gensym))
     5042           (CLEANUP (gensym)))
     5043      ;; Make sure there are no leftover multiple return values from previous calls.
     5044      (emit-clear-values)
     5045
     5046      (let* ((*blocks* (cons block *blocks*)))
     5047        (label BEGIN-PROTECTED-RANGE)
     5048        (compile-form protected-form :target result-register)
     5049        (emit-push-current-thread)
     5050        (emit 'getfield +lisp-thread-class+ "_values" "[Lorg/armedbear/lisp/LispObject;")
     5051        (emit 'astore values-register)
     5052        (label END-PROTECTED-RANGE))
     5053      (emit 'jsr CLEANUP)
     5054      (emit 'goto EXIT) ; Jump over handler.
     5055      (label HANDLER) ; Start of exception handler.
     5056      ;; The Throwable object is on the runtime stack. Stack depth is 1.
     5057      (emit 'astore exception-register)
     5058      (emit 'jsr CLEANUP) ; Call cleanup forms.
     5059      (emit-clear-values)
     5060      (emit 'aload exception-register)
     5061      (emit 'athrow) ; Re-throw exception.
     5062      (label CLEANUP) ; Cleanup forms.
     5063      ;; Return address is on stack here.
     5064      (emit 'astore return-address-register)
     5065      (dolist (subform cleanup-forms)
     5066        (compile-form subform :target nil))
     5067      (emit 'ret return-address-register)
     5068      (label EXIT)
     5069      ;; Restore multiple values returned by protected form.
    50045070      (emit-push-current-thread)
    5005       (emit 'getfield +lisp-thread-class+ "_values" "[Lorg/armedbear/lisp/LispObject;")
    5006       (emit 'astore values-register)
    5007       (label END-PROTECTED-RANGE))
    5008     (emit 'jsr CLEANUP)
    5009     (emit 'goto EXIT) ; Jump over handler.
    5010     (label HANDLER) ; Start of exception handler.
    5011     ;; The Throw object is on the runtime stack. Stack depth is 1.
    5012     (emit 'astore exception-register)
    5013     (emit 'jsr CLEANUP) ; Call cleanup forms.
    5014     (emit-clear-values)
    5015     (emit 'aload exception-register)
    5016     (emit 'athrow) ; Re-throw exception.
    5017     (label CLEANUP) ; Cleanup forms.
    5018     ;; Return address is on stack here.
    5019     (emit 'astore return-address-register)
    5020     (dolist (subform cleanup-forms)
    5021       (compile-form subform :target nil))
    5022     (emit 'ret return-address-register)
    5023     (label EXIT)
    5024     ;; Restore multiple values returned by protected form.
    5025     (emit-push-current-thread)
    5026     (emit 'aload values-register)
    5027     (emit 'putfield +lisp-thread-class+ "_values" "[Lorg/armedbear/lisp/LispObject;")
    5028     ;; Result.
    5029     (emit 'aload result-register)
    5030     (emit-move-from-stack target)
    5031     (let ((handler (make-handler :from BEGIN-PROTECTED-RANGE
    5032                                  :to END-PROTECTED-RANGE
    5033                                  :code HANDLER
    5034                                  :catch-type 0)))
    5035       (push handler *handlers*))))
     5071      (emit 'aload values-register)
     5072      (emit 'putfield +lisp-thread-class+ "_values" "[Lorg/armedbear/lisp/LispObject;")
     5073      ;; Result.
     5074      (emit 'aload result-register)
     5075      (emit-move-from-stack target)
     5076      (let ((handler (make-handler :from BEGIN-PROTECTED-RANGE
     5077                                   :to END-PROTECTED-RANGE
     5078                                   :code HANDLER
     5079                                   :catch-type 0)))
     5080        (push handler *handlers*)))))
    50365081
    50375082(defun compile-form (form &key (target *val*) representation)
     
    50895134               ((equal (block-name form) '(MULTIPLE-VALUE-BIND))
    50905135                (p2-m-v-b-node form target))
     5136               ((equal (block-name form) '(UNWIND-PROTECT))
     5137                (p2-unwind-protect-node form target))
    50915138               (t
    5092                 (compile-block-node form target))))
     5139                (p2-block-node form target))))
    50935140        ((constantp form)
    50945141;;          (dformat t "compile-form constantp case~%")
     
    52775324         (*registers-allocated* 0)
    52785325         (*handlers* ())
    5279 
    5280 ;;          (*context* *context*)
    5281 
    52825326         (*visible-variables* *visible-variables*)
    52835327         (*undefined-variables* *undefined-variables*)
     
    53215365                 (setf (variable-index variable) index)
    53225366                 (push variable parameters)
    5323 ;;                  (add-variable-to-context variable)
    53245367                 (incf index)))))
    53255368          (t
     
    54025445               #+nil (some #'variable-closure-index parameters)
    54035446               )
    5404       (dformat t "moving arguments to closure array (if applicable)~%")
     5447      (dformat t "~S moving arguments to closure array (if applicable)~%"
     5448               (compiland-name compiland))
    54055449      (cond (*child-p*
    54065450             (aver (eql (compiland-closure-register compiland) 1))
     
    54465490               (emit 'pop)))
    54475491            (t
    5448              (emit 'astore (compiland-closure-register compiland)))))
     5492             (emit 'astore (compiland-closure-register compiland))))
     5493      (dformat t "~S done moving arguments to closure array~%"
     5494               (compiland-name compiland))
     5495      )
    54495496
    54505497    ;; Establish dynamic bindings for any variables declared special.
     
    57565803                             setq
    57575804                             throw
    5758                              unwind-protect
    57595805                             values))
    57605806
    5761 (install-p2-handler '<           'p2-numeric-comparison)
    5762 (install-p2-handler '<=          'p2-numeric-comparison)
    5763 (install-p2-handler '>           'p2-numeric-comparison)
    5764 (install-p2-handler '>=          'p2-numeric-comparison)
    5765 (install-p2-handler '=           'p2-numeric-comparison)
    5766 (install-p2-handler '/=          'p2-numeric-comparison)
    5767 (install-p2-handler '+           'compile-plus)
    5768 (install-p2-handler '-           'compile-minus)
    5769 (install-p2-handler 'ash         'p2-ash)
    5770 (install-p2-handler 'eql         'p2-eql)
    5771 (install-p2-handler 'flet        'p2-flet)
    5772 (install-p2-handler 'function    'p2-function)
    5773 (install-p2-handler 'labels      'p2-labels)
    5774 (install-p2-handler 'logand      'p2-logand)
    5775 (install-p2-handler 'not         'compile-not/null)
    5776 (install-p2-handler 'null        'compile-not/null)
    5777 (install-p2-handler 'return-from 'p2-return-from)
    5778 (install-p2-handler 'the         'p2-the)
     5807(install-p2-handler '<              'p2-numeric-comparison)
     5808(install-p2-handler '<=             'p2-numeric-comparison)
     5809(install-p2-handler '>              'p2-numeric-comparison)
     5810(install-p2-handler '>=             'p2-numeric-comparison)
     5811(install-p2-handler '=              'p2-numeric-comparison)
     5812(install-p2-handler '/=             'p2-numeric-comparison)
     5813(install-p2-handler '+              'compile-plus)
     5814(install-p2-handler '-              'compile-minus)
     5815(install-p2-handler 'ash            'p2-ash)
     5816(install-p2-handler 'eql            'p2-eql)
     5817(install-p2-handler 'flet           'p2-flet)
     5818(install-p2-handler 'function       'p2-function)
     5819(install-p2-handler 'labels         'p2-labels)
     5820(install-p2-handler 'logand         'p2-logand)
     5821(install-p2-handler 'not            'compile-not/null)
     5822(install-p2-handler 'null           'compile-not/null)
     5823(install-p2-handler 'return-from    'p2-return-from)
     5824(install-p2-handler 'the            'p2-the)
     5825;; (install-p2-handler 'unwind-protect 'p2-unwind-protect)
    57795826
    57805827(defun process-optimization-declarations (forms)
Note: See TracChangeset for help on using the changeset viewer.