Changeset 13151


Ignore:
Timestamp:
01/15/11 20:51:11 (11 years ago)
Author:
ehuelsmann
Message:

No longer rewrite ordinary function calls for stack safety,
instead, let the code generator determine if it closes over
a block of unsafe code.

We need to remember per GO/RETURN-FROM to which block they
go in order to determine opstack safety.

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

Legend:

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

    r13129 r13151  
    621621(defun p1-return-from (form)
    622622  (let* ((name (second form))
    623          (block (find-block name)))
     623         (block (find-block name))
     624         non-local-p)
    624625    (when (null block)
    625626      (compiler-error "RETURN-FROM ~S: no block named ~S is currently visible."
     
    635636             (dformat t "p1-return-from protected = ~S~%" protected)
    636637             (if protected
    637                  (setf (block-non-local-return-p block) t)
     638                 (setf (block-non-local-return-p block) t
     639                       non-local-p t)
    638640                 ;; non-local GO's ensure environment restoration
    639641                 ;; find out about this local GO
     
    642644                         (enclosed-by-environment-setting-block-p block))))))
    643645          (t
    644            (setf (block-non-local-return-p block) t)))
     646           (setf (block-non-local-return-p block) t
     647                 non-local-p t)))
    645648    (when (block-non-local-return-p block)
    646649      (dformat t "non-local return from block ~S~%" (block-name block)))
    647650    (let ((value-form (p1 (caddr form))))
    648651      (push value-form (block-return-value-forms block))
    649       (list 'RETURN-FROM name value-form))))
     652      (make-jump-node (list 'RETURN-FROM name value-form)
     653                      non-local-p block))))
    650654
    651655(defun p1-tagbody (form)
     
    696700      (error "p1-go: tag not found: ~S" name))
    697701    (setf (tag-used tag) t)
    698     (let ((tag-block (tag-block tag)))
     702    (let ((tag-block (tag-block tag))
     703          non-local-p)
    699704      (cond ((eq (tag-compiland tag) *current-compiland*)
    700705             ;; Does the GO leave an enclosing UNWIND-PROTECT or CATCH?
    701706             (if (enclosed-by-protected-block-p tag-block)
    702707                 (setf (tagbody-non-local-go-p tag-block) t
    703                        (tag-used-non-locally tag) t)
     708                       (tag-used-non-locally tag) t
     709                       non-local-p t)
    704710                 ;; non-local GO's ensure environment restoration
    705711                 ;; find out about this local GO
     
    709715            (t
    710716             (setf (tagbody-non-local-go-p tag-block) t
    711                    (tag-used-non-locally tag) t)))))
    712   form)
     717                   (tag-used-non-locally tag) t
     718                   non-local-p t)))
     719      (make-jump-node form non-local-p tag-block tag))))
    713720
    714721(defun validate-function-name (name)
     
    11441151  (list 'TRULY-THE (%cadr form) (p1 (%caddr form))))
    11451152
     1153(defvar *pass2-unsafe-p-special-treatment-functions*
     1154  '(
     1155
     1156     constantp endp evenp floatp integerp listp minusp
     1157     numberp oddp plusp rationalp realp
     1158     ;; predicates not marked as such?
     1159       simple-vector-p
     1160       stringp
     1161       symbolp
     1162       vectorp
     1163       zerop
     1164       atom
     1165       consp
     1166       fixnump
     1167       packagep
     1168       readtablep
     1169       characterp
     1170       bit-vector-p
     1171       SIMPLE-TYPEP
     1172
     1173     declare
     1174     multiple-value-call
     1175     multiple-value-list
     1176     multiple-value-prog1
     1177     nth
     1178     progn
     1179
     1180     EQL EQUAL
     1181     + - / *
     1182     < < > >= = /=
     1183     ASH
     1184     AREF
     1185     RPLACA RPLACD
     1186     %ldb
     1187     and
     1188     aset
     1189     car
     1190     cdr
     1191     char
     1192     char-code
     1193     java:jclass
     1194     java:jconstructor
     1195     java:jmethod
     1196     char=
     1197     coerce-to-function
     1198     cons
     1199     sys::backq-cons
     1200     delete
     1201     elt
     1202     eq
     1203     eql
     1204     find-class
     1205     funcall
     1206     function
     1207     gensym
     1208     get
     1209     getf
     1210     gethash
     1211     gethash1
     1212     if
     1213     sys::%length
     1214     list
     1215     sys::backq-list
     1216     list*
     1217     sys::backq-list*
     1218     load-time-value
     1219     logand
     1220     logior
     1221     lognot
     1222     logxor
     1223     max
     1224     memq
     1225     memql
     1226     min
     1227     mod
     1228     neq
     1229     not
     1230     nthcdr
     1231     null
     1232     or
     1233     puthash
     1234     quote
     1235     read-line
     1236     rplacd
     1237     schar
     1238     set
     1239     set-car
     1240     set-cdr
     1241       set-char
     1242       set-schar
     1243       set-std-slot-value
     1244       setq
     1245       std-slot-value
     1246       stream-element-type
     1247       structure-ref
     1248       structure-set
     1249       svref
     1250       svset
     1251       sxhash
     1252       symbol-name
     1253       symbol-package
     1254       symbol-value
     1255       truncate
     1256       values
     1257       vector-push-extend
     1258       write-8-bits
     1259       with-inline-code)
     1260"The functions named in the list bound to this variable
     1261need to be rewritten if UNSAFE-P returns non-NIL for their
     1262argument list.
     1263
     1264All other function calls are handled by generic function calling
     1265in pass2, which accounts for OPSTACK unsafety itself.")
     1266
     1267
     1268
     1269
    11461270(defknown unsafe-p (t) t)
    11471271(defun unsafe-p (args)
     
    11891313       ;;((lambda (...) ...) ...)
    11901314       (expand-function-call-inline form (cadr op) (copy-tree (cddr op)) args))
    1191       (t (if (unsafe-p args)
     1315      (t (if (and (member op *pass2-unsafe-p-special-treatment-functions*)
     1316                  (unsafe-p args))
    11921317       (let ((arg1 (car args)))
    11931318         (cond ((and (consp arg1) (eq (car arg1) 'GO))
     
    11981323      ;; Preserve the order of evaluation of the arguments!
    11991324      (dolist (arg args)
    1200         (cond ((constantp arg)
     1325        (cond ((and (constantp arg)
     1326                                      (not (node-p arg)))
    12011327         (push arg syms))
    12021328        ((and (consp arg) (eq (car arg) 'GO))
  • branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

    r13129 r13151  
    599599               ((catch-node-p form)
    600600                nil)
     601               ((jump-node-p form)
     602                (single-valued-p (node-form form)))
    601603               (t
    602604                (assert (not "SINGLE-VALUED-P unhandled NODE-P branch")))))
     
    697699in a register"
    698700  (let ((unsafe (or *saved-operands*
    699         (some-nested-block #'block-opstack-unsafe-p
     701        (some-nested-block #'node-opstack-unsafe-p
    700702               (find-enclosed-blocks form)))))
    701703    (when (and unsafe (null *saved-operands*))
     
    18571859         nil)))
    18581860
    1859 (defknown process-args (t) t)
    1860 (defun process-args (args)
     1861(defknown process-args (t t) t)
     1862(defun process-args (args stack)
    18611863  "Compiles forms specified as function call arguments.
    18621864
     
    18661868  (when args
    18671869    (let ((numargs (length args)))
    1868       (let ((must-clear-values nil))
     1870      (let ((must-clear-values nil)
     1871            (unsafe-args (some-nested-block #'node-opstack-unsafe-p
     1872                                            (mapcan #'find-enclosed-blocks
     1873                                                    args))))
    18691874        (declare (type boolean must-clear-values))
    1870         (cond ((<= numargs call-registers-limit)
     1875        (cond ((and unsafe-args
     1876                    (<= numargs call-registers-limit))
     1877               (let ((*register* *register*)
     1878                     operand-registers)
     1879                 (dolist (stack-item stack)
     1880                   (let ((register (allocate-register)))
     1881                     (push register operand-registers)
     1882                     (emit-move-from-stack register stack-item)))
     1883                 (setf operand-registers (reverse operand-registers))
     1884                 (dolist (arg args)
     1885                   (push (allocate-register) operand-registers)
     1886                   (compile-form arg (car operand-registers) nil)
     1887                   (unless must-clear-values
     1888                     (unless (single-valued-p arg)
     1889                       (setf must-clear-values t))))
     1890                 (dolist (register (nreverse operand-registers))
     1891                   (aload register))))
     1892              ((<= numargs call-registers-limit)
    18711893               (dolist (arg args)
    18721894                 (compile-form arg 'stack nil)
     
    18751897                     (setf must-clear-values t)))))
    18761898              (t
    1877                (emit-push-constant-int numargs)
    1878                (emit-anewarray +lisp-object+)
    1879                (let ((i 0))
    1880                  (dolist (arg args)
    1881                    (emit 'dup)
    1882                    (emit-push-constant-int i)
    1883                    (compile-form arg 'stack nil)
    1884                    (emit 'aastore) ; store value in array
    1885                    (unless must-clear-values
    1886                      (unless (single-valued-p arg)
    1887                        (setf must-clear-values t)))
    1888                    (incf i)))))
     1899               (let (;(*register* *register*) ;; ### FIXME: this doesn't work, but why not?
     1900                     (array-register (allocate-register))
     1901                     saved-stack)
     1902                 (when unsafe-args
     1903                   (dolist (stack-item stack)
     1904                     (let ((register (allocate-register)))
     1905                       (push register saved-stack)
     1906                       (emit-move-from-stack register stack-item))))
     1907                 (emit-push-constant-int numargs)
     1908                 (emit-anewarray +lisp-object+)
     1909                 ;; be operand stack safe by not accumulating
     1910                 ;; any arguments on the stack.
     1911                 ;;
     1912                 ;; The overhead of storing+loading the array register
     1913                 ;; at the beginning and ending is small: there are at
     1914                 ;; least nine parameters to be calculated.
     1915                 (astore array-register)
     1916                 (let ((i 0))
     1917                   (dolist (arg args)
     1918                     (cond
     1919                      ((not (some-nested-block #'node-opstack-unsafe-p
     1920                                               (find-enclosed-blocks arg)))
     1921                       (aload array-register)
     1922                       (emit-push-constant-int i)
     1923                       (compile-form arg 'stack nil))
     1924                      (t
     1925                       (compile-form arg 'stack nil)
     1926                       (aload array-register)
     1927                       (emit 'swap)
     1928                       (emit-push-constant-int i)
     1929                       (emit 'swap)))
     1930                     (emit 'aastore) ; store value in array
     1931                     (unless must-clear-values
     1932                       (unless (single-valued-p arg)
     1933                         (setf must-clear-values t)))
     1934                     (incf i))
     1935                   (when unsafe-args
     1936                     (mapcar #'emit-push-register
     1937                             saved-stack
     1938                             (reverse stack)))
     1939                   (aload array-register)))))
    18891940        (when must-clear-values
    18901941          (emit-clear-values)))))
     
    19542005            (t
    19552006             (emit-load-externalized-object op)))
    1956       (process-args args)
     2007      (process-args args
     2008                    (if (or (<= *speed* *debug*) *require-stack-frame*)
     2009                        '(nil nil) '(nil)))
    19572010      (if (or (<= *speed* *debug*) *require-stack-frame*)
    19582011          (emit-call-thread-execute numargs)
     
    19612014      (emit-move-from-stack target representation))))
    19622015
    1963 (defun compile-call (args)
     2016(defun compile-call (args stack)
    19642017  "Compiles a function call.
    19652018
     
    19682021  (let ((numargs (length args)))
    19692022    (cond ((> *speed* *debug*)
    1970            (process-args args)
     2023           (process-args args stack)
    19712024           (emit-call-execute numargs))
    19722025          (t
    19732026           (emit-push-current-thread)
    19742027           (emit 'swap) ; Stack: thread function
    1975            (process-args args)
     2028           (process-args args (list* (car stack) nil (cdr stack)))
    19762029           (emit-call-thread-execute numargs)))))
    19772030
     
    20402093    (return-from p2-funcall (compile-function-call form target representation)))
    20412094  (compile-forms-and-maybe-emit-clear-values (cadr form) 'stack nil)
    2042   (compile-call (cddr form))
     2095  (compile-call (cddr form) '(nil))
    20432096  (fix-boxing representation nil)
    20442097  (emit-move-from-stack target))
     
    21052158                                  (list +lisp-object+ +closure-binding-array+)
    21062159                                  +lisp-object+)))))
    2107     (process-args args)
     2160    (process-args args '(nil))
    21082161    (emit-call-execute (length args))
    21092162    (fix-boxing representation nil)
     
    30043057
    30053058(defun restore-environment-and-make-handler (register label-START)
    3006   (let ((label-END (gensym))
    3007         (label-EXIT (gensym)))
     3059  (let ((label-END (gensym "U"))
     3060        (label-EXIT (gensym "E")))
    30083061    (emit 'goto label-EXIT)
    30093062    (label label-END)
     
    30223075         (bind-special-p nil)
    30233076         (variables (m-v-b-vars block))
    3024          (label-START (gensym)))
     3077         (label-START (gensym "F")))
    30253078    (dolist (variable variables)
    30263079      (let ((special-p (variable-special-p variable)))
     
    34253478         (*visible-variables* *visible-variables*)
    34263479         (specialp nil)
    3427          (label-START (gensym)))
     3480         (label-START (gensym "F")))
    34283481    ;; Walk the variable list looking for special bindings and unused lexicals.
    34293482    (dolist (variable (let-vars block))
     
    34723525         (form (tagbody-form block))
    34733526         (body (cdr form))
    3474          (BEGIN-BLOCK (gensym))
    3475          (END-BLOCK (gensym))
    3476          (RETHROW (gensym))
    3477          (EXIT (gensym))
     3527         (BEGIN-BLOCK (gensym "F"))
     3528         (END-BLOCK (gensym "U"))
     3529         (RETHROW (gensym "T"))
     3530         (EXIT (gensym "E"))
    34783531         (must-clear-values nil)
    34793532         (specials-register (when (tagbody-non-local-go-p block)
     
    35123565    (when (tagbody-non-local-go-p block)
    35133566      ; We need a handler to catch non-local GOs.
    3514       (let* ((HANDLER (gensym))
    3515              (EXTENT-EXIT-HANDLER (gensym))
     3567      (let* ((HANDLER (gensym "H"))
     3568             (EXTENT-EXIT-HANDLER (gensym "HE"))
    35163569             (*register* *register*)
    35173570             (go-register (allocate-register))
     
    35663619  ;; FIXME What if we're called with a non-NIL representation?
    35673620  (declare (ignore target representation))
    3568   (let* ((name (cadr form))
    3569          (tag (find-tag name))
    3570          (tag-block (when tag (tag-block tag))))
     3621  (let* ((node form)
     3622         (form (node-form form))
     3623         (name (cadr form))
     3624         (tag (jump-target-tag node))
     3625         (tag-block (when tag (jump-target-block node))))
    35713626    (unless tag
    35723627      (error "p2-go: tag not found: ~S" name))
     
    36723727  (let* ((*blocks* (cons block *blocks*))
    36733728         (*register* *register*)
    3674          (BEGIN-BLOCK (gensym))
    3675          (END-BLOCK (gensym))
     3729         (BEGIN-BLOCK (gensym "F"))
     3730         (END-BLOCK (gensym "U"))
    36763731         (BLOCK-EXIT (block-exit block))
    36773732         (specials-register (when (block-non-local-return-p block)
     
    36963751      ;; We need a handler to catch non-local RETURNs.
    36973752      (emit 'goto BLOCK-EXIT) ; Jump over handler, when inserting one
    3698       (let ((HANDLER (gensym))
    3699             (EXTENT-EXIT-HANDLER (gensym))
     3753      (let ((HANDLER (gensym "H"))
     3754            (EXTENT-EXIT-HANDLER (gensym "HE"))
    37003755            (THIS-BLOCK (gensym)))
    37013756        (label HANDLER)
     
    37323787  ;; FIXME What if we're called with a non-NIL representation?
    37333788  (declare (ignore target representation))
    3734   (let* ((name (second form))
     3789  (let* ((node form)
     3790         (form (node-form form))
     3791         (name (second form))
    37353792         (result-form (third form))
    3736          (block (find-block name)))
     3793         (block (jump-target-block node)))
    37373794    (when (null block)
    37383795      (error "No block named ~S is currently visible." name))
     
    38243881         (environment-register
    38253882          (setf (progv-environment-register block) (allocate-register)))
    3826          (label-START (gensym)))
     3883         (label-START (gensym "F")))
    38273884    (with-operand-accumulation
    38283885        ((compile-operand symbols-form nil)
     
    65076564         (*register* *register*)
    65086565         (object-register (allocate-register))
    6509          (BEGIN-PROTECTED-RANGE (gensym))
    6510          (END-PROTECTED-RANGE (gensym))
    6511          (EXIT (gensym)))
     6566         (BEGIN-PROTECTED-RANGE (gensym "F"))
     6567         (END-PROTECTED-RANGE (gensym "U"))
     6568         (EXIT (gensym "E")))
    65126569    (compile-form (cadr form) 'stack nil)
    65136570    (emit-invokevirtual +lisp-object+ "lockableInstance" nil
     
    65436600    (let* ((*register* *register*)
    65446601           (tag-register (allocate-register))
    6545            (BEGIN-PROTECTED-RANGE (gensym))
    6546            (END-PROTECTED-RANGE (gensym))
    6547            (THROW-HANDLER (gensym))
     6602           (BEGIN-PROTECTED-RANGE (gensym "F"))
     6603           (END-PROTECTED-RANGE (gensym "U"))
     6604           (THROW-HANDLER (gensym "H"))
    65486605           (RETHROW (gensym))
    65496606           (DEFAULT-HANDLER (gensym))
    6550            (EXIT (gensym))
     6607           (EXIT (gensym "E"))
    65516608           (specials-register (allocate-register)))
    65526609      (compile-form (second form) tag-register nil) ; Tag.
     
    66386695           (values-register (allocate-register))
    66396696           (specials-register (allocate-register))
    6640            (BEGIN-PROTECTED-RANGE (gensym))
    6641            (END-PROTECTED-RANGE (gensym))
    6642            (HANDLER (gensym))
    6643            (EXIT (gensym)))
     6697           (BEGIN-PROTECTED-RANGE (gensym "F"))
     6698           (END-PROTECTED-RANGE (gensym "U"))
     6699           (HANDLER (gensym "H"))
     6700           (EXIT (gensym "E")))
    66446701      ;; Make sure there are no leftover multiple return values from previous calls.
    66456702      (emit-clear-values)
     
    67306787        ((node-p form)
    67316788         (cond
     6789           ((jump-node-p form)
     6790            (let ((op (car (node-form form))))
     6791              (cond
     6792               ((eq op 'go)
     6793                (p2-go form target representation))
     6794               ((eq op 'return-from)
     6795                (p2-return-from form target representation))
     6796               (t
     6797                (assert (not "jump-node: can't happen"))))))
    67326798           ((block-node-p form)
    67336799            (p2-block-node form target representation))
     
    68646930         (*thread* nil)
    68656931         (*initialize-thread-var* nil)
    6866          (label-START (gensym)))
     6932         (label-START (gensym "F")))
    68676933
    68686934    (class-add-method class-file method)
  • branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm.lisp

    r13150 r13151  
    484484    block))
    485485
     486(defstruct (jump-node (:conc-name jump-)
     487                      (:include node)
     488                      (:constructor
     489                       %make-jump-node (non-local-p target-block target-tag)))
     490  non-local-p
     491  target-block
     492  target-tag)
     493(defun make-jump-node (form non-local-p target-block &optional target-tag)
     494  (let ((node (%make-jump-node non-local-p target-block target-tag)))
     495    ;; Don't push into compiland blocks, as this as a node rather than a block
     496    (setf (node-form node) form)
     497    (add-node-child *block* node)
     498    node))
     499
     500
    486501;; binding blocks: LET, LET*, FLET, LABELS, M-V-B, PROGV, LOCALLY
    487502;;
     
    620635    ;; when the innermost enclosing block doesn't have node-children,
    621636    ;;  there's really nothing to search for.
    622     (when (null (node-children (car *blocks*)))
    623       (return-from find-enclosed-blocks)))
     637    (let ((first-enclosing-block (car *blocks*)))
     638      (when (and (eq *current-compiland*
     639                     (node-compiland first-enclosing-block))
     640                 (null (node-children first-enclosing-block)))
     641        (return-from find-enclosed-blocks))))
    624642
    625643  (%find-enclosed-blocks form))
    626    
     644
    627645
    628646(defun some-nested-block (predicate blocks)
     
    662680      (synchronized-node-p object)))
    663681
    664 (defun block-opstack-unsafe-p (block)
    665   (or (when (tagbody-node-p block) (tagbody-non-local-go-p block))
    666       (when (block-node-p block) (block-non-local-return-p block))
    667       (catch-node-p block)))
     682(defun node-opstack-unsafe-p (node)
     683  (or (when (jump-node-p node)
     684        (let ((target-block (jump-target-block node)))
     685          (and (null (jump-non-local-p node))
     686               (eq (node-compiland target-block) *current-compiland*)
     687               (member target-block *blocks*))))
     688      (when (tagbody-node-p node) (tagbody-non-local-go-p node))
     689      (when (block-node-p node) (block-non-local-return-p node))
     690      (catch-node-p node)))
    668691
    669692(defknown block-creates-runtime-bindings-p (t) boolean)
Note: See TracChangeset for help on using the changeset viewer.