Changeset 13222


Ignore:
Timestamp:
02/15/11 22:29:22 (11 years ago)
Author:
ehuelsmann
Message:

Backport 'unsafe-p-removal' branch: this commit pushes back the
responsibility of maintaining stack consistency in generated (byte) code
to pass2, from a shared pass1/pass2 responsibility. The issue why it can't
happen in pass1 is because in pass1 the full structure of the lisp code
isn't known yet, due to lambda and local function inlining.

Location:
trunk/abcl/src/org/armedbear/lisp
Files:
5 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp

    r13147 r13222  
    399399  form)
    400400
    401 (defknown p1-if (t) t)
    402 (defun p1-if (form)
    403   (let ((test (cadr form)))
    404     (cond ((unsafe-p test)
    405            (cond ((and (consp test)
    406                        (memq (%car test) '(GO RETURN-FROM THROW)))
    407                   (p1 test))
    408                  (t
    409                   (let* ((var (gensym))
    410                          (new-form
    411                           `(let ((,var ,test))
    412                              (if ,var ,(third form) ,(fourth form)))))
    413                     (p1 new-form)))))
    414           (t
    415            (p1-default form)))))
    416 
    417 
    418 (defmacro p1-let/let*-vars
     401(defmacro p1-let/let*-vars
    419402    (block varlist variables-var var body1 body2)
    420403  (let ((varspec (gensym))
     
    469452  (let* ((*visible-variables* *visible-variables*)
    470453         (block (make-let/let*-node))
     454   (*block* block)
    471455         (op (%car form))
    472456         (varlist (cadr form))
     
    507491  (let* ((*visible-variables* *visible-variables*)
    508492         (block (make-locally-node))
     493   (*block* block)
    509494         (free-specials (process-declarations-for-vars (cdr form) nil block)))
    510495    (setf (locally-free-specials block) free-specials)
     
    524509  (let* ((*visible-variables* *visible-variables*)
    525510         (block (make-m-v-b-node))
     511   (*block* block)
    526512         (varlist (cadr form))
    527513         ;; Process the values-form first. ("The scopes of the name binding and
     
    553539(defun p1-block (form)
    554540  (let* ((block (make-block-node (cadr form)))
     541   (*block* block)
    555542         (*blocks* (cons block *blocks*)))
    556543    (setf (cddr form) (p1-body (cddr form)))
     
    569556         (body (cddr form))
    570557         (block (make-catch-node))
     558   (*block* block)
    571559         ;; our subform processors need to know
    572560         ;; they're enclosed in a CATCH block
     
    592580         (body (cddr form))
    593581         (block (make-synchronized-node))
     582   (*block* block)
    594583         (*blocks* (cons block *blocks*))
    595584         result)
     
    615604      ;; need to copy the forms to create a second copy.
    616605      (let* ((block (make-unwind-protect-node))
     606       (*block* block)
    617607             ;; a bit of jumping through hoops...
    618608             (unwinding-forms (p1-body (copy-tree (cddr form))))
     
    630620(defknown p1-return-from (t) t)
    631621(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))))
    635622  (let* ((name (second form))
    636          (block (find-block name)))
     623         (block (find-block name))
     624         non-local-p)
    637625    (when (null block)
    638626      (compiler-error "RETURN-FROM ~S: no block named ~S is currently visible."
     
    648636             (dformat t "p1-return-from protected = ~S~%" protected)
    649637             (if protected
    650                  (setf (block-non-local-return-p block) t)
     638                 (setf (block-non-local-return-p block) t
     639                       non-local-p t)
    651640                 ;; non-local GO's ensure environment restoration
    652641                 ;; find out about this local GO
     
    655644                         (enclosed-by-environment-setting-block-p block))))))
    656645          (t
    657            (setf (block-non-local-return-p block) t)))
     646           (setf (block-non-local-return-p block) t
     647                 non-local-p t)))
    658648    (when (block-non-local-return-p block)
    659       (dformat t "non-local return from block ~S~%" (block-name block))))
    660   (list* 'RETURN-FROM (cadr form) (mapcar #'p1 (cddr form))))
     649      (dformat t "non-local return from block ~S~%" (block-name block)))
     650    (let ((value-form (p1 (caddr form))))
     651      (push value-form (block-return-value-forms block))
     652      (make-jump-node (list 'RETURN-FROM name value-form)
     653                      non-local-p block))))
    661654
    662655(defun p1-tagbody (form)
    663656  (let* ((block (make-tagbody-node))
     657   (*block* block)
    664658         (*blocks* (cons block *blocks*))
    665659         (*visible-tags* *visible-tags*)
     
    706700      (error "p1-go: tag not found: ~S" name))
    707701    (setf (tag-used tag) t)
    708     (let ((tag-block (tag-block tag)))
     702    (let ((tag-block (tag-block tag))
     703          non-local-p)
    709704      (cond ((eq (tag-compiland tag) *current-compiland*)
    710705             ;; Does the GO leave an enclosing UNWIND-PROTECT or CATCH?
    711706             (if (enclosed-by-protected-block-p tag-block)
    712707                 (setf (tagbody-non-local-go-p tag-block) t
    713                        (tag-used-non-locally tag) t)
     708                       (tag-used-non-locally tag) t
     709                       non-local-p t)
    714710                 ;; non-local GO's ensure environment restoration
    715711                 ;; find out about this local GO
     
    719715            (t
    720716             (setf (tagbody-non-local-go-p tag-block) t
    721                    (tag-used-non-locally tag) t)))))
    722   form)
     717                   (tag-used-non-locally tag) t
     718                   non-local-p t)))
     719      (make-jump-node form non-local-p tag-block tag))))
    723720
    724721(defun validate-function-name (name)
     
    928925   (process-optimization-declarations (cddr form))
    929926   (let* ((block (make-flet-node))
     927    (*block* block)
    930928    (*blocks* (cons block *blocks*))
    931929    (body (cddr form))
     
    966964     (p1-compiland (local-function-compiland local-function))))
    967965       (let* ((block (make-labels-node))
     966        (*block* block)
    968967              (*blocks* (cons block *blocks*))
    969968              (body (cddr form))
     
    10691068(defun p1-progv (form)
    10701069  ;; 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))))
    10751070  (let* ((symbols-form (p1 (cadr form)))
    10761071         (values-form (p1 (caddr form)))
    10771072         (block (make-progv-node))
     1073   (*block* block)
    10781074         (*blocks* (cons block *blocks*))
    10791075         (body (cdddr form)))
     
    10901086          `(progv ,symbols-form ,values-form ,@(p1-body body)))
    10911087    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))))
    11061088
    11071089(defun p1-quote (form)
     
    11691151  (list 'TRULY-THE (%cadr form) (p1 (%caddr form))))
    11701152
    1171 (defknown unsafe-p (t) t)
    1172 (defun unsafe-p (args)
    1173   "Determines whether the args can cause 'stack unsafe situations'.
    1174 Returns T if this is the case.
    1175 
    1176 When a 'stack unsafe situation' is encountered, the stack cannot
    1177 be used for temporary storage of intermediary results. This happens
    1178 because one of the forms in ARGS causes a local transfer of control
    1179 - local GO instruction - which assumes an empty stack, or if one of
    1180 the args causes a Java exception handler to be installed, which
    1181 - when triggered - clears out the stack.
    1182 "
    1183   (cond ((node-p args)
    1184          (unsafe-p (node-form args)))
    1185         ((atom args)
    1186          nil)
    1187         (t
    1188          (case (%car args)
    1189            (QUOTE
    1190             nil)
    1191 ;;           (LAMBDA
    1192 ;;            nil)
    1193            ((RETURN-FROM GO CATCH THROW UNWIND-PROTECT BLOCK)
    1194             t)
    1195            (t
    1196             (dolist (arg args)
    1197               (when (unsafe-p arg)
    1198                 (return t))))))))
    1199 
    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 
    12441153(defknown p1-throw (t) t)
    12451154(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))))
    12491155  (list* 'THROW (mapcar #'p1 (cdr form))))
    12501156
     
    12561162       ;;(funcall (lambda (...) ...) ...)
    12571163       (let ((op (car args)) (args (cdr args)))
    1258   (expand-function-call-inline form (cadr op) (copy-tree (cddr op))
    1259               args)))
     1164        (expand-function-call-inline form (cadr op) (copy-tree (cddr op))
     1165                                      args)))
    12601166      ((and (listp op) (eq (car op) 'lambda))
    12611167       ;;((lambda (...) ...) ...)
    12621168       (expand-function-call-inline form (cadr op) (copy-tree (cddr op)) args))
    1263       (t (if (unsafe-p args)
    1264        (let ((arg1 (car args)))
    1265          (cond ((and (consp arg1) (eq (car arg1) 'GO))
    1266           arg1)
    1267          (t
    1268           (let ((syms ())
    1269           (lets ()))
    1270       ;; Preserve the order of evaluation of the arguments!
    1271       (dolist (arg args)
    1272         (cond ((constantp arg)
    1273          (push arg syms))
    1274         ((and (consp arg) (eq (car arg) 'GO))
    1275          (return-from rewrite-function-call
    1276            (list 'LET* (nreverse lets) arg)))
    1277         (t
    1278          (let ((sym (gensym)))
    1279            (push sym syms)
    1280            (push (list sym arg) lets)))))
    1281       (list 'LET* (nreverse lets)
    1282             (list* (car form) (nreverse syms)))))))
    1283        form)))))
     1169      (t form))))
    12841170
    12851171(defknown p1-function-call (t) t)
     
    14071293                  (FUNCTION             p1-function)
    14081294                  (GO                   p1-go)
    1409                   (IF                   p1-if)
     1295                  (IF                   p1-default)
     1296                  ;; used to be p1-if, which was used to rewrite the test
     1297                  ;; form to a LET-binding; that's not necessary, because
     1298                  ;; the test form doesn't lead to multiple operands on the
     1299                  ;; operand stack
    14101300                  (LABELS               p1-labels)
    14111301                  (LAMBDA               p1-lambda)
  • trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

    r13116 r13222  
    346346        (return-from type-representation (caar types))))))
    347347
    348 (defun representation-size (representation)
    349   (ecase representation
    350     ((NIL :int :boolean :float :char) 1)
    351     ((:long :double) 2)))
    352 
    353 
    354348(defknown emit-unbox-boolean () t)
    355349(defun emit-unbox-boolean ()
     
    580574(defun single-valued-p (form)
    581575  (cond ((node-p form)
    582          (if (tagbody-node-p form)
    583              (not (unsafe-p (node-form form)))
    584              (single-valued-p (node-form form))))
     576         (cond ((tagbody-node-p form)
     577                t)
     578               ((block-node-p form)
     579                (and (single-valued-p (car (last (node-form form))))
     580                     ;; return-from value forms
     581                     (every #'single-valued-p
     582                            (block-return-value-forms form))))
     583               ((or (flet-node-p form)
     584                    (labels-node-p form)
     585                    (let/let*-node-p form)
     586                    (m-v-b-node-p form)
     587                    (progv-node-p form)
     588                    (locally-node-p form)
     589                    (synchronized-node-p form))
     590                (single-valued-p (car (last (node-form form)))))
     591               ((unwind-protect-node-p form)
     592                (single-valued-p (second (node-form form))))
     593               ((catch-node-p form)
     594                nil)
     595               ((jump-node-p form)
     596                (single-valued-p (node-form form)))
     597               (t
     598                (assert (not "SINGLE-VALUED-P unhandled NODE-P branch")))))
    585599        ((var-ref-p form)
    586600         t)
     
    591605               result-type
    592606               compiland)
     607           (assert (not (member op '(LET LET* FLET LABELS TAGBODY CATCH
     608                                         MULTIPLE-VALUE-BIND
     609                                         UNWIND-PROTECT BLOCK PROGV
     610                                         LOCALLY))))
    593611           (cond ((eq op 'IF)
    594612                  (and (single-valued-p (third form))
     
    596614                 ((eq op 'PROGN)
    597615                  (single-valued-p (car (last form))))
    598                  ((eq op 'BLOCK)
    599                   (single-valued-p (car (last form))))
    600                  ((memq op '(LET LET*))
    601                   (single-valued-p (car (last (cddr form)))))
    602616                 ((memq op '(AND OR))
    603617                  (every #'single-valued-p (cdr form)))
     
    646660    (apply #'maybe-emit-clear-values forms-for-emit-clear)))
    647661
     662
     663(declaim (special *saved-operands* *operand-representations*))
     664(defmacro with-operand-accumulation ((&body argument-accumulation-body)
     665                                     &body call-body)
     666  "Macro used to operand-stack-safely collect arguments in the
     667`argument-accumulation-body' to be available on the stack upon entry of the
     668`call-body'. The argument-accumulation-body code may not assume arguments
     669are actually on the stack while accumulating.
     670
     671This macro closes over a code-generating block. Operands can be collected
     672using the `accumulate-operand', `compile-operand', `emit-variable-operand'
     673and `emit-load-externalized-object-operand'."
     674  `(let (*saved-operands*
     675         *operand-representations*
     676         (*register* *register*)
     677         ) ;; hmm can we do this?? either body
     678                                  ;; could allocate registers ...
     679     ,@argument-accumulation-body
     680     (load-saved-operands)
     681     ,@call-body))
     682
     683(defmacro accumulate-operand ((representation &key unsafe-p)
     684                              &body body)
     685  "Macro used to collect a single operand.
     686
     687This macro closes over a code-generating block. The generated code should
     688leave a single operand on the stack, with representation `representation'.
     689The value `unsafe-p', when provided, is an expression evaluated at run time
     690to indicate if the body is opstack unsafe."
     691  `(progn
     692     ,@(when unsafe-p
     693         `((when ,unsafe-p
     694             (save-existing-operands))))
     695     ,@body
     696     (save-operand ,representation)))
     697
     698(defun load-saved-operands ()
     699  "Load any operands which have been saved into registers
     700back onto the stack in preparation of the execution of the opcode."
     701  (mapcar #'emit-push-register
     702          (reverse *saved-operands*)
     703          (reverse *operand-representations*)))
     704
     705(defun save-existing-operands ()
     706  "If any operands have been compiled to the stack,
     707save them in registers."
     708  (when (null *saved-operands*)
     709    (dolist (representation *operand-representations*)
     710      (let ((register (allocate-register representation)))
     711        (push register *saved-operands*)
     712        (emit-move-from-stack register representation)))
     713
     714    (setf *saved-operands* (nreverse *saved-operands*))))
     715
     716(defun save-operand (representation)
     717  "Saves an operand from the stack (with `representation') to
     718a register and updates associated operand collection variables."
     719  (push representation *operand-representations*)
     720
     721  (when *saved-operands*
     722    (let ((register (allocate-register representation)))
     723      (push register *saved-operands*)
     724      (emit-move-from-stack register representation))))
     725
     726(defun compile-operand (form representation &optional cast)
     727  "Compiles `form' into `representation', storing the resulting value
     728on the operand stack, if it's safe to do so. Otherwise stores the value
     729in a register"
     730  (let ((unsafe (or *saved-operands*
     731                    (some-nested-block #'node-opstack-unsafe-p
     732                                       (find-enclosed-blocks form)))))
     733    (when (and unsafe (null *saved-operands*))
     734      (save-existing-operands))
     735
     736    (compile-form form 'stack representation)
     737    (when cast
     738      (emit-checkcast cast))
     739    (when unsafe
     740      (let ((register (allocate-register representation)))
     741        (push register *saved-operands*)
     742        (emit-move-from-stack register representation)))
     743
     744  (push representation *operand-representations*)))
     745
     746(defun emit-variable-operand (variable)
     747  "Pushes a variable onto the operand stack, if it's safe to do so. Otherwise
     748stores the value in a register."
     749  (push (variable-representation variable) *operand-representations*)
     750  (cond
     751   ((and *saved-operands*
     752         (variable-register variable))
     753    ;; we're in 'safe mode' and the  variable is in a register,
     754    ;; instead of binding a new register, just load the existing one
     755    (push (variable-register variable) *saved-operands*))
     756   (t
     757    (emit-push-variable variable)
     758    (when *saved-operands* ;; safe-mode
     759      (let ((register (allocate-register (variable-representation variable))))
     760        (push register *saved-operands*)
     761        (emit-move-from-stack register (variable-representation variable)))))))
     762
     763(defun emit-register-operand (register representation)
     764  (push representation *operand-representations*)
     765  (cond (*saved-operands*
     766         (push register *saved-operands*))
     767        (t
     768         (emit-push-register register representation))))
     769
     770(defun emit-thread-operand ()
     771  (ensure-thread-var-initialized)
     772  (emit-register-operand *thread* nil))
     773
     774(defun emit-load-externalized-object-operand (object)
     775  (push nil *operand-representations*)
     776  (emit-load-externalized-object object)
     777  (when *saved-operands* ;; safe-mode
     778    (let ((register (allocate-register nil)))
     779      (push register *saved-operands*)
     780      (emit 'astore register))))
     781
    648782(defknown emit-unbox-fixnum () t)
    649783(defun emit-unbox-fixnum ()
     
    729863         (aver nil))))
    730864
     865(defknown emit-push-register (t &optional t) t)
     866(defun emit-push-register (source &optional representation)
     867  (declare (optimize speed))
     868  (assert (fixnump source))
     869  (emit (ecase representation
     870               ((:int :boolean :char)
     871                        'iload)
     872               (:long   'lload)
     873               (:float  'fload)
     874               (:double 'dload)
     875               ((nil)   'aload))
     876        source))
     877
    731878;; Expects value on stack.
    732879(defknown emit-invoke-method (t t t) t)
     
    809956         more-keys-p)
    810957    (with-code-to-method (class method)
    811       (allocate-register)
     958      (allocate-register nil)
    812959      (unless (eq super +lisp-compiled-primitive+)
    813960        (multiple-value-bind
     
    825972                      (emit-anewarray +lisp-closure-parameter+)
    826973                      (astore (setf ,register *registers-allocated*))
    827                       (allocate-register)
     974                      (allocate-register nil)
    828975                      (do* ((,count-sym 0 (1+ ,count-sym))
    829976                            (,params ,params (cdr ,params))
     
    14951642  (let ((arg1 (car args))
    14961643        (arg2 (cadr args)))
    1497     (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    1498                                                arg2 'stack nil)
    1499     (emit-invokevirtual +lisp-object+ op
    1500                         (lisp-object-arg-types 1) +lisp-object+)
     1644    (with-operand-accumulation
     1645        ((compile-operand arg1 nil)
     1646         (compile-operand arg2 nil)
     1647         (maybe-emit-clear-values arg1 arg2))
     1648      (emit-invokevirtual +lisp-object+ op
     1649                          (lisp-object-arg-types 1) +lisp-object+))
    15011650    (fix-boxing representation nil)
    15021651    (emit-move-from-stack target representation)))
     
    15481697         (arg1 (%car args))
    15491698         (arg2 (%cadr args)))
    1550     (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    1551                                                arg2 'stack nil)
    1552      (let ((LABEL1 (gensym))
    1553            (LABEL2 (gensym)))
    1554        (emit (if (eq op 'EQ) 'if_acmpne 'if_acmpeq) LABEL1)
    1555        (emit-push-true representation)
    1556        (emit 'goto LABEL2)
    1557        (label LABEL1)
    1558        (emit-push-false representation)
    1559        (label LABEL2))
     1699    (with-operand-accumulation
     1700         ((compile-operand arg1 nil)
     1701          (compile-operand arg2 nil)
     1702          (maybe-emit-clear-values arg1 arg2))
     1703      (let ((LABEL1 (gensym))
     1704            (LABEL2 (gensym)))
     1705        (emit (if (eq op 'EQ) 'if_acmpne 'if_acmpeq) LABEL1)
     1706        (emit-push-true representation)
     1707        (emit 'goto LABEL2)
     1708        (label LABEL1)
     1709        (emit-push-false representation)
     1710        (label LABEL2)))
    15601711     (emit-move-from-stack target representation))
    15611712   t)
     
    15751726    (cond ((and (fixnum-type-p type1)
    15761727                (fixnum-type-p type2))
    1577            (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    1578                                                       arg2 'stack :int)
     1728           (with-operand-accumulation
     1729                ((compile-operand arg1 :int)
     1730                 (compile-operand arg2 :int)
     1731                 (maybe-emit-clear-values arg1 arg2)))
    15791732           (let ((label1 (gensym))
    15801733                 (label2 (gensym)))
     
    15861739             (label label2)))
    15871740          ((fixnum-type-p type2)
    1588            (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    1589                                                       arg2 'stack :int)
     1741           (with-operand-accumulation
     1742                ((compile-operand arg1 nil)
     1743                 (compile-operand arg2 :int)
     1744                 (maybe-emit-clear-values arg1 arg2)))
    15901745           (emit-ifne-for-eql representation '(:int)))
    15911746          ((fixnum-type-p type1)
    1592            (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    1593                                                       arg2 'stack nil)
     1747           (with-operand-accumulation
     1748                ((compile-operand arg1 :int)
     1749                 (compile-operand arg2 nil)
     1750                 (maybe-emit-clear-values arg1 arg2)))
    15941751           (emit 'swap)
    15951752           (emit-ifne-for-eql representation '(:int)))
    15961753          ((eq type2 'CHARACTER)
    1597            (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    1598                                                       arg2 'stack :char)
     1754           (with-operand-accumulation
     1755                ((compile-operand arg1 nil)
     1756                 (compile-operand arg2 :char)
     1757                 (maybe-emit-clear-values arg1 arg2)))
    15991758           (emit-ifne-for-eql representation '(:char)))
    16001759          ((eq type1 'CHARACTER)
    1601            (compile-forms-and-maybe-emit-clear-values arg1 'stack :char
    1602                                                       arg2 'stack nil)
     1760           (with-operand-accumulation
     1761                ((compile-operand arg1 :char)
     1762                 (compile-operand arg2 nil)
     1763                 (maybe-emit-clear-values arg1 arg2)))
    16031764           (emit 'swap)
    16041765           (emit-ifne-for-eql representation '(:char)))
    16051766          (t
    1606            (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    1607                                                       arg2 'stack nil)
     1767           (with-operand-accumulation
     1768                ((compile-operand arg1 nil)
     1769                 (compile-operand arg2 nil)
     1770                 (maybe-emit-clear-values arg1 arg2)))
    16081771           (ecase representation
    16091772             (:boolean
     
    16221785                (arg1 (first args))
    16231786                (arg2 (second args)))
    1624            (compile-form arg1 'stack nil)
    1625            (compile-form arg2 'stack nil)
     1787           (with-operand-accumulation
     1788               ((compile-operand arg1 nil)
     1789                (compile-operand arg2 nil)
     1790                (maybe-emit-clear-values arg1 arg2)))
    16261791           (emit-invokestatic +lisp+ "memq"
    16271792                              (lisp-object-arg-types 2) :boolean)
     
    16381803                (arg2 (second args))
    16391804                (type1 (derive-compiler-type arg1)))
    1640            (compile-form arg1 'stack nil)
    1641            (compile-form arg2 'stack nil)
     1805           (with-operand-accumulation
     1806               ((compile-operand arg1 nil)
     1807                (compile-operand arg2 nil)
     1808                (maybe-emit-clear-values arg1 arg2)))
    16421809           (cond ((eq type1 'SYMBOL) ; FIXME
    16431810                  (emit-invokestatic +lisp+ "memq"
     
    16671834    (case (length args)
    16681835      ((2 3)
    1669        (compile-form arg1 'stack nil)
    1670        (compile-form arg2 'stack nil)
    1671        (cond ((null arg3)
    1672               (maybe-emit-clear-values arg1 arg2))
    1673              (t
    1674               (compile-form arg3 'stack nil)
    1675               (maybe-emit-clear-values arg1 arg2 arg3)))
     1836       (with-operand-accumulation
     1837           ((compile-operand arg1 nil)
     1838            (compile-operand arg2 nil)
     1839            (when arg3
     1840              (compile-operand arg3 nil))
     1841            (maybe-emit-clear-values arg1 arg2 arg3)))
    16761842       (emit-invokestatic +lisp+ "get"
    16771843                          (lisp-object-arg-types (if arg3 3 2))
     
    16931859             (arg2 (second args))
    16941860             (arg3 (third args)))
    1695          (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    1696                                                     arg2 'stack nil
    1697                                                     arg3 'stack nil)
     1861       (with-operand-accumulation
     1862           ((compile-operand arg1 nil)
     1863            (compile-operand arg2 nil)
     1864            (compile-operand arg3 nil)
     1865            (maybe-emit-clear-values arg1 arg2 arg3)))
    16981866         (emit-invokestatic +lisp+ "getf"
    16991867                            (lisp-object-arg-types 3) +lisp-object+)
     
    17101878         (let ((key-form (%cadr form))
    17111879               (ht-form (%caddr form)))
    1712            (compile-form ht-form 'stack nil)
    1713            (emit-checkcast +lisp-hash-table+)
    1714            (compile-form key-form 'stack nil)
    1715            (maybe-emit-clear-values ht-form key-form)
     1880           (with-operand-accumulation
     1881               ((compile-operand ht-form nil +lisp-hash-table+)
     1882                (compile-operand key-form nil)
     1883                (maybe-emit-clear-values ht-form key-form)))
    17161884           (emit-invokevirtual +lisp-hash-table+ "gethash1"
    17171885                               (lisp-object-arg-types 1) +lisp-object+)
     
    17281896               (ht-form (%caddr form))
    17291897               (value-form (fourth form)))
    1730            (compile-form ht-form 'stack nil)
    1731            (emit-checkcast +lisp-hash-table+)
    1732            (compile-form key-form 'stack nil)
    1733            (compile-form value-form 'stack nil)
    1734            (maybe-emit-clear-values ht-form key-form value-form)
     1898           (with-operand-accumulation
     1899               ((compile-operand ht-form nil +lisp-hash-table+)
     1900                (compile-operand key-form nil)
     1901                (compile-operand value-form nil)
     1902                (maybe-emit-clear-values ht-form key-form value-form)))
    17351903           (cond (target
    17361904                  (emit-invokevirtual +lisp-hash-table+ "puthash"
     
    17571925         nil)))
    17581926
    1759 (defknown process-args (t) t)
    1760 (defun process-args (args)
     1927(defknown process-args (t t) t)
     1928(defun process-args (args stack)
    17611929  "Compiles forms specified as function call arguments.
    17621930
     
    17661934  (when args
    17671935    (let ((numargs (length args)))
    1768       (let ((must-clear-values nil))
     1936      (let ((must-clear-values nil)
     1937            (unsafe-args (some-nested-block #'node-opstack-unsafe-p
     1938                                            (mapcan #'find-enclosed-blocks
     1939                                                    args))))
    17691940        (declare (type boolean must-clear-values))
    1770         (cond ((<= numargs call-registers-limit)
     1941        (cond ((and unsafe-args
     1942                    (<= numargs call-registers-limit))
     1943               (let ((*register* *register*)
     1944                     operand-registers)
     1945                 (dolist (stack-item stack)
     1946                   (let ((register (allocate-register nil)))
     1947                     (push register operand-registers)
     1948                     (emit-move-from-stack register stack-item)))
     1949                 (setf operand-registers (reverse operand-registers))
     1950                 (dolist (arg args)
     1951                   (push (allocate-register nil) operand-registers)
     1952                   (compile-form arg (car operand-registers) nil)
     1953                   (unless must-clear-values
     1954                     (unless (single-valued-p arg)
     1955                       (setf must-clear-values t))))
     1956                 (dolist (register (nreverse operand-registers))
     1957                   (aload register))))
     1958              ((<= numargs call-registers-limit)
    17711959               (dolist (arg args)
    17721960                 (compile-form arg 'stack nil)
     
    17751963                     (setf must-clear-values t)))))
    17761964              (t
    1777                (emit-push-constant-int numargs)
    1778                (emit-anewarray +lisp-object+)
    1779                (let ((i 0))
    1780                  (dolist (arg args)
    1781                    (emit 'dup)
    1782                    (emit-push-constant-int i)
    1783                    (compile-form arg 'stack nil)
    1784                    (emit 'aastore) ; store value in array
    1785                    (unless must-clear-values
    1786                      (unless (single-valued-p arg)
    1787                        (setf must-clear-values t)))
    1788                    (incf i)))))
     1965               (let* ((*register* *register*) ;; ### FIXME: this doesn't work, but why not?
     1966                     (array-register (allocate-register nil))
     1967                     saved-stack)
     1968                 (when unsafe-args
     1969                   (dolist (stack-item stack)
     1970                     (let ((register (allocate-register nil)))
     1971                       (push register saved-stack)
     1972                       (emit-move-from-stack register stack-item))))
     1973                 (emit-push-constant-int numargs)
     1974                 (emit-anewarray +lisp-object+)
     1975                 ;; be operand stack safe by not accumulating
     1976                 ;; any arguments on the stack.
     1977                 ;;
     1978                 ;; The overhead of storing+loading the array register
     1979                 ;; at the beginning and ending is small: there are at
     1980                 ;; least nine parameters to be calculated.
     1981                 (astore array-register)
     1982                 (let ((i 0))
     1983                   (dolist (arg args)
     1984                     (cond
     1985                      ((not (some-nested-block #'node-opstack-unsafe-p
     1986                                               (find-enclosed-blocks arg)))
     1987                       (aload array-register)
     1988                       (emit-push-constant-int i)
     1989                       (compile-form arg 'stack nil))
     1990                      (t
     1991                       (compile-form arg 'stack nil)
     1992                       (aload array-register)
     1993                       (emit 'swap)
     1994                       (emit-push-constant-int i)
     1995                       (emit 'swap)))
     1996                     (emit 'aastore) ; store value in array
     1997                     (unless must-clear-values
     1998                       (unless (single-valued-p arg)
     1999                         (setf must-clear-values t)))
     2000                     (incf i))
     2001                   (when unsafe-args
     2002                     (mapcar #'emit-push-register
     2003                             saved-stack
     2004                             (reverse stack)))
     2005                   (aload array-register)))))
    17892006        (when must-clear-values
    17902007          (emit-clear-values)))))
     
    18542071            (t
    18552072             (emit-load-externalized-object op)))
    1856       (process-args args)
     2073      (process-args args
     2074                    (if (or (<= *speed* *debug*) *require-stack-frame*)
     2075                        '(nil nil) '(nil)))
    18572076      (if (or (<= *speed* *debug*) *require-stack-frame*)
    18582077          (emit-call-thread-execute numargs)
     
    18612080      (emit-move-from-stack target representation))))
    18622081
    1863 (defun compile-call (args)
     2082(defun compile-call (args stack)
    18642083  "Compiles a function call.
    18652084
     
    18682087  (let ((numargs (length args)))
    18692088    (cond ((> *speed* *debug*)
    1870            (process-args args)
     2089           (process-args args stack)
    18712090           (emit-call-execute numargs))
    18722091          (t
    18732092           (emit-push-current-thread)
    18742093           (emit 'swap) ; Stack: thread function
    1875            (process-args args)
     2094           (process-args args (list* (car stack) nil (cdr stack)))
    18762095           (emit-call-thread-execute numargs)))))
    18772096
     
    19402159    (return-from p2-funcall (compile-function-call form target representation)))
    19412160  (compile-forms-and-maybe-emit-clear-values (cadr form) 'stack nil)
    1942   (compile-call (cddr form))
     2161  (compile-call (cddr form) '(nil))
    19432162  (fix-boxing representation nil)
    19442163  (emit-move-from-stack target))
     
    19472166(defun duplicate-closure-array (compiland)
    19482167  (let* ((*register* *register*)
    1949          (register (allocate-register)))
     2168         (register (allocate-register nil)))
    19502169    (aload (compiland-closure-register compiland))        ;; src
    19512170    (emit-push-constant-int 0)                            ;; srcPos
     
    20052224                                  (list +lisp-object+ +closure-binding-array+)
    20062225                                  +lisp-object+)))))
    2007     (process-args args)
     2226    (process-args args '(nil))
    20082227    (emit-call-execute (length args))
    20092228    (fix-boxing representation nil)
     
    20602279                (let ((LABEL1 (gensym))
    20612280                      (LABEL2 (gensym)))
    2062                   (compile-forms-and-maybe-emit-clear-values
    2063                           arg1 'stack common-rep
    2064                           arg2 'stack common-rep)
    2065                   (emit-numeric-comparison op common-rep LABEL1)
    2066                   (emit-push-true representation)
    2067                   (emit 'goto LABEL2)
    2068                   (label LABEL1)
    2069                   (emit-push-false representation)
    2070                   (label LABEL2))
     2281                  (with-operand-accumulation
     2282                       ((compile-operand arg1 common-rep)
     2283                        (compile-operand arg2 common-rep)
     2284                        (maybe-emit-clear-values arg1 arg2))
     2285                    (emit-numeric-comparison op common-rep LABEL1)
     2286                    (emit-push-true representation)
     2287                    (emit 'goto LABEL2)
     2288                    (label LABEL1)
     2289                    (emit-push-false representation)
     2290                    (label LABEL2)))
    20712291                (emit-move-from-stack target representation)
    20722292                (return-from p2-numeric-comparison))
     
    21092329                                  (var-ref-p arg2))
    21102330                              (node-constant-p arg3))
    2111                    (allocate-register)))
     2331                   (allocate-register nil)))
    21122332                (arg3-register
    2113                  (unless (node-constant-p arg3) (allocate-register))))
    2114            (compile-form arg1 'stack :int)
    2115            (compile-form arg2 'stack :int)
    2116            (when arg2-register
    2117              (emit 'dup)
    2118              (emit 'istore arg2-register))
    2119            (cond (arg3-register
    2120                   (compile-form arg3 'stack :int)
    2121                   (emit 'istore arg3-register)
    2122                   (maybe-emit-clear-values arg1 arg2 arg3))
    2123                  (t
    2124                   (maybe-emit-clear-values arg1 arg2)))
     2333                 (unless (node-constant-p arg3) (allocate-register nil))))
     2334           (with-operand-accumulation
     2335               ((compile-operand arg1 :int)
     2336                (compile-operand arg2 :int)
     2337                (when arg3-register
     2338                  (compile-operand arg3 :int))
     2339                (maybe-emit-clear-values arg1 arg2 arg3))
     2340             (when arg3-register
     2341               (emit 'istore arg3-register))
     2342             (when arg2-register
     2343               (emit 'dup)
     2344               (emit 'istore arg2-register)))
    21252345           ;; First test.
    21262346           (emit test LABEL1)
     
    23722592    (let* ((arg1 (%cadr form))
    23732593           (arg2 (%caddr form)))
    2374       (compile-forms-and-maybe-emit-clear-values arg1 'stack :char
    2375                                                  arg2 'stack :char)
     2594      (with-operand-accumulation
     2595           ((compile-operand arg1 :char)
     2596            (compile-operand arg2 :char)
     2597            (maybe-emit-clear-values arg1 arg2)))
    23762598      'if_icmpne)))
    23772599
     
    23802602    (let ((arg1 (%cadr form))
    23812603          (arg2 (%caddr form)))
    2382       (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    2383                                                  arg2 'stack nil)
     2604      (with-operand-accumulation
     2605           ((compile-operand arg1 nil)
     2606            (compile-operand arg2 nil)
     2607            (maybe-emit-clear-values arg1 arg2)))
    23842608     'if_acmpne)))
    23852609
     
    24102634           (type2 (derive-compiler-type arg2)))
    24112635      (cond ((and (fixnum-type-p type1) (fixnum-type-p type2))
    2412              (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    2413                                                         arg2 'stack :int)
     2636             (with-operand-accumulation
     2637                  ((compile-operand arg1 :int)
     2638                   (compile-operand arg2 :int)
     2639                   (maybe-emit-clear-values arg1 arg2)))
    24142640             'if_icmpne)
    24152641            ((and (eq type1 'CHARACTER) (eq type2 'CHARACTER))
    2416              (compile-forms-and-maybe-emit-clear-values arg1 'stack :char
    2417                                                         arg2 'stack :char)
     2642             (with-operand-accumulation
     2643                  ((compile-operand arg1 :char)
     2644                   (compile-operand arg2 :char)
     2645                   (maybe-emit-clear-values arg1 arg2)))
    24182646             'if_icmpne)
    24192647            ((eq type2 'CHARACTER)
    2420              (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    2421                                                         arg2 'stack :char)
     2648             (with-operand-accumulation
     2649                  ((compile-operand arg1 nil)
     2650                   (compile-operand arg2 :char)
     2651                   (maybe-emit-clear-values arg1 arg2)))
    24222652             (emit-invokevirtual +lisp-object+ "eql" '(:char) :boolean)
    24232653             'ifeq)
    24242654            ((eq type1 'CHARACTER)
    2425              (compile-forms-and-maybe-emit-clear-values arg1 'stack :char
    2426                                                         arg2 'stack nil)
     2655             (with-operand-accumulation
     2656                  ((compile-operand arg1 :char)
     2657                   (compile-operand arg2 nil)
     2658                   (maybe-emit-clear-values arg1 arg2)))
    24272659             (emit 'swap)
    24282660             (emit-invokevirtual +lisp-object+ "eql" '(:char) :boolean)
    24292661             'ifeq)
    24302662            ((fixnum-type-p type2)
    2431              (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    2432                                                         arg2 'stack :int)
     2663             (with-operand-accumulation
     2664                  ((compile-operand arg1 nil)
     2665                   (compile-operand arg2 :int)
     2666                   (maybe-emit-clear-values arg1 arg2)))
    24332667             (emit-invokevirtual +lisp-object+ "eql" '(:int) :boolean)
    24342668             'ifeq)
    24352669            ((fixnum-type-p type1)
    2436              (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    2437                                                         arg2 'stack nil)
     2670             (with-operand-accumulation
     2671                  ((compile-operand arg1 :int)
     2672                   (compile-operand arg2 nil)
     2673                   (maybe-emit-clear-values arg1 arg2)))
    24382674             (emit 'swap)
    24392675             (emit-invokevirtual +lisp-object+ "eql" '(:int) :boolean)
    24402676             'ifeq)
    24412677            (t
    2442              (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    2443                                                         arg2 'stack nil)
     2678             (with-operand-accumulation
     2679                  ((compile-operand arg1 nil)
     2680                   (compile-operand arg2 nil)
     2681                   (maybe-emit-clear-values arg1 arg2)))
    24442682             (emit-invokevirtual +lisp-object+ "eql"
    24452683                                 (lisp-object-arg-types 1) :boolean)
     
    24552693           (arg2 (%caddr form)))
    24562694      (cond ((fixnum-type-p (derive-compiler-type arg2))
    2457              (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    2458                                                         arg2 'stack :int)
     2695             (with-operand-accumulation
     2696                  ((compile-operand arg1 nil)
     2697                   (compile-operand arg2 :int)
     2698                   (maybe-emit-clear-values arg1 arg2)))
    24592699             (emit-invokevirtual +lisp-object+
    24602700                                 translated-op
    24612701                                 '(:int) :boolean))
    24622702            (t
    2463              (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    2464                                                         arg2 'stack nil)
     2703             (with-operand-accumulation
     2704                  ((compile-operand arg1 nil)
     2705                   (compile-operand arg2 nil)
     2706                   (maybe-emit-clear-values arg1 arg2)))
    24652707             (emit-invokevirtual +lisp-object+
    24662708                                 translated-op
     
    24722714    (let ((arg1 (%cadr form))
    24732715          (arg2 (%caddr form)))
    2474       (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    2475                                                  arg2 'stack nil)
     2716      (with-operand-accumulation
     2717                  ((compile-operand arg1 nil)
     2718                   (compile-operand arg2 nil)
     2719                   (maybe-emit-clear-values arg1 arg2)))
    24762720      (emit-invokevirtual +lisp-object+ "typep"
    24772721                          (lisp-object-arg-types 1) +lisp-object+)
     
    24832727    (let ((arg1 (%cadr form))
    24842728          (arg2 (%caddr form)))
    2485       (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    2486                                                  arg2 'stack nil)
     2729      (with-operand-accumulation
     2730                  ((compile-operand arg1 nil)
     2731                   (compile-operand arg2 nil)
     2732                   (maybe-emit-clear-values arg1 arg2)))
    24872733      (emit-invokestatic +lisp+ "memq"
    24882734                         (lisp-object-arg-types 2) :boolean)
     
    24932739    (let ((arg1 (%cadr form))
    24942740          (arg2 (%caddr form)))
    2495       (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    2496                                                  arg2 'stack nil)
     2741      (with-operand-accumulation
     2742                  ((compile-operand arg1 nil)
     2743                   (compile-operand arg2 nil)
     2744                   (maybe-emit-clear-values arg1 arg2)))
    24972745      (emit-invokestatic +lisp+ "memql"
    24982746                         (lisp-object-arg-types 2) :boolean)
     
    25092757            ((and (fixnum-type-p type1)
    25102758                  (fixnum-type-p type2))
    2511              (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    2512                                                         arg2 'stack :int)
     2759             (with-operand-accumulation
     2760                 ((compile-operand arg1 :int)
     2761                  (compile-operand arg2 :int)
     2762                  (maybe-emit-clear-values arg1 arg2)))
    25132763             'if_icmpeq)
    25142764            ((fixnum-type-p type2)
    2515              (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    2516                                                         arg2 'stack :int)
     2765             (with-operand-accumulation
     2766                 ((compile-operand arg1 nil)
     2767                  (compile-operand arg2 :int)
     2768                  (maybe-emit-clear-values arg1 arg2)))
    25172769             (emit-invokevirtual +lisp-object+ "isNotEqualTo" '(:int) :boolean)
    25182770             'ifeq)
     
    25202772             ;; FIXME Compile the args in reverse order and avoid the swap if
    25212773             ;; either arg is a fixnum or a lexical variable.
    2522              (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    2523                                                         arg2 'stack nil)
     2774             (with-operand-accumulation
     2775                 ((compile-operand arg1 :int)
     2776                  (compile-operand arg2 nil)
     2777                  (maybe-emit-clear-values arg1 arg2)))
    25242778             (emit 'swap)
    25252779             (emit-invokevirtual +lisp-object+ "isNotEqualTo" '(:int) :boolean)
    25262780             'ifeq)
    25272781            (t
    2528              (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    2529                                                         arg2 'stack nil)
     2782             (with-operand-accumulation
     2783                 ((compile-operand arg1 nil)
     2784                  (compile-operand arg2 nil)
     2785                  (maybe-emit-clear-values arg1 arg2)))
    25302786             (emit-invokevirtual +lisp-object+ "isNotEqualTo"
    25312787                                 (lisp-object-arg-types 1) :boolean)
     
    25442800               (if (funcall op arg1 arg2) :consequent :alternate))
    25452801              ((and (fixnum-type-p type1) (fixnum-type-p type2))
    2546                (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    2547                                                           arg2 'stack :int)
     2802               (with-operand-accumulation
     2803                 ((compile-operand arg1 :int)
     2804                  (compile-operand arg2 :int)
     2805                  (maybe-emit-clear-values arg1 arg2)))
    25482806               (ecase op
    25492807                 (<  'if_icmpge)
     
    25532811                 (=  'if_icmpne)))
    25542812              ((and (java-long-type-p type1) (java-long-type-p type2))
    2555                (compile-forms-and-maybe-emit-clear-values arg1 'stack :long
    2556                                                           arg2 'stack :long)
     2813               (with-operand-accumulation
     2814                 ((compile-operand arg1 :long)
     2815                  (compile-operand arg2 :long)
     2816                  (maybe-emit-clear-values arg1 arg2)))
    25572817               (emit 'lcmp)
    25582818               (ecase op
     
    25632823                 (=  'ifne)))
    25642824              ((fixnum-type-p type2)
    2565                (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    2566                                                           arg2 'stack :int)
     2825               (with-operand-accumulation
     2826                 ((compile-operand arg1 nil)
     2827                  (compile-operand arg2 :int)
     2828                  (maybe-emit-clear-values arg1 arg2)))
    25672829               (emit-invokevirtual +lisp-object+
    25682830                                   (ecase op
     
    25772839               ;; FIXME We can compile the args in reverse order and avoid
    25782840               ;; the swap if either arg is a fixnum or a lexical variable.
    2579                (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    2580                                                           arg2 'stack nil)
     2841               (with-operand-accumulation
     2842                 ((compile-operand arg1 :int)
     2843                  (compile-operand arg2 nil)
     2844                  (maybe-emit-clear-values arg1 arg2)))
    25812845               (emit 'swap)
    25822846               (emit-invokevirtual +lisp-object+
     
    25902854               'ifeq)
    25912855              (t
    2592                (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    2593                                                           arg2 'stack nil)
     2856               (with-operand-accumulation
     2857                 ((compile-operand arg1 nil)
     2858                  (compile-operand arg2 nil)
     2859                  (maybe-emit-clear-values arg1 arg2)))
    25942860               (emit-invokevirtual +lisp-object+
    25952861                                   (ecase op
     
    26222888                  (let ((arg1 (second arg))
    26232889                        (arg2 (third arg)))
    2624                     (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    2625                                                                arg2 'stack nil)
     2890                    (with-operand-accumulation
     2891                         ((compile-operand arg1 nil)
     2892                          (compile-operand arg2 nil)
     2893                          (maybe-emit-clear-values arg1 arg2)))
    26262894                    (emit 'if_acmpeq LABEL1)))
    26272895                 ((eq (derive-compiler-type arg) 'BOOLEAN)
     
    27423010  (let ((first-subform (cadr form))
    27433011        (subforms (cddr form))
    2744         (result-register (allocate-register))
    2745         (values-register (allocate-register)))
     3012        (result-register (allocate-register nil))
     3013        (values-register (allocate-register nil)))
    27463014    ;; Make sure there are no leftover values from previous calls.
    27473015    (emit-clear-values)
     
    27743042    (3
    27753043     (let* ((*register* *register*)
    2776             (function-register (allocate-register)))
     3044            (function-register (allocate-register nil)))
    27773045       (compile-form (second form) function-register nil)
    27783046       (compile-form (third form) 'stack nil)
     
    27853053     ;; The general case.
    27863054     (let* ((*register* *register*)
    2787             (function-register (allocate-register))
    2788             (values-register (allocate-register)))
     3055            (function-register (allocate-register nil))
     3056            (values-register (allocate-register nil)))
    27893057       (compile-form (second form) 'stack nil)
    27903058       (emit-invokestatic +lisp+ "coerceToFunction"
     
    29043172
    29053173(defun restore-environment-and-make-handler (register label-START)
    2906   (let ((label-END (gensym))
    2907         (label-EXIT (gensym)))
     3174  (let ((label-END (gensym "U"))
     3175        (label-EXIT (gensym "E")))
    29083176    (emit 'goto label-EXIT)
    29093177    (label label-END)
     
    29223190         (bind-special-p nil)
    29233191         (variables (m-v-b-vars block))
    2924          (label-START (gensym)))
     3192         (label-START (gensym "F")))
    29253193    (dolist (variable variables)
    29263194      (let ((special-p (variable-special-p variable)))
     
    29293197              (t
    29303198               (unless (variable-closure-index variable)
    2931                  (setf (variable-register variable) (allocate-register)))))))
     3199                 (setf (variable-register variable)
     3200                       (allocate-register nil)))))))
    29323201    ;; If we're going to bind any special variables...
    29333202    (when bind-special-p
    29343203      (dformat t "p2-m-v-b-node lastSpecialBinding~%")
    29353204      ;; Save current dynamic environment.
    2936       (setf (m-v-b-environment-register block) (allocate-register))
     3205      (setf (m-v-b-environment-register block) (allocate-register nil))
    29373206      (save-dynamic-environment (m-v-b-environment-register block))
    29383207      (label label-START))
     
    29463215          (t
    29473216           (let* ((*register* *register*)
    2948                   (result-register (allocate-register))
    2949                   (values-register (allocate-register))
     3217                  (result-register (allocate-register nil))
     3218                  (values-register (allocate-register nil))
    29503219                  (LABEL1 (gensym))
    29513220                  (LABEL2 (gensym)))
     
    31023371(defun allocate-variable-register (variable)
    31033372  (setf (variable-register variable)
    3104         (if (= 2 (representation-size (variable-representation variable)))
    3105             (allocate-register-pair)
    3106             (allocate-register))))
     3373        (allocate-register (variable-representation variable))))
    31073374
    31083375(defun emit-move-to-variable (variable)
     
    32143481               (when (variable-special-p variable)
    32153482                 (setf (variable-binding-register variable)
    3216                        (allocate-register)))
     3483                       (allocate-register nil)))
    32173484               (cond ((variable-special-p variable)
    3218                       (let ((temp-register (allocate-register)))
     3485                      (let ((temp-register (allocate-register nil)))
    32193486                        ;; FIXME: this permanently allocates a register
    32203487                        ;; which has only a single local use
     
    32783545                             (eq (variable-declared-type variable) 'BOOLEAN))
    32793546                        (setf (variable-representation variable) :boolean)
    3280                         (setf (variable-register variable) (allocate-register))
     3547                        (setf (variable-register variable)
     3548                              (allocate-register nil))
    32813549                        (emit 'iconst_0)
    32823550                        (emit 'istore (variable-register variable))
     
    33083576          (unless (or (variable-closure-index variable)
    33093577                      (variable-register variable))
    3310             (setf (variable-register variable) (allocate-register))))
     3578            (setf (variable-register variable)
     3579                  (allocate-register nil))))
    33113580        (push variable *visible-variables*)
    33123581        (unless boundp
    33133582          (when (variable-special-p variable)
    3314             (setf (variable-binding-register variable) (allocate-register)))
     3583            (setf (variable-binding-register variable)
     3584                  (allocate-register nil)))
    33153585          (compile-binding variable))
    33163586        (maybe-generate-type-check variable)))
     
    33253595         (*visible-variables* *visible-variables*)
    33263596         (specialp nil)
    3327          (label-START (gensym)))
     3597         (label-START (gensym "F")))
    33283598    ;; Walk the variable list looking for special bindings and unused lexicals.
    33293599    (dolist (variable (let-vars block))
     
    33353605    (when specialp
    33363606      ;; We need to save current dynamic environment.
    3337       (setf (let-environment-register block) (allocate-register))
     3607      (setf (let-environment-register block) (allocate-register nil))
    33383608      (save-dynamic-environment (let-environment-register block))
    33393609      (label label-START))
     
    33723642         (form (tagbody-form block))
    33733643         (body (cdr form))
    3374          (BEGIN-BLOCK (gensym))
    3375          (END-BLOCK (gensym))
    3376          (RETHROW (gensym))
    3377          (EXIT (gensym))
     3644         (BEGIN-BLOCK (gensym "F"))
     3645         (END-BLOCK (gensym "U"))
     3646         (RETHROW (gensym "T"))
     3647         (EXIT (gensym "E"))
    33783648         (must-clear-values nil)
    33793649         (specials-register (when (tagbody-non-local-go-p block)
    3380                               (allocate-register))))
     3650                              (allocate-register nil))))
    33813651    ;; Scan for tags.
    33823652    (dolist (tag (tagbody-tags block))
     
    34123682    (when (tagbody-non-local-go-p block)
    34133683      ; We need a handler to catch non-local GOs.
    3414       (let* ((HANDLER (gensym))
    3415              (EXTENT-EXIT-HANDLER (gensym))
     3684      (let* ((HANDLER (gensym "H"))
     3685             (EXTENT-EXIT-HANDLER (gensym "HE"))
    34163686             (*register* *register*)
    3417              (go-register (allocate-register))
    3418              (tag-register (allocate-register)))
     3687             (go-register (allocate-register nil))
     3688             (tag-register (allocate-register nil)))
    34193689        (label HANDLER)
    34203690        ;; The Go object is on the runtime stack. Stack depth is 1.
     
    34663736  ;; FIXME What if we're called with a non-NIL representation?
    34673737  (declare (ignore target representation))
    3468   (let* ((name (cadr form))
    3469          (tag (find-tag name))
    3470          (tag-block (when tag (tag-block tag))))
     3738  (let* ((node form)
     3739         (form (node-form form))
     3740         (name (cadr form))
     3741         (tag (jump-target-tag node))
     3742         (tag-block (when tag (jump-target-block node))))
    34713743    (unless tag
    34723744      (error "p2-go: tag not found: ~S" name))
     
    35723844  (let* ((*blocks* (cons block *blocks*))
    35733845         (*register* *register*)
    3574          (BEGIN-BLOCK (gensym))
    3575          (END-BLOCK (gensym))
     3846         (BEGIN-BLOCK (gensym "F"))
     3847         (END-BLOCK (gensym "U"))
    35763848         (BLOCK-EXIT (block-exit block))
    35773849         (specials-register (when (block-non-local-return-p block)
    3578                               (allocate-register))))
     3850                              (allocate-register nil))))
    35793851    (setf (block-target block) target)
    35803852    (when (block-id-variable block)
     
    35963868      ;; We need a handler to catch non-local RETURNs.
    35973869      (emit 'goto BLOCK-EXIT) ; Jump over handler, when inserting one
    3598       (let ((HANDLER (gensym))
    3599             (EXTENT-EXIT-HANDLER (gensym))
     3870      (let ((HANDLER (gensym "H"))
     3871            (EXTENT-EXIT-HANDLER (gensym "HE"))
    36003872            (THIS-BLOCK (gensym)))
    36013873        (label HANDLER)
     
    36323904  ;; FIXME What if we're called with a non-NIL representation?
    36333905  (declare (ignore target representation))
    3634   (let* ((name (second form))
     3906  (let* ((node form)
     3907         (form (node-form form))
     3908         (name (second form))
    36353909         (result-form (third form))
    3636          (block (find-block name)))
     3910         (block (jump-target-block node)))
    36373911    (when (null block)
    36383912      (error "No block named ~S is currently visible." name))
     
    36523926    ;; Non-local RETURN.
    36533927    (aver (block-non-local-return-p block))
    3654     (emit-push-variable (block-id-variable block))
    3655     (emit-load-externalized-object (block-name block))
    36563928    (emit-clear-values)
    3657     (compile-form result-form 'stack nil)
    3658     (emit-invokestatic +lisp+ "nonLocalReturn" (lisp-object-arg-types 3)
    3659                        +lisp-object+)
     3929    (with-operand-accumulation
     3930         ((emit-variable-operand (block-id-variable block))
     3931    (emit-load-externalized-object-operand (block-name block))
     3932    (compile-operand result-form nil))
     3933       (emit-invokestatic +lisp+ "nonLocalReturn" (lisp-object-arg-types 3)
     3934        +lisp-object+))
    36603935    ;; Following code will not be reached, but is needed for JVM stack
    36613936    ;; consistency.
     
    36843959(define-inlined-function p2-cons (form target representation)
    36853960  ((check-arg-count form 2))
    3686   (emit-new +lisp-cons+)
    3687   (emit 'dup)
    36883961  (let* ((args (%cdr form))
    36893962         (arg1 (%car args))
    3690          (arg2 (%cadr args)))
    3691     (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    3692                                                arg2 'stack nil))
    3693   (emit-invokespecial-init +lisp-cons+ (lisp-object-arg-types 2))
    3694   (emit-move-from-stack target))
     3963         (arg2 (%cadr args))
     3964         (cons-register (when (some-nested-block #'node-opstack-unsafe-p
     3965                                                 (find-enclosed-blocks args))
     3966                          (allocate-register nil))))
     3967    (emit-new +lisp-cons+)
     3968    (if cons-register
     3969        (astore cons-register)
     3970      (emit 'dup))
     3971    (with-operand-accumulation
     3972        ((when cons-register
     3973           (emit-register-operand cons-register nil))
     3974         (compile-operand arg1 nil)
     3975         (compile-operand arg2 nil)
     3976         (maybe-emit-clear-values arg1 arg2)))
     3977    (emit-invokespecial-init +lisp-cons+ (lisp-object-arg-types 2))
     3978    (when cons-register
     3979      (emit-push-register cons-register nil))
     3980    (emit-move-from-stack target)))
    36953981
    36963982(defun compile-progn (form target representation)
     
    37224008         (*register* *register*)
    37234009         (environment-register
    3724           (setf (progv-environment-register block) (allocate-register)))
    3725          (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)
     4010          (setf (progv-environment-register block) (allocate-register nil)))
     4011         (label-START (gensym "F")))
     4012    (with-operand-accumulation
     4013        ((compile-operand symbols-form nil)
     4014   (compile-operand values-form nil))
     4015      (unless (and (single-valued-p symbols-form)
     4016       (single-valued-p values-form))
     4017  (emit-clear-values))
     4018      (save-dynamic-environment environment-register)
     4019      (label label-START)
     4020      ;; Compile call to Lisp.progvBindVars().
     4021      (emit-push-current-thread)
     4022      (emit-invokestatic +lisp+ "progvBindVars"
     4023       (list +lisp-object+ +lisp-object+ +lisp-thread+) nil))
    37374024      ;; Implicit PROGN.
    37384025    (let ((*blocks* (cons block *blocks*)))
     
    37634050(define-inlined-function p2-rplacd (form target representation)
    37644051  ((check-arg-count form 2))
    3765   (let ((args (cdr form)))
    3766     (compile-form (first args) 'stack nil)
    3767     (when target
    3768       (emit 'dup))
    3769     (compile-form (second args) 'stack nil)
     4052  (let* ((args (cdr form))
     4053         (*register* *register*)
     4054         (target-register (allocate-register nil)))
     4055    (with-operand-accumulation
     4056        ((accumulate-operand (nil
     4057                              :unsafe-p (some-nested-block
     4058                                         #'node-opstack-unsafe-p
     4059                                         (find-enclosed-blocks (first args))))
     4060          (compile-form (first args) 'stack nil)
     4061          (when target-register
     4062            (emit 'dup)
     4063            (astore target-register)))
     4064         (compile-operand (second args) nil)))
     4065    (maybe-emit-clear-values (car args) (cadr args))
    37704066    (emit-invokevirtual +lisp-object+
    37714067                        "setCdr"
    37724068                        (lisp-object-arg-types 1)
    37734069                        nil)
    3774     (when target
     4070    (when target-register
     4071      (aload target-register)
    37754072      (fix-boxing representation nil)
    37764073      (emit-move-from-stack target representation))))
     
    37784075(define-inlined-function p2-set-car/cdr (form target representation)
    37794076  ((check-arg-count form 2))
    3780   (let ((op (%car form))
    3781         (args (%cdr form)))
    3782     (compile-form (%car args) 'stack nil)
    3783     (compile-form (%cadr args) 'stack nil)
    3784     (when target
    3785       (emit-dup nil :past nil))
     4077  (let* ((op (%car form))
     4078         (args (%cdr form))
     4079         (*register* *register*)
     4080         (target-register (when target (allocate-register nil))))
     4081    (with-operand-accumulation
     4082         ((compile-operand (%car args) nil)
     4083          (accumulate-operand (nil
     4084                               :unsafe-p (some-nested-block
     4085                                          #'node-opstack-unsafe-p
     4086                                          (find-enclosed-blocks (cadr args))))
     4087           (compile-form (%cadr args) 'stack nil)
     4088           (when target-register
     4089             (emit 'dup)
     4090             (astore target-register)))
     4091          (maybe-emit-clear-values (car args) (cadr args))))
    37864092    (emit-invokevirtual +lisp-object+
    37874093                        (if (eq op 'sys:set-car) "setCar" "setCdr")
    37884094                        (lisp-object-arg-types 1)
    37894095                        nil)
    3790     (when target
     4096    (when target-register
     4097      (aload target-register)
    37914098      (fix-boxing representation nil)
    37924099      (emit-move-from-stack target representation))))
     
    38994206        (aver (null (variable-register variable)))
    39004207        (unless (variable-closure-index variable)
    3901           (setf (variable-register variable) (allocate-register)))))
     4208          (setf (variable-register variable) (allocate-register nil)))))
    39024209    (dolist (local-function local-functions)
    39034210      (p2-labels-process-compiland local-function))
     
    41314438                                                           arg2 target representation))
    41324439               ((eql (fixnum-constant-value type2) -1)
    4133                 (compile-forms-and-maybe-emit-clear-values arg1 target representation
    4134                                                            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)))
    41354452               ((and (fixnum-type-p type1) (fixnum-type-p type2))
    41364453                ;; Both arguments are fixnums.
    4137                 (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    4138                                                            arg2 'stack :int)
     4454                (with-operand-accumulation
     4455                    ((compile-operand arg1 :int)
     4456                     (compile-operand arg2 :int)
     4457                     (maybe-emit-clear-values arg1 arg2)))
    41394458                (emit 'iand)
    41404459                (convert-representation :int representation)
     
    41454464                         (compiler-subtypep type2 'unsigned-byte)))
    41464465                ;; One of the arguments is a positive fixnum.
    4147                 (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    4148                                                            arg2 'stack :int)
     4466                (with-operand-accumulation
     4467                    ((compile-operand arg1 :int)
     4468                     (compile-operand arg2 :int)
     4469                     (maybe-emit-clear-values arg1 arg2)))
    41494470                (emit 'iand)
    41504471                (convert-representation :int representation)
     
    41524473               ((and (java-long-type-p type1) (java-long-type-p type2))
    41534474                ;; Both arguments are longs.
    4154                 (compile-forms-and-maybe-emit-clear-values arg1 'stack :long
    4155                                                            arg2 'stack :long)
     4475                (with-operand-accumulation
     4476                    ((compile-operand arg1 :long)
     4477                     (compile-operand arg2 :long)
     4478                     (maybe-emit-clear-values arg1 arg2)))
    41564479                (emit 'land)
    41574480                (convert-representation :long representation)
     
    41624485                         (compiler-subtypep type2 'unsigned-byte)))
    41634486                ;; One of the arguments is a positive long.
    4164                 (compile-forms-and-maybe-emit-clear-values arg1 'stack :long
    4165                                                            arg2 'stack :long)
     4487                (with-operand-accumulation
     4488                    ((compile-operand arg1 :long)
     4489                     (compile-operand arg2 :long)
     4490                     (maybe-emit-clear-values arg1 arg2)))
    41664491                (emit 'land)
    41674492                (convert-representation :long representation)
    41684493                (emit-move-from-stack target representation))
    41694494               ((fixnum-type-p type2)
    4170                 (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    4171                                                            arg2 'stack :int)
     4495                (with-operand-accumulation
     4496                    ((compile-operand arg1 nil)
     4497                     (compile-operand arg2 :int)
     4498                     (maybe-emit-clear-values arg1 arg2)))
    41724499                (emit-invokevirtual +lisp-object+ "LOGAND" '(:int) +lisp-object+)
    41734500                (fix-boxing representation result-type)
     
    41754502               ((fixnum-type-p type1)
    41764503                ;; arg1 is a fixnum, but arg2 is not
    4177                 (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    4178                                                            arg2 'stack nil)
     4504                (with-operand-accumulation
     4505                    ((compile-operand arg1 :int)
     4506                     (compile-operand arg2 nil)
     4507                     (maybe-emit-clear-values arg1 arg2)))
    41794508                ;; swap args
    41804509                (emit 'swap)
     
    41834512                (emit-move-from-stack target representation))
    41844513               (t
    4185                 (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    4186                                                            arg2 'stack nil)
     4514                (with-operand-accumulation
     4515                    ((compile-operand arg1 nil)
     4516                     (compile-operand arg2 nil)
     4517                     (maybe-emit-clear-values arg1 arg2)))
    41874518                (emit-invokevirtual +lisp-object+ "LOGAND"
    41884519                                    (lisp-object-arg-types 1) +lisp-object+)
     
    42154546               result-type (derive-compiler-type form))
    42164547         (cond ((and (fixnum-constant-value type1) (fixnum-constant-value type2))
    4217                 (compile-forms-and-maybe-emit-clear-values arg1 nil nil
    4218                                                            arg2 nil nil)
    42194548                (compile-constant (logior (fixnum-constant-value type1)
    42204549                                          (fixnum-constant-value type2))
    42214550                                  target representation))
    42224551               ((and (fixnum-type-p type1) (fixnum-type-p type2))
    4223                 (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    4224                                                            arg2 'stack :int)
     4552                (with-operand-accumulation
     4553                    ((compile-operand arg1 :int)
     4554                     (compile-operand arg2 :int)
     4555                     (maybe-emit-clear-values arg1 arg2)))
    42254556                (emit 'ior)
    42264557                (convert-representation :int representation)
     
    42304561                                                           arg2 target representation))
    42314562               ((and (eql (fixnum-constant-value type2) 0) (< *safety* 3))
    4232                 (compile-forms-and-maybe-emit-clear-values arg1 target representation
    4233                                                            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)))
    42344575               ((or (eq representation :long)
    42354576                    (and (java-long-type-p type1) (java-long-type-p type2)))
    4236                 (compile-forms-and-maybe-emit-clear-values arg1 'stack :long
    4237                                                            arg2 'stack :long)
     4577                (with-operand-accumulation
     4578                    ((compile-operand arg1 :long)
     4579                     (compile-operand arg2 :long)
     4580                     (maybe-emit-clear-values arg1 arg2)))
    42384581                (emit 'lor)
    42394582                (convert-representation :long representation)
    42404583                (emit-move-from-stack target representation))
    42414584               ((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)))
    42424589                (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    42434590                                                           arg2 'stack :int)
     
    42474594               ((fixnum-type-p type1)
    42484595                ;; arg1 is of fixnum type, but arg2 is not
    4249                 (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    4250                                                            arg2 'stack nil)
     4596                (with-operand-accumulation
     4597                    ((compile-operand arg1 :int)
     4598                     (compile-operand arg2 nil)
     4599                     (maybe-emit-clear-values arg1 arg2)))
    42514600                ;; swap args
    42524601                (emit 'swap)
     
    42554604                (emit-move-from-stack target representation))
    42564605               (t
    4257                 (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    4258                                                            arg2 'stack nil)
     4606                (with-operand-accumulation
     4607                    ((compile-operand arg1 nil)
     4608                     (compile-operand arg2 nil)
     4609                     (maybe-emit-clear-values arg1 arg2)))
    42594610                (emit-invokevirtual +lisp-object+ "LOGIOR"
    42604611                                    (lisp-object-arg-types 1) +lisp-object+)
     
    42894640               type2       (derive-compiler-type arg2)
    42904641               result-type (derive-compiler-type form))
    4291          (cond ((eq representation :int)
    4292                 (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    4293                                                            arg2 'stack :int)
    4294                 (emit 'ixor))
    4295                ((and (fixnum-type-p type1) (fixnum-type-p type2))
    4296                 (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    4297                                                            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)))
    42984648                (emit 'ixor)
    42994649                (convert-representation :int representation))
    43004650               ((and (java-long-type-p type1) (java-long-type-p type2))
    4301                 (compile-forms-and-maybe-emit-clear-values arg1 'stack :long
    4302                                                            arg2 'stack :long)
     4651                (with-operand-accumulation
     4652                    ((compile-operand arg1 :long)
     4653                     (compile-operand arg2 :long)
     4654                     (maybe-emit-clear-values arg1 arg2)))
    43034655                (emit 'lxor)
    43044656                (convert-representation :long representation))
    43054657               ((fixnum-type-p type2)
    4306                 (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    4307                                                            arg2 'stack :int)
     4658                (with-operand-accumulation
     4659                    ((compile-operand arg1 nil)
     4660                     (compile-operand arg2 :int)
     4661                     (maybe-emit-clear-values arg1 arg2)))
    43084662                (emit-invokevirtual +lisp-object+ "LOGXOR" '(:int) +lisp-object+)
    43094663                (fix-boxing representation result-type))
    43104664               (t
    4311                 (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    4312                                                            arg2 'stack nil)
     4665                (with-operand-accumulation
     4666                    ((compile-operand arg1 nil)
     4667                     (compile-operand arg2 nil)
     4668                     (maybe-emit-clear-values arg1 arg2)))
    43134669                (emit-invokevirtual +lisp-object+ "LOGXOR"
    43144670                                    (lisp-object-arg-types 1) +lisp-object+)
     
    43954751          ((and (fixnum-type-p size-type)
    43964752                (fixnum-type-p position-type))
    4397            (compile-forms-and-maybe-emit-clear-values size-arg 'stack :int
    4398                                                       position-arg 'stack :int
    4399                                                       arg3 'stack nil)
     4753           (with-operand-accumulation
     4754                ((compile-operand size-arg :int)
     4755                 (compile-operand position-arg :int)
     4756                 (compile-operand arg3 nil)
     4757                 (maybe-emit-clear-values size-arg position-arg arg3)))
    44004758           (emit 'dup_x2) ;; use not supported by emit-dup: 3 values involved
    44014759           (emit 'pop)
     
    44174775                (fixnum-type-p type1)
    44184776                (fixnum-type-p type2))
    4419            (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    4420                                                       arg2 'stack :int)
     4777           (with-operand-accumulation
     4778               ((compile-operand arg1 :int)
     4779                (compile-operand arg2 :int)
     4780                (maybe-emit-clear-values arg1 arg2)))
    44214781           (emit-invokestatic +lisp+ "mod" '(:int :int) :int)
    44224782           (emit-move-from-stack target representation))
    44234783          ((fixnum-type-p type2)
    4424            (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    4425                                                       arg2 'stack :int)
     4784           (with-operand-accumulation
     4785               ((compile-operand arg1 nil)
     4786                (compile-operand arg2 :int)
     4787                (maybe-emit-clear-values arg1 arg2)))
    44264788           (emit-invokevirtual +lisp-object+ "MOD" '(:int) +lisp-object+)
    44274789           (fix-boxing representation nil) ; FIXME use derived result type
    44284790           (emit-move-from-stack target representation))
    44294791          (t
    4430            (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    4431                                                       arg2 'stack nil)
     4792           (with-operand-accumulation
     4793               ((compile-operand arg1 nil)
     4794                (compile-operand arg2 nil)
     4795                (maybe-emit-clear-values arg1 arg2)))
    44324796           (emit-invokevirtual +lisp-object+ "MOD"
    44334797                               (lisp-object-arg-types 1) +lisp-object+)
     
    45044868      (2
    45054869       (let ((arg2 (second args)))
    4506          (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    4507                                                     arg2 'stack :boolean)
     4870         (with-operand-accumulation
     4871             ((compile-operand arg1 nil)
     4872              (compile-operand arg2 :boolean)
     4873              (maybe-emit-clear-values arg1 arg2)))
    45084874         (emit-invokestatic +lisp-class+ "findClass"
    45094875                            (list +lisp-object+ :boolean) +lisp-object+)
     
    45214887    (case arg-count
    45224888      (2
    4523        (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    4524                                                   arg2 'stack nil)
     4889       (with-operand-accumulation
     4890           ((compile-operand arg1 nil)
     4891            (compile-operand arg2 nil)))
     4892       (maybe-emit-clear-values arg1 arg2)
    45254893       (emit 'swap)
    45264894       (cond (target
     
    45414909         (arg1 (first args))
    45424910         (arg2 (second args)))
    4543     (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    4544                                                arg2 'stack nil)
     4911    (with-operand-accumulation
     4912        ((compile-operand arg1 nil)
     4913         (compile-operand arg2 nil)))
     4914    (maybe-emit-clear-values arg1 arg2)
    45454915    (emit-invokevirtual +lisp-object+ "SLOT_VALUE"
    45464916                        (lisp-object-arg-types 1) +lisp-object+)
     
    45574927         (arg3 (third args))
    45584928         (*register* *register*)
    4559          (value-register (when target (allocate-register))))
    4560     (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    4561                                                arg2 'stack nil
    4562                                                arg3 'stack nil)
     4929         (value-register (when target (allocate-register nil))))
     4930    (with-operand-accumulation
     4931        ((compile-operand arg1 nil)
     4932         (compile-operand arg2 nil)
     4933         (compile-operand arg3 nil)))
    45634934    (when value-register
    45644935      (emit 'dup)
    45654936      (astore value-register))
     4937    (maybe-emit-clear-values arg1 arg2 arg3)
    45664938    (emit-invokevirtual +lisp-object+ "setSlotValue"
    45674939                        (lisp-object-arg-types 2) nil)
     
    45944966    (cond ((and (compiler-subtypep type1 '(UNSIGNED-BYTE 8))
    45954967                (eq type2 'STREAM))
    4596            (compile-form arg1 'stack :int)
    4597            (compile-form arg2 'stack nil)
    4598            (emit-checkcast +lisp-stream+)
     4968           (with-operand-accumulation
     4969               ((compile-operand arg1 :int)
     4970                (compile-operand arg2 nil +lisp-stream+)))
    45994971           (maybe-emit-clear-values arg1 arg2)
    46004972           (emit 'swap)
     
    46044976             (emit-move-from-stack target)))
    46054977          ((fixnum-type-p type1)
    4606            (compile-form arg1 'stack :int)
    4607            (compile-form arg2 'stack nil)
     4978           (with-operand-accumulation
     4979               ((compile-operand arg1 :int)
     4980                (compile-operand arg2 nil)))
    46084981           (maybe-emit-clear-values arg1 arg2)
    46094982           (emit-invokestatic +lisp+ "writeByte"
     
    51855558             (test (if (memq type1 '(SYMBOL NULL)) 'eq 'eql)))
    51865559        (cond ((subtypep type2 'VECTOR)
    5187                (compile-form arg1 'stack nil)
    5188                (compile-form arg2 'stack nil)
    5189                (emit-checkcast +lisp-abstract-vector+)
     5560               (with-operand-accumulation
     5561                    ((compile-operand arg1 nil)
     5562                     (compile-operand arg2 nil +lisp-abstract-vector+)))
    51905563               (maybe-emit-clear-values arg1 arg2)
    51915564               (emit 'swap)
     
    52275600                         (butlast args 1)
    52285601                         args)))
    5229     (cond ((>= 4 length 1)
     5602    (cond ((and (not (some-nested-block #'node-opstack-unsafe-p
     5603                                        (find-enclosed-blocks args)))
     5604                (>= 4 length 1))
    52305605           (dolist (cons-head cons-heads)
    52315606             (emit-new +lisp-cons+)
     
    52635638  (let ((index-form (second form))
    52645639        (list-form (third form)))
    5265     (compile-forms-and-maybe-emit-clear-values index-form 'stack :int
    5266                                                list-form 'stack nil)
    5267     (emit 'swap)
    5268     (emit-invokevirtual +lisp-object+ "NTH" '(:int) +lisp-object+)
     5640    (with-operand-accumulation
     5641        ((compile-operand index-form :int)
     5642         (compile-operand list-form nil)
     5643         (maybe-emit-clear-values index-form list-form))
     5644      (emit 'swap)
     5645      (emit-invokevirtual +lisp-object+ "NTH" '(:int) +lisp-object+))
    52695646    (fix-boxing representation nil) ; FIXME use derived result type
    52705647    (emit-move-from-stack target representation)))
     
    52905667              (compile-constant value target representation))
    52915668             (result-rep
    5292               (compile-forms-and-maybe-emit-clear-values
    5293                           arg1 'stack result-rep
    5294                           arg2 'stack result-rep)
    5295               (emit (case result-rep
    5296                       (:int    'imul)
    5297                       (:long   'lmul)
    5298                       (:float  'fmul)
    5299                       (:double 'dmul)
    5300                       (t
    5301                        (sys::format t "p2-times: unsupported rep case"))))
     5669              (with-operand-accumulation
     5670                   ((compile-operand arg1 result-rep)
     5671                    (compile-operand arg2 result-rep)
     5672                    (maybe-emit-clear-values arg1 arg2))
     5673                 (emit (case result-rep
     5674                          (:int    'imul)
     5675                          (:long   'lmul)
     5676                          (:float  'fmul)
     5677                          (:double 'dmul)
     5678                          (t
     5679                           (sys::format t "p2-times: unsupported rep case")))))
    53025680              (convert-representation result-rep representation)
    53035681              (emit-move-from-stack target representation))
     
    53245702              (args (%cdr form))
    53255703              (arg1 (%car args))
    5326               (arg2 (%cadr args)))
     5704              (arg2 (%cadr args))
     5705              (*register* *register*))
    53275706         (when (null target)
     5707           ;; compile for effect
    53285708           (compile-forms-and-maybe-emit-clear-values arg1 nil nil
    53295709                                                      arg2 nil nil)
     
    53355715               (type2 (derive-compiler-type arg2)))
    53365716           (cond ((and (java-long-type-p type1) (java-long-type-p type2))
    5337                   (let ((common-rep (if (and (fixnum-type-p type1)
    5338                                              (fixnum-type-p type2))
    5339                                         :int :long))
    5340                         (LABEL1 (gensym)))
    5341                     (compile-form arg1 'stack common-rep)
     5717                  (let* ((common-rep (if (and (fixnum-type-p type1)
     5718                                              (fixnum-type-p type2))
     5719                                         :int :long))
     5720                        (LABEL1 (gensym))
     5721                        (LABEL2 (gensym))
     5722                        (arg1-register (allocate-register common-rep))
     5723                        (arg2-register (allocate-register common-rep)))
     5724                    (compile-form arg1 arg1-register common-rep)
     5725                    (compile-form arg2 'stack common-rep)
    53425726                    (emit-dup common-rep)
    5343                     (compile-form arg2 'stack common-rep)
    5344                     (emit-dup common-rep :past common-rep)
     5727                    (emit-move-from-stack arg2-register common-rep)
     5728                    (emit-push-register arg1-register common-rep)
     5729                    ;; note: we've now reversed the arguments on the stack!
    53455730                    (emit-numeric-comparison (if (eq op 'max) '<= '>=)
    53465731                                             common-rep LABEL1)
    5347                     (emit-swap common-rep common-rep)
     5732                    (emit-push-register arg1-register common-rep)
     5733                    (emit 'goto LABEL2)
    53485734                    (label LABEL1)
    5349                     (emit-move-from-stack nil common-rep)
     5735                    (emit-push-register arg2-register common-rep)
     5736                    (label LABEL2)
    53505737                    (convert-representation common-rep representation)
    53515738                    (emit-move-from-stack target representation)))
    53525739                 (t
    5353                   (compile-form arg1 'stack nil)
    5354                   (emit-dup nil)
    5355                   (compile-form arg2 'stack nil)
    5356                   (emit-dup nil :past nil)
    5357                   (emit-invokevirtual +lisp-object+
    5358                                       (if (eq op 'max)
    5359                                           "isLessThanOrEqualTo"
     5740                  (let* ((arg1-register (allocate-register nil))
     5741                         (arg2-register (allocate-register nil)))
     5742                    (compile-form arg1 arg1-register nil)
     5743                    (compile-form arg2 'stack nil)
     5744                    (emit-dup nil)
     5745                    (astore arg2-register)
     5746                    (emit-push-register arg1-register nil)
     5747                    (emit-invokevirtual +lisp-object+
     5748                                        (if (eq op 'max)
     5749                                            "isLessThanOrEqualTo"
    53605750                                          "isGreaterThanOrEqualTo")
    5361                                       (lisp-object-arg-types 1) :boolean)
    5362                   (let ((LABEL1 (gensym)))
    5363                     (emit 'ifeq LABEL1)
    5364                     (emit 'swap)
    5365                     (label LABEL1)
    5366                     (emit 'pop))
    5367                   (fix-boxing representation nil)
    5368                   (emit-move-from-stack target representation))))))
     5751                                        (lisp-object-arg-types 1) :boolean)
     5752                    (let ((LABEL1 (gensym))
     5753                          (LABEL2 (gensym)))
     5754                      (emit 'ifeq LABEL1)
     5755                      (emit-push-register arg1-register nil)
     5756                      (emit 'goto LABEL2)
     5757                      (label LABEL1)
     5758                      (emit-push-register arg2-register nil)
     5759                      (label LABEL2))
     5760                    (fix-boxing representation nil)
     5761                    (emit-move-from-stack target representation)))))))
    53695762    (t
    53705763     (p2-min/max `(,(car form) (,(car form) ,(second form) ,(third form))
     
    53965789              (emit-move-from-stack target representation))
    53975790             (result-rep
    5398               (compile-forms-and-maybe-emit-clear-values
    5399                         arg1 'stack result-rep
    5400                         arg2 'stack result-rep)
    5401               (emit (case result-rep
    5402                       (:int    'iadd)
    5403                       (:long   'ladd)
    5404                       (:float  'fadd)
    5405                       (:double 'dadd)
    5406                       (t
    5407                        (sys::format
    5408                         t "p2-plus: Unexpected result-rep ~S for form ~S."
    5409                         result-rep form)
    5410                        (assert nil))))
     5791              (with-operand-accumulation
     5792                   ((compile-operand arg1 result-rep)
     5793                    (compile-operand arg2 result-rep)
     5794                    (maybe-emit-clear-values arg1 arg2))
     5795                (emit (case result-rep
     5796                        (:int    'iadd)
     5797                        (:long   'ladd)
     5798                        (:float  'fadd)
     5799                        (:double 'dadd)
     5800                        (t
     5801                         (sys::format
     5802                          t "p2-plus: Unexpected result-rep ~S for form ~S."
     5803                          result-rep form)
     5804                         (assert nil)))))
    54115805              (convert-representation result-rep representation)
    54125806              (emit-move-from-stack target representation))
     
    54185812              (emit-invoke-method "incr" target representation))
    54195813             ((or (fixnum-type-p type1) (fixnum-type-p type2))
    5420               (compile-forms-and-maybe-emit-clear-values
    5421                     arg1 'stack (when (fixnum-type-p type1) :int)
    5422                     arg2 'stack (when (null (fixnum-type-p type1)) :int))
    5423               (when (fixnum-type-p type1)
    5424                 (emit 'swap))
    5425               (emit-invokevirtual +lisp-object+ "add"
    5426                                   '(:int) +lisp-object+)
     5814              (with-operand-accumulation
     5815                   ((compile-operand arg1 (when (fixnum-type-p type1) :int))
     5816                    (compile-operand arg2 (when (null (fixnum-type-p type1))
     5817                                            :int))
     5818                    (maybe-emit-clear-values arg1 arg2))
     5819                 (when (fixnum-type-p type1)
     5820                   (emit 'swap))
     5821                 (emit-invokevirtual +lisp-object+ "add"
     5822                                     '(:int) +lisp-object+))
    54275823              (fix-boxing representation result-type)
    54285824              (emit-move-from-stack target representation))
     
    54765872              (compile-constant (- arg1 arg2) target representation))
    54775873             (result-rep
    5478               (compile-forms-and-maybe-emit-clear-values
    5479                         arg1 'stack result-rep
    5480                         arg2 'stack result-rep)
    5481               (emit (case result-rep
    5482                       (:int    'isub)
    5483                       (:long   'lsub)
    5484                       (:float  'fsub)
    5485                       (:double 'dsub)
    5486                       (t
    5487                        (sys::%format t "p2-minus sub-instruction (rep: ~S); form: ~S~%"
    5488                                      result-rep form)
    5489                        (assert nil))))
     5874              (with-operand-accumulation
     5875                  ((compile-operand arg1 result-rep)
     5876                   (compile-operand arg2 result-rep)
     5877                   (maybe-emit-clear-values arg1 arg2))
     5878                (emit (case result-rep
     5879                        (:int    'isub)
     5880                        (:long   'lsub)
     5881                        (:float  'fsub)
     5882                        (:double 'dsub)
     5883                        (t
     5884                         (sys::%format t "p2-minus sub-instruction (rep: ~S); form: ~S~%"
     5885                                       result-rep form)
     5886                         (assert nil)))))
    54905887              (convert-representation result-rep representation)
    54915888              (emit-move-from-stack target representation))
    54925889             ((fixnum-type-p type2)
    5493               (compile-forms-and-maybe-emit-clear-values
    5494                     arg1 'stack nil
    5495                     arg2 'stack :int)
    5496               (emit-invokevirtual +lisp-object+
    5497                                   "subtract"
    5498                                   '(:int) +lisp-object+)
     5890              (with-operand-accumulation
     5891                  ((compile-operand arg1 nil)
     5892                   (compile-operand arg2 :int)
     5893                   (maybe-emit-clear-values arg1 arg2))
     5894                (emit-invokevirtual +lisp-object+
     5895                                    "subtract"
     5896                                    '(:int) +lisp-object+))
    54995897              (fix-boxing representation result-type)
    55005898              (emit-move-from-stack target representation))
     
    55155913         (type1 (derive-compiler-type arg1))
    55165914         (type2 (derive-compiler-type arg2)))
    5517     (cond ((and (eq representation :char)
    5518                 (zerop *safety*))
    5519            (compile-form arg1 'stack nil)
    5520            (emit-checkcast +lisp-abstract-string+)
    5521            (compile-form arg2 'stack :int)
    5522            (maybe-emit-clear-values arg1 arg2)
    5523            (emit-invokevirtual +lisp-abstract-string+ "charAt"
    5524                                '(:int) :char)
    5525            (emit-move-from-stack target representation))
    5526           ((and (eq representation :char)
     5915    (cond ((or (and (eq representation :char)
     5916                    (zerop *safety*))
     5917               (and (eq representation :char)
    55275918                (or (eq op 'CHAR) (< *safety* 3))
    55285919                (compiler-subtypep type1 'STRING)
    5529                 (fixnum-type-p type2))
    5530            (compile-form arg1 'stack nil)
    5531            (emit-checkcast +lisp-abstract-string+)
    5532            (compile-form arg2 'stack :int)
     5920                (fixnum-type-p type2)))
     5921           (with-operand-accumulation
     5922               ((compile-operand arg1 nil +lisp-abstract-string+)
     5923                (compile-operand arg2 :int)))
    55335924           (maybe-emit-clear-values arg1 arg2)
    55345925           (emit-invokevirtual +lisp-abstract-string+ "charAt"
     
    55365927           (emit-move-from-stack target representation))
    55375928          ((fixnum-type-p type2)
    5538            (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    5539                                                       arg2 'stack :int)
     5929           (with-operand-accumulation
     5930               ((compile-operand arg1 nil)
     5931                (compile-operand arg2 :int)
     5932                (maybe-emit-clear-values arg1 arg2)))
    55405933           (emit-invokevirtual +lisp-object+
    55415934                               (symbol-name op) ;; "CHAR" or "SCHAR"
     
    55655958                (compiler-subtypep type3 'CHARACTER))
    55665959           (let* ((*register* *register*)
    5567                   (value-register (when target (allocate-register)))
     5960                  (value-register (when target (allocate-register nil)))
    55685961                  (class (if (eq op 'SCHAR)
    55695962                             +lisp-simple-string+
    55705963                             +lisp-abstract-string+)))
    5571              (compile-form arg1 'stack nil)
    5572              (emit-checkcast class)
    5573              (compile-form arg2 'stack :int)
    5574              (compile-form arg3 'stack :char)
    5575              (when target
    5576                (emit 'dup)
    5577                (emit-move-from-stack value-register :char))
     5964             (with-operand-accumulation
     5965                  ((compile-operand arg1 nil class)
     5966                   (compile-operand arg2 :int)
     5967                   (accumulate-operand (:char
     5968                                        :unsafe-p (some-nested-block
     5969                                                   #'node-opstack-unsafe-p
     5970                                                   (find-enclosed-blocks arg3)))
     5971                      (compile-form arg3 'stack :char)
     5972                      (when target
     5973                        (emit 'dup)
     5974                        (emit-move-from-stack value-register :char)))))
    55785975             (maybe-emit-clear-values arg1 arg2 arg3)
    55795976             (emit-invokevirtual class "setCharAt" '(:int :char) nil)
     
    55915988         (let ((arg1 (%cadr form))
    55925989               (arg2 (%caddr form)))
    5593            (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    5594                                                       arg2 'stack :int)
     5990           (with-operand-accumulation
     5991               ((compile-operand arg1 nil)
     5992                (compile-operand arg2 :int)))
     5993           (maybe-emit-clear-values arg1 arg2)
    55955994           (emit-invokevirtual +lisp-object+ "SVREF" '(:int) +lisp-object+)
    55965995           (fix-boxing representation nil)
     
    56056004                (arg3 (fourth form))
    56066005                (*register* *register*)
    5607                 (value-register (when target (allocate-register))))
    5608            (compile-form arg1 'stack nil) ;; vector
    5609            (compile-form arg2 'stack :int) ;; index
    5610            (compile-form arg3 'stack nil) ;; new value
     6006                (value-register (when target (allocate-register nil))))
     6007           (with-operand-accumulation
     6008               ((compile-operand arg1 nil) ;; vector
     6009                (compile-operand arg2 :int) ;; intex
     6010                (compile-operand arg3 nil) ;; new value
     6011                ))
    56116012           (when value-register
    56126013             (emit 'dup)
     
    56366037       (compile-function-call form target representation)
    56376038       (return-from p2-truncate)))
    5638     (compile-form arg1 'stack nil)
    5639     (compile-form arg2 'stack nil)
    5640     (emit-invokevirtual +lisp-object+ "truncate" (lisp-object-arg-types 1) +lisp-object+)
     6039    (with-operand-accumulation
     6040        ((compile-operand arg1 nil)
     6041         (compile-operand arg2 nil)))
     6042    (maybe-emit-clear-values arg1 arg2)
     6043    (emit-invokevirtual +lisp-object+ "truncate"
     6044                        (lisp-object-arg-types 1) +lisp-object+)
    56416045    (fix-boxing representation nil) ; FIXME use derived result type
    56426046    (emit-move-from-stack target representation)))
     
    56466050              (fixnum-type-p (derive-compiler-type (third form)))
    56476051              (neq representation :char)) ; FIXME
    5648          (compile-form (second form) 'stack nil)
    5649          (compile-form (third form) 'stack :int)
     6052         (with-operand-accumulation
     6053              ((compile-operand (second form) nil)
     6054               (compile-operand (third form) :int)
     6055               (maybe-emit-clear-values (second form) (third form))))
    56506056         (emit-invokevirtual +lisp-object+ "elt" '(:int) +lisp-object+)
    56516057         (fix-boxing representation nil) ; FIXME use derived result type
     
    56616067            (arg2 (%caddr form))
    56626068            (type1 (derive-compiler-type arg1)))
    5663        (ecase representation
    5664          (:int
    5665           (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    5666                                                      arg2 'stack :int)
    5667           (emit-invokevirtual +lisp-object+ "aref" '(:int) :int))
    5668          (:long
    5669           (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    5670                                                      arg2 'stack :int)
    5671           (emit-invokevirtual +lisp-object+ "aref_long" '(:int) :long))
    5672          (:char
    5673           (cond ((compiler-subtypep type1 'string)
    5674                  (compile-form arg1 'stack nil) ; array
    5675                  (emit-checkcast +lisp-abstract-string+)
    5676                  (compile-form arg2 'stack :int) ; index
    5677                  (maybe-emit-clear-values arg1 arg2)
    5678                  (emit-invokevirtual +lisp-abstract-string+
    5679                                      "charAt" '(:int) :char))
    5680                 (t
    5681                  (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    5682                                                             arg2 'stack :int)
    5683                  (emit-invokevirtual +lisp-object+ "AREF" '(:int) +lisp-object+)
    5684                  (emit-unbox-character))))
    5685          ((nil :float :double :boolean)
    5686           ;;###FIXME for float and double, we probably want
    5687           ;; separate java methods to retrieve the values.
    5688           (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    5689                                                      arg2 'stack :int)
    5690           (emit-invokevirtual +lisp-object+ "AREF" '(:int) +lisp-object+)
    5691           (convert-representation nil representation)))
     6069       (with-operand-accumulation
     6070            ((compile-operand arg1 nil
     6071                              (when (compiler-subtypep type1 'string)
     6072                                +lisp-abstract-string+))
     6073             (compile-operand arg2 :int)
     6074             (maybe-emit-clear-values arg1 arg2))
     6075          (ecase representation
     6076            (:int
     6077             (emit-invokevirtual +lisp-object+ "aref" '(:int) :int))
     6078            (:long
     6079             (emit-invokevirtual +lisp-object+ "aref_long" '(:int) :long))
     6080            (:char
     6081             (cond ((compiler-subtypep type1 'string)
     6082                    (emit-invokevirtual +lisp-abstract-string+
     6083                                        "charAt" '(:int) :char))
     6084                   (t
     6085                    (emit-invokevirtual +lisp-object+
     6086                                        "AREF" '(:int) +lisp-object+)
     6087                    (emit-unbox-character))))
     6088            ((nil :float :double :boolean)
     6089             ;;###FIXME for float and double, we probably want
     6090             ;; separate java methods to retrieve the values.
     6091             (emit-invokevirtual +lisp-object+ "AREF" '(:int) +lisp-object+)
     6092             (convert-representation nil representation))))
    56926093       (emit-move-from-stack target representation)))
    56936094    (t
     
    57036104                (type3 (derive-compiler-type arg3))
    57046105                (*register* *register*)
    5705                 (value-register (unless (null target) (allocate-register))))
     6106                (value-register (unless (null target) (allocate-register nil))))
     6107           (with-operand-accumulation
     6108               (
    57066109           ;; array
    5707            (compile-form arg1 'stack nil)
     6110                (compile-operand arg1 nil)
    57086111           ;; index
    5709            (compile-form arg2 'stack :int)
     6112                (compile-operand arg2 :int)
    57106113           ;; value
    5711            (cond ((fixnum-type-p type3)
    5712                   (compile-form arg3 'stack :int)
    5713                   (when value-register
    5714                     (emit 'dup)
    5715                     (emit-move-from-stack value-register :int)))
    5716                  (t
    5717                   (compile-form arg3 'stack nil)
    5718                   (when value-register
    5719                     (emit 'dup)
    5720                     (emit-move-from-stack value-register nil))))
     6114                (accumulate-operand
     6115                         ((when (fixnum-type-p type3) :int)
     6116                          :unsafe-p (some-nested-block
     6117                                     #'node-opstack-unsafe-p
     6118                                     (find-enclosed-blocks arg3)))
     6119                   (cond ((fixnum-type-p type3)
     6120                          (compile-form arg3 'stack :int)
     6121                          (when value-register
     6122                            (emit 'dup)
     6123                            (emit-move-from-stack value-register :int)))
     6124                         (t
     6125                          (compile-form arg3 'stack nil)
     6126                          (when value-register
     6127                            (emit 'dup)
     6128                            (emit-move-from-stack value-register nil)))))))
    57216129           (maybe-emit-clear-values arg1 arg2 arg3)
    57226130           (cond ((fixnum-type-p type3)
    57236131                  (emit-invokevirtual +lisp-object+ "aset" '(:int :int) nil))
    57246132                 (t
    5725                   (emit-invokevirtual +lisp-object+ "aset" (list :int +lisp-object+) nil)))
     6133                  (emit-invokevirtual +lisp-object+ "aset"
     6134                                      (list :int +lisp-object+) nil)))
    57266135           (when value-register
    57276136             (cond ((fixnum-type-p type3)
     
    57916200               (<= 0 arg2 3))
    57926201          (let* ((*register* *register*)
    5793                  (value-register (when target (allocate-register))))
    5794             (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    5795                                                        arg3 'stack nil)
     6202                 (value-register (when target (allocate-register nil))))
     6203            (with-operand-accumulation
     6204                ((compile-operand arg1 nil)
     6205                 (compile-operand arg3 nil)))
    57966206            (when value-register
    57976207              (emit 'dup)
    57986208              (astore value-register))
     6209            (maybe-emit-clear-values arg1 arg3)
    57996210            (emit-invokevirtual +lisp-object+
    58006211                                (format nil "setSlotValue_~D" arg2)
     
    58066217         ((fixnump arg2)
    58076218          (let* ((*register* *register*)
    5808                  (value-register (when target (allocate-register))))
    5809             (compile-form arg1 'stack nil)
    5810             (emit-push-constant-int arg2)
    5811             (compile-form arg3 'stack nil)
     6219                 (value-register (when target (allocate-register nil))))
     6220            (with-operand-accumulation
     6221                ((compile-operand arg1 nil)
     6222                 (compile-operand arg3 nil)))
    58126223            (maybe-emit-clear-values arg1 arg3)
    58136224            (when value-register
    58146225              (emit 'dup)
    58156226              (astore value-register))
     6227            (emit-push-constant-int arg2)
     6228            (emit 'swap)  ;; prevent the integer
     6229                          ;; from being pushed, saved and restored
    58166230            (emit-invokevirtual +lisp-object+ "setSlotValue"
    58176231                                (list :int +lisp-object+) nil)
     
    58776291         (arg2 (%cadr args)))
    58786292    (cond ((fixnum-type-p (derive-compiler-type arg1))
    5879            (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    5880                                                       arg2 'stack nil)
     6293           (with-operand-accumulation
     6294               ((compile-operand arg1 :int)
     6295                (compile-operand arg2 nil)
     6296                (maybe-emit-clear-values arg1 arg2)))
    58816297           (emit 'swap)
    58826298           (emit-invokevirtual +lisp-object+ "nthcdr" '(:int) +lisp-object+)
     
    59626378         (compile-forms-and-maybe-emit-clear-values arg target representation)))
    59636379      (2
    5964        (emit-push-current-thread)
    59656380       (let ((arg1 (%car args))
    59666381             (arg2 (%cadr args)))
    59676382         (cond ((and (eq arg1 t)
    59686383                     (eq arg2 t))
     6384                (emit-push-current-thread)
    59696385                (emit-push-t)
    59706386                (emit 'dup))
    59716387               ((and (eq arg1 nil)
    59726388                     (eq arg2 nil))
     6389                (emit-push-current-thread)
    59736390                (emit-push-nil)
    59746391                (emit 'dup))
    59756392               (t
    5976                 (compile-form arg1 'stack nil)
    5977                 (compile-form arg2 'stack nil))))
     6393                (with-operand-accumulation
     6394                   ((emit-thread-operand)
     6395                    (compile-operand arg1 nil)
     6396                    (compile-operand arg2 nil)
     6397                    (maybe-emit-clear-values arg1 arg2))))))
    59786398       (emit-invokevirtual +lisp-thread+
    59796399                           "setValues"
     
    59836403       (emit-move-from-stack target))
    59846404      ((3 4)
    5985        (emit-push-current-thread)
    5986        (dolist (arg args)
    5987          (compile-form arg 'stack nil))
     6405       (with-operand-accumulation
     6406           ((emit-thread-operand)
     6407            (dolist (arg args)
     6408              (compile-operand arg nil))))
     6409       (when (notevery #'single-valued-p args)
     6410         (emit-clear-values))
    59886411       (emit-invokevirtual +lisp-thread+
    59896412                           "setValues"
     
    60536476  (cond ((and (check-arg-count form 2)
    60546477              (eq (derive-type (%cadr form)) 'SYMBOL))
    6055          (emit-push-current-thread)
    6056          (compile-form (%cadr form) 'stack nil)
    6057          (emit-checkcast +lisp-symbol+)
    6058          (compile-form (%caddr form) 'stack nil)
     6478         (with-operand-accumulation
     6479             ((emit-thread-operand)
     6480              (compile-operand (%cadr form) nil +lisp-symbol+)
     6481              (compile-operand (%caddr form) nil)))
    60596482         (maybe-emit-clear-values (%cadr form) (%caddr form))
    60606483         (emit-invokevirtual +lisp-thread+ "setSpecialVariable"
     
    60646487        (t
    60656488         (compile-function-call form target representation))))
    6066 
    6067 (declaim (ftype (function (t) t) rewrite-setq))
    6068 (defun rewrite-setq (form)
    6069   (let ((expr (%caddr form)))
    6070     (if (unsafe-p expr)
    6071         (let ((sym (gensym)))
    6072           (list 'LET (list (list sym expr)) (list 'SETQ (%cadr form) sym)))
    6073         form)))
    60746489
    60756490(defknown p2-setq (t t t) t)
     
    60826497    (when (or (null variable)
    60836498              (variable-special-p variable))
    6084       (let ((new-form (rewrite-setq form)))
    6085         (when (neq new-form form)
    6086           (return-from p2-setq (compile-form (p1 new-form) target representation))))
    60876499      ;; We're setting a special variable.
    60886500      (cond ((and variable
     
    60916503                  (not (enclosed-by-runtime-bindings-creating-block-p
    60926504                        (variable-block variable))))
     6505             ;; choose this compilation order to prevent
     6506             ;; with-operand-accumulation
     6507             (compile-forms-and-maybe-emit-clear-values value-form 'stack nil)
     6508             (emit 'dup)
    60936509             (aload (variable-binding-register variable))
    6094              (compile-forms-and-maybe-emit-clear-values value-form 'stack nil)
    6095              (emit 'dup_x1) ;; copy past th
     6510             (emit 'swap)
    60966511             (emit-putfield +lisp-special-binding+ "value"
    60976512                   +lisp-object+))
     
    61006515                  (= (length value-form) 3)
    61016516                  (var-ref-p (third value-form))
    6102                   (eq (variable-name (var-ref-variable (third value-form))) name))
    6103              (emit-push-current-thread)
    6104              (emit-load-externalized-object name)
    6105              (compile-forms-and-maybe-emit-clear-values (second value-form) 'stack nil)
    6106              (emit-invokevirtual +lisp-thread+ "pushSpecial"
    6107                                  (list +lisp-symbol+ +lisp-object+) +lisp-object+))
     6517                  (eq (variable-name (var-ref-variable (third value-form)))
     6518                      name))
     6519             (with-operand-accumulation
     6520                 ((emit-thread-operand)
     6521                  (emit-load-externalized-object-operand name)
     6522                  (compile-operand (second value-form) nil)
     6523                  (maybe-emit-clear-values (second value-form)))
     6524                 (emit-invokevirtual +lisp-thread+ "pushSpecial"
     6525                                     (list +lisp-symbol+ +lisp-object+)
     6526                                     +lisp-object+)))
    61086527            (t
    6109              (emit-push-current-thread)
    6110              (emit-load-externalized-object name)
    6111              (compile-forms-and-maybe-emit-clear-values value-form 'stack nil)
    6112              (emit-invokevirtual +lisp-thread+ "setSpecialVariable"
    6113                                  (list +lisp-symbol+ +lisp-object+) +lisp-object+)))
     6528             (with-operand-accumulation
     6529                 ((emit-thread-operand)
     6530                  (emit-load-externalized-object-operand name)
     6531                  (compile-operand value-form nil)
     6532                  (maybe-emit-clear-values value-form))
     6533                 (emit-invokevirtual +lisp-thread+ "setSpecialVariable"
     6534                                     (list +lisp-symbol+ +lisp-object+)
     6535                                     +lisp-object+))))
    61146536      (fix-boxing representation nil)
    61156537      (emit-move-from-stack target representation)
     
    63836805        (return-from p2-char=))
    63846806      (cond ((characterp arg1)
    6385              (emit-push-constant-int (char-code arg1))
    6386              (compile-forms-and-maybe-emit-clear-values arg2 'stack :char))
     6807               ;; prevent need for with-operand-accumulation: reverse args
     6808             (compile-forms-and-maybe-emit-clear-values arg2 'stack :char)
     6809             (emit-push-constant-int (char-code arg1)))
    63876810            ((characterp arg2)
    63886811             (compile-forms-and-maybe-emit-clear-values arg1 'stack :char)
    63896812             (emit-push-constant-int (char-code arg2)))
    63906813            (t
    6391              (compile-forms-and-maybe-emit-clear-values arg1 'stack :char
    6392                                                         arg2 'stack :char)))
     6814             (with-operand-accumulation
     6815                 ((compile-operand arg1 :char)
     6816                  (compile-operand arg2 :char)
     6817                  (maybe-emit-clear-values arg1 arg2)))))
    63936818      (let ((LABEL1 (gensym))
    63946819            (LABEL2 (gensym)))
     
    64056830  (let* ((form (synchronized-form block))
    64066831         (*register* *register*)
    6407          (object-register (allocate-register))
    6408          (BEGIN-PROTECTED-RANGE (gensym))
    6409          (END-PROTECTED-RANGE (gensym))
    6410          (EXIT (gensym)))
     6832         (object-register (allocate-register nil))
     6833         (BEGIN-PROTECTED-RANGE (gensym "F"))
     6834         (END-PROTECTED-RANGE (gensym "U"))
     6835         (EXIT (gensym "E")))
    64116836    (compile-form (cadr form) 'stack nil)
    64126837    (emit-invokevirtual +lisp-object+ "lockableInstance" nil
     
    64416866      (return-from p2-catch-node))
    64426867    (let* ((*register* *register*)
    6443            (tag-register (allocate-register))
    6444            (BEGIN-PROTECTED-RANGE (gensym))
    6445            (END-PROTECTED-RANGE (gensym))
    6446            (THROW-HANDLER (gensym))
     6868           (tag-register (allocate-register nil))
     6869           (BEGIN-PROTECTED-RANGE (gensym "F"))
     6870           (END-PROTECTED-RANGE (gensym "U"))
     6871           (THROW-HANDLER (gensym "H"))
    64476872           (RETHROW (gensym))
    64486873           (DEFAULT-HANDLER (gensym))
    6449            (EXIT (gensym))
    6450            (specials-register (allocate-register)))
     6874           (EXIT (gensym "E"))
     6875           (specials-register (allocate-register nil)))
    64516876      (compile-form (second form) tag-register nil) ; Tag.
    64526877      (emit-push-current-thread)
     
    65006925  ;; FIXME What if we're called with a non-NIL representation?
    65016926  (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)
     6927  (with-operand-accumulation
     6928      ((emit-thread-operand)
     6929       (compile-operand (second form) nil) ; Tag.
     6930       (emit-clear-values) ; Do this unconditionally! (MISC.503)
     6931       (compile-operand (third form) nil)) ; Result.
     6932    (emit-invokevirtual +lisp-thread+ "throwToTag"
     6933       (lisp-object-arg-types 2) nil))
    65086934  ;; Following code will not be reached.
    65096935  (when target
     
    65326958           (cleanup-forms (cdddr form))
    65336959           (*register* *register*)
    6534            (exception-register (allocate-register))
    6535            (result-register (allocate-register))
    6536            (values-register (allocate-register))
    6537            (specials-register (allocate-register))
    6538            (BEGIN-PROTECTED-RANGE (gensym))
    6539            (END-PROTECTED-RANGE (gensym))
    6540            (HANDLER (gensym))
    6541            (EXIT (gensym)))
     6960           (exception-register (allocate-register nil))
     6961           (result-register (allocate-register nil))
     6962           (values-register (allocate-register nil))
     6963           (specials-register (allocate-register nil))
     6964           (BEGIN-PROTECTED-RANGE (gensym "F"))
     6965           (END-PROTECTED-RANGE (gensym "U"))
     6966           (HANDLER (gensym "H"))
     6967           (EXIT (gensym "E")))
    65426968      ;; Make sure there are no leftover multiple return values from previous calls.
    65436969      (emit-clear-values)
     
    66287054        ((node-p form)
    66297055         (cond
     7056           ((jump-node-p form)
     7057            (let ((op (car (node-form form))))
     7058              (cond
     7059               ((eq op 'go)
     7060                (p2-go form target representation))
     7061               ((eq op 'return-from)
     7062                (p2-return-from form target representation))
     7063               (t
     7064                (assert (not "jump-node: can't happen"))))))
    66307065           ((block-node-p form)
    66317066            (p2-block-node form target representation))
     
    67627197         (*thread* nil)
    67637198         (*initialize-thread-var* nil)
    6764          (label-START (gensym)))
     7199         (label-START (gensym "F")))
    67657200
    67667201    (class-add-method class-file method)
     
    67967231
    67977232      (when *using-arg-array*
    6798         (setf (compiland-argument-register compiland) (allocate-register)))
     7233        (setf (compiland-argument-register compiland) (allocate-register nil)))
    67997234
    68007235      ;; Assign indices or registers, depending on where the args are
     
    68067241          (if *using-arg-array*
    68077242              (setf (variable-index variable) index)
    6808               (setf (variable-register variable) (allocate-register)))
     7243              (setf (variable-register variable) (allocate-register nil)))
    68097244          (incf index)))
    68107245
    68117246      ;; Reserve the next available slot for the thread register.
    6812       (setf *thread* (allocate-register))
     7247      (setf *thread* (allocate-register nil))
    68137248
    68147249      (when *closure-variables*
    6815         (setf (compiland-closure-register compiland) (allocate-register))
     7250        (setf (compiland-closure-register compiland) (allocate-register nil))
    68167251        (dformat t "p2-compiland 2 closure register = ~S~%"
    68177252                 (compiland-closure-register compiland)))
     
    68847319                      (< (+ (variable-reads variable)
    68857320                            (variable-writes variable)) 2))
    6886             (let ((register (allocate-register)))
     7321            (let ((register (allocate-register nil)))
    68877322              (aload (compiland-argument-register compiland))
    68887323              (emit-push-constant-int (variable-index variable))
     
    69037338        ;; Save the dynamic environment
    69047339        (setf (compiland-environment-register compiland)
    6905               (allocate-register))
     7340              (allocate-register nil))
    69067341        (save-dynamic-environment (compiland-environment-register compiland))
    69077342        (label label-START)
    69087343        (dolist (variable (compiland-arg-vars compiland))
    69097344          (when (variable-special-p variable)
    6910             (setf (variable-binding-register variable) (allocate-register))
     7345            (setf (variable-binding-register variable) (allocate-register nil))
    69117346            (emit-push-current-thread)
    69127347            (emit-push-variable-name variable)
  • trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp

    r13078 r13222  
    10211021(defun finalize-code-attribute (code parent class)
    10221022  "Prepares the `code' attribute for serialization, within method `parent'."
    1023   (declare (ignore parent))
    10241023  (let* ((handlers (code-exception-handlers code))
    10251024         (c (finalize-code
     
    10291028                            (mapcar #'exception-handler-pc handlers))
    10301029                     t)))
     1030    (invoke-callbacks :code-finalized class parent
     1031                      (coerce c 'list) handlers)
    10311032    (unless (code-max-stack code)
    10321033      (setf (code-max-stack code)
  • trunk/abcl/src/org/armedbear/lisp/jvm-instructions.lisp

    r12941 r13222  
    722722        (setf depth (+ depth instruction-stack))
    723723        (setf (instruction-depth instruction) depth)
     724        (unless (<= 0 depth)
     725          (internal-compiler-error "Stack inconsistency detected ~
     726                                    in ~A at index ~D: ~
     727                                    negative depth ~S."
     728                                   (compiland-name *current-compiland*)
     729                                   i depth))
    724730        (when (branch-p opcode)
    725731          (let ((label (car (instruction-args instruction))))
  • trunk/abcl/src/org/armedbear/lisp/jvm.lisp

    r13120 r13222  
    5454
    5555(defvar *enable-dformat* nil)
     56(defvar *callbacks* nil
     57  "A list of functions to be called by the compiler and code generator
     58in order to generate 'compilation events'.")
     59
     60(declaim (inline invoke-callbacks))
     61(defun invoke-callbacks (&rest args)
     62  (dolist (cb *callbacks*)
     63    (apply cb args)))
    5664
    5765#+nil
     
    338346      (return variable))))
    339347
    340 (defknown allocate-register () (integer 0 65535))
    341 (defun allocate-register ()
    342   (let* ((register *register*)
    343          (next-register (1+ register)))
    344     (declare (type (unsigned-byte 16) register next-register))
    345     (setf *register* next-register)
    346     (when (< *registers-allocated* next-register)
    347       (setf *registers-allocated* next-register))
     348(defknown representation-size (t) (integer 0 65535))
     349(defun representation-size (representation)
     350  (ecase representation
     351    ((NIL :int :boolean :float :char) 1)
     352    ((:long :double) 2)))
     353
     354(defknown allocate-register (t) (integer 0 65535))
     355(defun allocate-register (representation)
     356  (let ((register *register*))
     357    (incf *register* (representation-size representation))
     358    (setf *registers-allocated*
     359          (max *registers-allocated* *register*))
    348360    register))
    349361
    350 (defknown allocate-register-pair () (integer 0 65535))
    351 (defun allocate-register-pair ()
    352   (let* ((register *register*)
    353          (next-register (+ register 2)))
    354     (declare (type (unsigned-byte 16) register next-register))
    355     (setf *register* next-register)
    356     (when (< *registers-allocated* next-register)
    357       (setf *registers-allocated* next-register))
    358     register))
    359362
    360363(defstruct local-function
     
    465468  ;; Contains a variable whose value uniquely identifies the
    466469  ;; lexical scope from this block, to be used by RETURN-FROM
    467   id-variable)
     470  id-variable
     471  ;; A list of all RETURN-FROM value forms associated with this block
     472  return-value-forms)
     473
    468474(defknown make-block-node (t) t)
    469475(defun make-block-node (name)
     
    472478    (add-node-child *block* block)
    473479    block))
     480
     481(defstruct (jump-node (:conc-name jump-)
     482                      (:include node)
     483                      (:constructor
     484                       %make-jump-node (non-local-p target-block target-tag)))
     485  non-local-p
     486  target-block
     487  target-tag)
     488(defun make-jump-node (form non-local-p target-block &optional target-tag)
     489  (let ((node (%make-jump-node non-local-p target-block target-tag)))
     490    ;; Don't push into compiland blocks, as this as a node rather than a block
     491    (setf (node-form node) form)
     492    (add-node-child *block* node)
     493    node))
     494
    474495
    475496;; binding blocks: LET, LET*, FLET, LABELS, M-V-B, PROGV, LOCALLY
     
    609630    ;; when the innermost enclosing block doesn't have node-children,
    610631    ;;  there's really nothing to search for.
    611     (when (null (node-children (car *blocks*)))
    612       (return-from find-enclosed-blocks)))
     632    (let ((first-enclosing-block (car *blocks*)))
     633      (when (and (eq *current-compiland*
     634                     (node-compiland first-enclosing-block))
     635                 (null (node-children first-enclosing-block)))
     636        (return-from find-enclosed-blocks))))
    613637
    614638  (%find-enclosed-blocks form))
    615    
     639
    616640
    617641(defun some-nested-block (predicate blocks)
     
    651675      (synchronized-node-p object)))
    652676
    653 (defun block-opstack-unsafe-p (block)
    654   (or (when (tagbody-node-p block) (tagbody-non-local-go-p block))
    655       (when (block-node-p block) (block-non-local-return-p block))
    656       (catch-node-p block)))
     677(defun node-opstack-unsafe-p (node)
     678  (or (when (jump-node-p node)
     679        (let ((target-block (jump-target-block node)))
     680          (and (null (jump-non-local-p node))
     681               (member target-block *blocks*))))
     682      (when (tagbody-node-p node) (tagbody-non-local-go-p node))
     683      (when (block-node-p node) (block-non-local-return-p node))
     684      (catch-node-p node)))
    657685
    658686(defknown block-creates-runtime-bindings-p (t) boolean)
Note: See TracChangeset for help on using the changeset viewer.