Changeset 13161


Ignore:
Timestamp:
01/20/11 13:31:13 (11 years ago)
Author:
ehuelsmann
Message:

Final UNSAFE-P removal.

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

    r13160 r13161  
    11511151  (list 'TRULY-THE (%cadr form) (p1 (%caddr form))))
    11521152
    1153 (defvar *pass2-unsafe-p-special-treatment-functions*
    1154   '(
    1155      logand
    1156      logior
    1157      lognot
    1158      logxor
    1159 )
    1160 "The functions named in the list bound to this variable
    1161 need to be rewritten if UNSAFE-P returns non-NIL for their
    1162 argument list.
    1163 
    1164 All other function calls are handled by generic function calling
    1165 in pass2, which accounts for OPSTACK unsafety itself.")
    1166 
    1167 
    1168 
    1169 
    1170 (defknown unsafe-p (t) t)
    1171 (defun unsafe-p (args)
    1172   "Determines whether the args can cause 'stack unsafe situations'.
    1173 Returns T if this is the case.
    1174 
    1175 When a 'stack unsafe situation' is encountered, the stack cannot
    1176 be used for temporary storage of intermediary results. This happens
    1177 because one of the forms in ARGS causes a local transfer of control
    1178 - local GO instruction - which assumes an empty stack, or if one of
    1179 the args causes a Java exception handler to be installed, which
    1180 - when triggered - clears out the stack.
    1181 "
    1182   (cond ((node-p args)
    1183          (unsafe-p (node-form args)))
    1184         ((atom args)
    1185          nil)
    1186         (t
    1187          (case (%car args)
    1188            (QUOTE
    1189             nil)
    1190 ;;           (LAMBDA
    1191 ;;            nil)
    1192            ((RETURN-FROM GO CATCH THROW UNWIND-PROTECT BLOCK)
    1193             t)
    1194            (t
    1195             (dolist (arg args)
    1196               (when (unsafe-p arg)
    1197                 (return t))))))))
    1198 
    11991153(defknown p1-throw (t) t)
    12001154(defun p1-throw (form)
     
    12081162       ;;(funcall (lambda (...) ...) ...)
    12091163       (let ((op (car args)) (args (cdr args)))
    1210   (expand-function-call-inline form (cadr op) (copy-tree (cddr op))
    1211               args)))
     1164        (expand-function-call-inline form (cadr op) (copy-tree (cddr op))
     1165                                      args)))
    12121166      ((and (listp op) (eq (car op) 'lambda))
    12131167       ;;((lambda (...) ...) ...)
    12141168       (expand-function-call-inline form (cadr op) (copy-tree (cddr op)) args))
    1215       (t (if (and (member op *pass2-unsafe-p-special-treatment-functions*)
    1216                   (unsafe-p args))
    1217        (let ((arg1 (car args)))
    1218          (cond ((and (consp arg1) (eq (car arg1) 'GO))
    1219           arg1)
    1220          (t
    1221           (let ((syms ())
    1222           (lets ()))
    1223       ;; Preserve the order of evaluation of the arguments!
    1224       (dolist (arg args)
    1225         (cond ((and (constantp arg)
    1226                                       (not (node-p arg)))
    1227          (push arg syms))
    1228         ((and (consp arg) (eq (car arg) 'GO))
    1229          (return-from rewrite-function-call
    1230            (list 'LET* (nreverse lets) arg)))
    1231         (t
    1232          (let ((sym (gensym)))
    1233            (push sym syms)
    1234            (push (list sym arg) lets)))))
    1235       (list 'LET* (nreverse lets)
    1236             (list* (car form) (nreverse syms)))))))
    1237        form)))))
     1169      (t form))))
    12381170
    12391171(defknown p1-function-call (t) t)
  • branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

    r13160 r13161  
    44384438                                                           arg2 target representation))
    44394439               ((eql (fixnum-constant-value type2) -1)
    4440                 (compile-forms-and-maybe-emit-clear-values arg1 target representation
    4441                                                            arg2 nil nil))
     4440                (let ((target-register
     4441                       (if (or (not (eq target 'stack))
     4442                               (not (some-nested-block #'node-opstack-unsafe-p
     4443                                               (find-enclosed-blocks arg2))))
     4444                           target
     4445                         (allocate-register representation))))
     4446                  (compile-form arg1 target-register representation)
     4447                  (compile-form arg2 nil nil)
     4448                  (when (and (eq target 'stack)
     4449                             (not (eq target-register 'stack)))
     4450                    (emit-push-register target-register))
     4451                  (maybe-emit-clear-values arg1 arg2)))
    44424452               ((and (fixnum-type-p type1) (fixnum-type-p type2))
    44434453                ;; Both arguments are fixnums.
    4444                 (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    4445                                                            arg2 'stack :int)
     4454                (with-operand-accumulation
     4455                    ((compile-operand arg1 :int)
     4456                     (compile-operand arg2 :int)
     4457                     (maybe-emit-clear-values arg1 arg2)))
    44464458                (emit 'iand)
    44474459                (convert-representation :int representation)
     
    44524464                         (compiler-subtypep type2 'unsigned-byte)))
    44534465                ;; One of the arguments is a positive fixnum.
    4454                 (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    4455                                                            arg2 'stack :int)
     4466                (with-operand-accumulation
     4467                    ((compile-operand arg1 :int)
     4468                     (compile-operand arg2 :int)
     4469                     (maybe-emit-clear-values arg1 arg2)))
    44564470                (emit 'iand)
    44574471                (convert-representation :int representation)
     
    44594473               ((and (java-long-type-p type1) (java-long-type-p type2))
    44604474                ;; Both arguments are longs.
    4461                 (compile-forms-and-maybe-emit-clear-values arg1 'stack :long
    4462                                                            arg2 'stack :long)
     4475                (with-operand-accumulation
     4476                    ((compile-operand arg1 :long)
     4477                     (compile-operand arg2 :long)
     4478                     (maybe-emit-clear-values arg1 arg2)))
    44634479                (emit 'land)
    44644480                (convert-representation :long representation)
     
    44694485                         (compiler-subtypep type2 'unsigned-byte)))
    44704486                ;; One of the arguments is a positive long.
    4471                 (compile-forms-and-maybe-emit-clear-values arg1 'stack :long
    4472                                                            arg2 'stack :long)
     4487                (with-operand-accumulation
     4488                    ((compile-operand arg1 :long)
     4489                     (compile-operand arg2 :long)
     4490                     (maybe-emit-clear-values arg1 arg2)))
    44734491                (emit 'land)
    44744492                (convert-representation :long representation)
    44754493                (emit-move-from-stack target representation))
    44764494               ((fixnum-type-p type2)
    4477                 (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    4478                                                            arg2 'stack :int)
     4495                (with-operand-accumulation
     4496                    ((compile-operand arg1 nil)
     4497                     (compile-operand arg2 :int)
     4498                     (maybe-emit-clear-values arg1 arg2)))
    44794499                (emit-invokevirtual +lisp-object+ "LOGAND" '(:int) +lisp-object+)
    44804500                (fix-boxing representation result-type)
     
    44824502               ((fixnum-type-p type1)
    44834503                ;; arg1 is a fixnum, but arg2 is not
    4484                 (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    4485                                                            arg2 'stack nil)
     4504                (with-operand-accumulation
     4505                    ((compile-operand arg1 :int)
     4506                     (compile-operand arg2 nil)
     4507                     (maybe-emit-clear-values arg1 arg2)))
    44864508                ;; swap args
    44874509                (emit 'swap)
     
    44904512                (emit-move-from-stack target representation))
    44914513               (t
    4492                 (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    4493                                                            arg2 'stack nil)
     4514                (with-operand-accumulation
     4515                    ((compile-operand arg1 nil)
     4516                     (compile-operand arg2 nil)
     4517                     (maybe-emit-clear-values arg1 arg2)))
    44944518                (emit-invokevirtual +lisp-object+ "LOGAND"
    44954519                                    (lisp-object-arg-types 1) +lisp-object+)
     
    45224546               result-type (derive-compiler-type form))
    45234547         (cond ((and (fixnum-constant-value type1) (fixnum-constant-value type2))
    4524                 (compile-forms-and-maybe-emit-clear-values arg1 nil nil
    4525                                                            arg2 nil nil)
    45264548                (compile-constant (logior (fixnum-constant-value type1)
    45274549                                          (fixnum-constant-value type2))
    45284550                                  target representation))
    45294551               ((and (fixnum-type-p type1) (fixnum-type-p type2))
    4530                 (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    4531                                                            arg2 'stack :int)
     4552                (with-operand-accumulation
     4553                    ((compile-operand arg1 :int)
     4554                     (compile-operand arg2 :int)
     4555                     (maybe-emit-clear-values arg1 arg2)))
    45324556                (emit 'ior)
    45334557                (convert-representation :int representation)
     
    45374561                                                           arg2 target representation))
    45384562               ((and (eql (fixnum-constant-value type2) 0) (< *safety* 3))
    4539                 (compile-forms-and-maybe-emit-clear-values arg1 target representation
    4540                                                            arg2 nil nil))
     4563                (let ((target-register
     4564                       (if (or (not (eq target 'stack))
     4565                               (not (some-nested-block #'node-opstack-unsafe-p
     4566                                               (find-enclosed-blocks arg2))))
     4567                           target
     4568                         (allocate-register representation))))
     4569                  (compile-form arg1 target-register representation)
     4570                  (compile-form arg2 nil nil)
     4571                  (when (and (eq target 'stack)
     4572                             (not (eq target-register 'stack)))
     4573                    (emit-push-register target-register))
     4574                  (maybe-emit-clear-values arg1 arg2)))
    45414575               ((or (eq representation :long)
    45424576                    (and (java-long-type-p type1) (java-long-type-p type2)))
    4543                 (compile-forms-and-maybe-emit-clear-values arg1 'stack :long
    4544                                                            arg2 'stack :long)
     4577                (with-operand-accumulation
     4578                    ((compile-operand arg1 :long)
     4579                     (compile-operand arg2 :long)
     4580                     (maybe-emit-clear-values arg1 arg2)))
    45454581                (emit 'lor)
    45464582                (convert-representation :long representation)
    45474583                (emit-move-from-stack target representation))
    45484584               ((fixnum-type-p type2)
     4585                (with-operand-accumulation
     4586                    ((compile-operand arg1 nil)
     4587                     (compile-operand arg2 :int)
     4588                     (maybe-emit-clear-values arg1 arg2)))
    45494589                (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    45504590                                                           arg2 'stack :int)
     
    45544594               ((fixnum-type-p type1)
    45554595                ;; arg1 is of fixnum type, but arg2 is not
    4556                 (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    4557                                                            arg2 'stack nil)
     4596                (with-operand-accumulation
     4597                    ((compile-operand arg1 :int)
     4598                     (compile-operand arg2 nil)
     4599                     (maybe-emit-clear-values arg1 arg2)))
    45584600                ;; swap args
    45594601                (emit 'swap)
     
    45624604                (emit-move-from-stack target representation))
    45634605               (t
    4564                 (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    4565                                                            arg2 'stack nil)
     4606                (with-operand-accumulation
     4607                    ((compile-operand arg1 nil)
     4608                     (compile-operand arg2 nil)
     4609                     (maybe-emit-clear-values arg1 arg2)))
    45664610                (emit-invokevirtual +lisp-object+ "LOGIOR"
    45674611                                    (lisp-object-arg-types 1) +lisp-object+)
     
    45964640               type2       (derive-compiler-type arg2)
    45974641               result-type (derive-compiler-type form))
    4598          (cond ((eq representation :int)
    4599                 (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    4600                                                            arg2 'stack :int)
    4601                 (emit 'ixor))
    4602                ((and (fixnum-type-p type1) (fixnum-type-p type2))
    4603                 (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    4604                                                            arg2 'stack :int)
     4642         (cond ((or (eq representation :int)
     4643                    (and (fixnum-type-p type1) (fixnum-type-p type2)))
     4644                (with-operand-accumulation
     4645                    ((compile-operand arg1 :int)
     4646                     (compile-operand arg2 :int)
     4647                     (maybe-emit-clear-values arg1 arg2)))
    46054648                (emit 'ixor)
    46064649                (convert-representation :int representation))
    46074650               ((and (java-long-type-p type1) (java-long-type-p type2))
    4608                 (compile-forms-and-maybe-emit-clear-values arg1 'stack :long
    4609                                                            arg2 'stack :long)
     4651                (with-operand-accumulation
     4652                    ((compile-operand arg1 :long)
     4653                     (compile-operand arg2 :long)
     4654                     (maybe-emit-clear-values arg1 arg2)))
    46104655                (emit 'lxor)
    46114656                (convert-representation :long representation))
    46124657               ((fixnum-type-p type2)
    4613                 (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    4614                                                            arg2 'stack :int)
     4658                (with-operand-accumulation
     4659                    ((compile-operand arg1 nil)
     4660                     (compile-operand arg2 :int)
     4661                     (maybe-emit-clear-values arg1 arg2)))
    46154662                (emit-invokevirtual +lisp-object+ "LOGXOR" '(:int) +lisp-object+)
    46164663                (fix-boxing representation result-type))
    46174664               (t
    4618                 (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    4619                                                            arg2 'stack nil)
     4665                (with-operand-accumulation
     4666                    ((compile-operand arg1 nil)
     4667                     (compile-operand arg2 nil)
     4668                     (maybe-emit-clear-values arg1 arg2)))
    46204669                (emit-invokevirtual +lisp-object+ "LOGXOR"
    46214670                                    (lisp-object-arg-types 1) +lisp-object+)
Note: See TracChangeset for help on using the changeset viewer.