Index: /branches/arm/compiler/ARM/arm-asm.lisp =================================================================== --- /branches/arm/compiler/ARM/arm-asm.lisp (revision 13980) +++ /branches/arm/compiler/ARM/arm-asm.lisp (revision 13981) @@ -1296,4 +1296,14 @@ (%make-lap-instruction form)))) +(defun emit-lap-instruction-element (insn seg) + (ccl::append-dll-node insn seg) + (let* ((addr (let* ((prev (ccl::dll-node-pred insn))) + (if (eq prev seg) + 0 + (the fixnum (+ (the fixnum (instruction-element-address prev)) + (the fixnum (instruction-element-size prev)))))))) + (setf (instruction-element-address insn) addr)) + insn) + ;;; FORM is a list and its car isn't a pseudo-op or lapmacro; try to ;;; generate an instruction. @@ -1332,5 +1342,5 @@ (setf (lap-instruction-opcode insn) (dpb cond (byte 4 28) (lap-instruction-opcode insn)))) - (ccl::append-dll-node insn seg)))))) + (emit-lap-instruction-element insn seg)))))) ;;; A label can only be emitted once. Once it's been emitted, its pred/succ @@ -1379,5 +1389,5 @@ (error "Label ~s: multiply defined." name)) (setq lab (make-lap-label name))) - (ccl::append-dll-node lab seg))) + (emit-lap-instruction-element lab seg))) (defmacro do-lap-labels ((lab &optional result) &body body) @@ -1395,4 +1405,12 @@ ,result))) +(defun section-size (seg) + (let* ((last (ccl::dll-node-pred seg))) + (if (eq last seg) ;empty + 0 + (the fixnum + (+ (the fixnum (instruction-element-address last)) + (the fixnum (instruction-element-size last))))))) + (defun set-element-addresses (start seg) (ccl::do-dll-nodes (element seg start) @@ -1400,22 +1418,11 @@ (incf start (instruction-element-size element)))) -(defun count-element-sizes (seg) - (let* ((start 0)) - (ccl::do-dll-nodes (element seg start) - (incf start (instruction-element-size element))))) - -(defun element-sizes-since (seg first) - (let* ((n 0)) - (do* ((curr (or first (ccl::dll-node-succ seg)) (ccl::dll-node-succ curr))) - ((eq curr seg) n) - (incf n (instruction-element-size curr))))) - ;;; It's better to do this naively than to not do it at all (defun drain-constant-pool (primary constant-pool) - (let* ((n-constant-bytes (count-element-sizes constant-pool))) + (let* ((n-constant-bytes (section-size constant-pool))) (declare (fixnum n-constant-bytes)) (when (> n-constant-bytes 0) - (when (> (+ n-constant-bytes (element-sizes-since primary *last-constant-pool-origin*)) 4000) ; some slack here + (when (> (+ n-constant-bytes (section-size primary)) 4000) ; some slack here ;; Jump around an embedded constant pool. We might be following ;; some flavor of a jump with an unreachable one, or sticking @@ -1425,23 +1432,24 @@ ;; generates jump tables or other span-dependent things, it'll ;; have to be careful about how it does so. - (multiple-value-bind (first last) (ccl::detach-dll-nodes constant-pool) - (let* ((target-name (gensym)) - (origin (make-lap-instruction nil)) - (offset (make-lap-instruction nil)) - (pool-count (make-lap-instruction nil)) - (offset-label (make-lap-label (gensym)))) - (assemble-instruction primary `(b ,target-name)) - (setf (lap-instruction-opcode origin) 0) - (ccl::append-dll-node origin primary) - (setq *last-constant-pool-origin* origin) - (setf (lap-instruction-opcode offset) 0) - (ccl::append-dll-node offset primary) - (setf (lap-instruction-opcode pool-count) - (ash n-constant-bytes (- arm::word-shift))) - (ccl::append-dll-node pool-count primary) - (ccl::insert-dll-node-after first pool-count last) - (push (cons offset :offset) (lap-label-refs offset-label)) - (emit-lap-label primary (lap-label-name offset-label)) - (emit-lap-label primary target-name))))))) + (let* ((target-name (gensym)) + (origin (make-lap-instruction nil)) + (offset (make-lap-instruction nil)) + (pool-count (make-lap-instruction nil)) + (offset-label (make-lap-label (gensym)))) + (assemble-instruction primary `(b ,target-name)) + (setf (lap-instruction-opcode origin) 0) + (emit-lap-instruction-element origin primary) + (setq *last-constant-pool-origin* origin) + (setf (lap-instruction-opcode offset) 0) + (emit-lap-instruction-element offset primary) + (setf (lap-instruction-opcode pool-count) + (ash n-constant-bytes (- arm::word-shift))) + (emit-lap-instruction-element pool-count primary) + (ccl::do-dll-nodes (datum constant-pool) + (ccl::remove-dll-node datum) + (emit-lap-instruction-element datum primary)) + (push (cons offset :offset) (lap-label-refs offset-label)) + (emit-lap-label primary (lap-label-name offset-label)) + (emit-lap-label primary target-name)))))) @@ -1460,7 +1468,7 @@ (dolist (lab *called-subprim-jmp-labels*) (unless (lap-label-emitted-p lab) - (ccl::append-dll-node lab primary) + (emit-lap-instruction-element lab primary) (assemble-instruction primary `(ba ,(lap-label-name lab))))) - (let* ((constants-size (count-element-sizes constant-pool))) + (let* ((constants-size (section-size constant-pool))) (unless (eql constants-size 0) (let* ((c0 (make-lap-instruction nil))) Index: /branches/arm/compiler/ARM/arm-lap.lisp =================================================================== --- /branches/arm/compiler/ARM/arm-lap.lisp (revision 13980) +++ /branches/arm/compiler/ARM/arm-lap.lisp (revision 13981) @@ -140,5 +140,5 @@ (:word (check-usage :word) - (append-dll-node + (arm::emit-lap-instruction-element (let* ((insn (arm::make-lap-instruction nil))) (setf (arm::lap-instruction-opcode insn) (logand #xffffffff (eval arg))) Index: /branches/arm/compiler/ARM/arm2.lisp =================================================================== --- /branches/arm/compiler/ARM/arm2.lisp (revision 13980) +++ /branches/arm/compiler/ARM/arm2.lisp (revision 13981) @@ -4897,5 +4897,5 @@ (setf (arm::lap-instruction-opcode insn) (parse-operand-form (cadr f))) - (append-dll-node insn current))) + (arm::emit-lap-instruction-element insn current))) (t (let* ((insn (arm::make-lap-instruction nil)) @@ -4907,5 +4907,5 @@ insn predicate)) - (dolist (op operands (append-dll-node insn current)) + (dolist (op operands (arm::emit-lap-instruction-element insn current)) (let* ((insert-function (svref operand-insert-functions (car op)))) (funcall insert-function insn (parse-operand-form (cdr op)))))))))