Changeset 13122


Ignore:
Timestamp:
01/03/11 20:30:12 (11 years ago)
Author:
ehuelsmann
Message:

Remove REWRITE-RETURN-FROM, REWRITE-PROGV and REWRITE-THROW
in favor of unsafety detection in compilation pass2.

Location:
branches/unsafe-p-removal/abcl/src/org/armedbear/lisp
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp

    r13118 r13122  
    469469  (let* ((*visible-variables* *visible-variables*)
    470470         (block (make-let/let*-node))
     471   (*block* block)
    471472         (op (%car form))
    472473         (varlist (cadr form))
     
    507508  (let* ((*visible-variables* *visible-variables*)
    508509         (block (make-locally-node))
     510   (*block* block)
    509511         (free-specials (process-declarations-for-vars (cdr form) nil block)))
    510512    (setf (locally-free-specials block) free-specials)
     
    524526  (let* ((*visible-variables* *visible-variables*)
    525527         (block (make-m-v-b-node))
     528   (*block* block)
    526529         (varlist (cadr form))
    527530         ;; Process the values-form first. ("The scopes of the name binding and
     
    553556(defun p1-block (form)
    554557  (let* ((block (make-block-node (cadr form)))
     558   (*block* block)
    555559         (*blocks* (cons block *blocks*)))
    556560    (setf (cddr form) (p1-body (cddr form)))
     
    569573         (body (cddr form))
    570574         (block (make-catch-node))
     575   (*block* block)
    571576         ;; our subform processors need to know
    572577         ;; they're enclosed in a CATCH block
     
    592597         (body (cddr form))
    593598         (block (make-synchronized-node))
     599   (*block* block)
    594600         (*blocks* (cons block *blocks*))
    595601         result)
     
    615621      ;; need to copy the forms to create a second copy.
    616622      (let* ((block (make-unwind-protect-node))
     623       (*block* block)
    617624             ;; a bit of jumping through hoops...
    618625             (unwinding-forms (p1-body (copy-tree (cddr form))))
     
    630637(defknown p1-return-from (t) t)
    631638(defun p1-return-from (form)
    632   (let ((new-form (rewrite-return-from form)))
    633     (when (neq form new-form)
    634       (return-from p1-return-from (p1 new-form))))
    635639  (let* ((name (second form))
    636640         (block (find-block name)))
     
    662666(defun p1-tagbody (form)
    663667  (let* ((block (make-tagbody-node))
     668   (*block* block)
    664669         (*blocks* (cons block *blocks*))
    665670         (*visible-tags* *visible-tags*)
     
    928933   (process-optimization-declarations (cddr form))
    929934   (let* ((block (make-flet-node))
     935    (*block* block)
    930936    (*blocks* (cons block *blocks*))
    931937    (body (cddr form))
     
    966972     (p1-compiland (local-function-compiland local-function))))
    967973       (let* ((block (make-labels-node))
     974        (*block* block)
    968975              (*blocks* (cons block *blocks*))
    969976              (body (cddr form))
     
    10691076(defun p1-progv (form)
    10701077  ;; We've already checked argument count in PRECOMPILE-PROGV.
    1071 
    1072   (let ((new-form (rewrite-progv form)))
    1073     (when (neq new-form form)
    1074       (return-from p1-progv (p1 new-form))))
    10751078  (let* ((symbols-form (p1 (cadr form)))
    10761079         (values-form (p1 (caddr form)))
    10771080         (block (make-progv-node))
     1081   (*block* block)
    10781082         (*blocks* (cons block *blocks*))
    10791083         (body (cdddr form)))
     
    10901094          `(progv ,symbols-form ,values-form ,@(p1-body body)))
    10911095    block))
    1092 
    1093 (defknown rewrite-progv (t) t)
    1094 (defun rewrite-progv (form)
    1095   (let ((symbols-form (cadr form))
    1096         (values-form (caddr form))
    1097         (body (cdddr form)))
    1098     (cond ((or (unsafe-p symbols-form) (unsafe-p values-form))
    1099            (let ((g1 (gensym))
    1100                  (g2 (gensym)))
    1101              `(let ((,g1 ,symbols-form)
    1102                     (,g2 ,values-form))
    1103                 (progv ,g1 ,g2 ,@body))))
    1104           (t
    1105            form))))
    11061096
    11071097(defun p1-quote (form)
     
    11981188                (return t))))))))
    11991189
    1200 (defknown rewrite-return-from (t) t)
    1201 (defun rewrite-return-from (form)
    1202   (let* ((args (cdr form))
    1203          (result-form (second args))
    1204          (var (gensym)))
    1205     (if (unsafe-p (cdr args))
    1206         (if (single-valued-p result-form)
    1207             `(let ((,var ,result-form))
    1208                (return-from ,(first args) ,var))
    1209             `(let ((,var (multiple-value-list ,result-form)))
    1210                (return-from ,(first args) (values-list ,var))))
    1211         form)))
    1212 
    1213 
    1214 (defknown rewrite-throw (t) t)
    1215 (defun rewrite-throw (form)
    1216   (let ((args (cdr form)))
    1217     (if (unsafe-p args)
    1218         (let ((syms ())
    1219               (lets ()))
    1220           ;; Tag.
    1221           (let ((arg (first args)))
    1222             (if (constantp arg)
    1223                 (push arg syms)
    1224                 (let ((sym (gensym)))
    1225                   (push sym syms)
    1226                   (push (list sym arg) lets))))
    1227           ;; Result. "If the result-form produces multiple values, then all the
    1228           ;; values are saved."
    1229           (let ((arg (second args)))
    1230             (if (constantp arg)
    1231                 (push arg syms)
    1232                 (let ((sym (gensym)))
    1233                   (cond ((single-valued-p arg)
    1234                          (push sym syms)
    1235                          (push (list sym arg) lets))
    1236                         (t
    1237                          (push (list 'VALUES-LIST sym) syms)
    1238                          (push (list sym
    1239                                      (list 'MULTIPLE-VALUE-LIST arg))
    1240                                lets))))))
    1241           (list 'LET* (nreverse lets) (list* 'THROW (nreverse syms))))
    1242         form)))
    1243 
    12441190(defknown p1-throw (t) t)
    12451191(defun p1-throw (form)
    1246   (let ((new-form (rewrite-throw form)))
    1247     (when (neq new-form form)
    1248       (return-from p1-throw (p1 new-form))))
    12491192  (list* 'THROW (mapcar #'p1 (cdr form))))
    12501193
  • branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

    r13116 r13122  
    645645            collecting form)))
    646646    (apply #'maybe-emit-clear-values forms-for-emit-clear)))
     647
     648
     649(declaim (special *saved-operands* *operand-representations*))
     650(defmacro with-operand-accumulation ((&body argument-buildup-body)
     651             &body funcall-body)
     652  `(let (*saved-operands*
     653   *operand-representations*
     654   (*register* *register*)) ;; hmm can we do this?? either body
     655                                  ;; could allocate registers ...
     656     ,@argument-buildup-body
     657     (load-saved-operands)
     658     ,@funcall-body))
     659
     660(defun load-saved-operands ()
     661  "Load any operands which have been saved into registers
     662back onto the stack in preparation of the execution of the opcode."
     663  (dolist (operand (reverse *saved-operands*))
     664    (emit 'aload operand)))
     665
     666(defun save-existing-operands ()
     667  "If any operands have been compiled to the stack,
     668save them in registers."
     669  (dotimes (i (length *operand-representations*))
     670    (let ((register (allocate-register)))
     671      (push register *saved-operands*)
     672      (emit 'astore register)))
     673
     674  (setf *saved-operands* (nreverse *saved-operands*)))
     675
     676(defun compile-operand (form representation)
     677  "Compiles `form` into `representation`, storing the resulting value
     678on the operand stack, if it's safe to do so. Otherwise stores the value
     679in a register"
     680  (let ((unsafe (or *saved-operands*
     681        (some-nested-block #'block-opstack-unsafe-p
     682               (find-enclosed-blocks form)))))
     683    (when (and unsafe (null *saved-operands*))
     684      (save-existing-operands))
     685   
     686    (compile-form form 'stack representation)
     687    (when unsafe
     688      (let ((register (allocate-register)))
     689  (push register *saved-operands*)
     690  (assert (null representation))
     691  (emit 'astore register)))
     692   
     693  (push representation *operand-representations*)))
     694
     695(defun emit-variable-operand (variable)
     696  "Pushes a variable onto the operand stack, if it's safe to do so. Otherwise
     697stores the value in a register."
     698  (push (variable-representation variable) *operand-representations*)
     699  (cond
     700   ((and *saved-operands*
     701   (variable-register variable))
     702    ;; we're in 'safe mode' and the  variable is in a register,
     703    ;; instead of binding a new register, just load the existing one
     704    (push (variable-register variable) *saved-operands*))
     705   (t
     706    (emit-push-variable variable)
     707    (when *saved-operands* ;; safe-mode
     708      (let ((register (allocate-register)))
     709  (push register *saved-operands*)
     710  (assert (null (variable-representation variable)))
     711  (emit 'astore register))))))
     712
     713(defun emit-thread-operand ()
     714  (push nil *operand-representations*)
     715  (emit-push-current-thread)
     716  (when *saved-operands*
     717    (let ((register (allocate-register)))
     718  (push register *saved-operands*)
     719  (emit 'astore register))))
     720 
     721
     722(defun emit-load-externalized-object-operand (object)
     723  (push nil *operand-representations*)
     724  (emit-load-externalized-object object)
     725  (when *saved-operands* ;; safe-mode
     726    (let ((register (allocate-register)))
     727  (push register *saved-operands*)
     728  (emit 'astore register))))
    647729
    648730(defknown emit-unbox-fixnum () t)
     
    36523734    ;; Non-local RETURN.
    36533735    (aver (block-non-local-return-p block))
    3654     (emit-push-variable (block-id-variable block))
    3655     (emit-load-externalized-object (block-name block))
    36563736    (emit-clear-values)
    3657     (compile-form result-form 'stack nil)
    3658     (emit-invokestatic +lisp+ "nonLocalReturn" (lisp-object-arg-types 3)
    3659                        +lisp-object+)
     3737    (with-operand-accumulation
     3738         ((emit-variable-operand (block-id-variable block))
     3739    (emit-load-externalized-object-operand (block-name block))
     3740    (compile-operand result-form nil))
     3741       (emit-invokestatic +lisp+ "nonLocalReturn" (lisp-object-arg-types 3)
     3742        +lisp-object+))
    36603743    ;; Following code will not be reached, but is needed for JVM stack
    36613744    ;; consistency.
     
    37243807          (setf (progv-environment-register block) (allocate-register)))
    37253808         (label-START (gensym)))
    3726     (compile-form symbols-form 'stack nil)
    3727     (compile-form values-form 'stack nil)
    3728     (unless (and (single-valued-p symbols-form)
    3729                  (single-valued-p values-form))
    3730       (emit-clear-values))
    3731     (save-dynamic-environment environment-register)
    3732     (label label-START)
    3733     ;; Compile call to Lisp.progvBindVars().
    3734     (emit-push-current-thread)
    3735     (emit-invokestatic +lisp+ "progvBindVars"
    3736                        (list +lisp-object+ +lisp-object+ +lisp-thread+) nil)
     3809    (with-operand-accumulation
     3810        ((compile-operand symbols-form nil)
     3811   (compile-operand values-form nil))
     3812      (unless (and (single-valued-p symbols-form)
     3813       (single-valued-p values-form))
     3814  (emit-clear-values))
     3815      (save-dynamic-environment environment-register)
     3816      (label label-START)
     3817      ;; Compile call to Lisp.progvBindVars().
     3818      (emit-push-current-thread)
     3819      (emit-invokestatic +lisp+ "progvBindVars"
     3820       (list +lisp-object+ +lisp-object+ +lisp-thread+) nil))
    37373821      ;; Implicit PROGN.
    37383822    (let ((*blocks* (cons block *blocks*)))
     
    65006584  ;; FIXME What if we're called with a non-NIL representation?
    65016585  (declare (ignore representation))
    6502   (emit-push-current-thread)
    6503   (compile-form (second form) 'stack nil) ; Tag.
    6504   (emit-clear-values) ; Do this unconditionally! (MISC.503)
    6505   (compile-form (third form) 'stack nil) ; Result.
    6506   (emit-invokevirtual +lisp-thread+ "throwToTag"
    6507                       (lisp-object-arg-types 2) nil)
     6586  (with-operand-accumulation
     6587      ((emit-thread-operand)
     6588       (compile-operand (second form) nil) ; Tag.
     6589       (emit-clear-values) ; Do this unconditionally! (MISC.503)
     6590       (compile-operand (third form) nil)) ; Result.
     6591    (emit-invokevirtual +lisp-thread+ "throwToTag"
     6592       (lisp-object-arg-types 2) nil))
    65086593  ;; Following code will not be reached.
    65096594  (when target
Note: See TracChangeset for help on using the changeset viewer.