Changeset 13981
- Timestamp:
- Jul 19, 2010, 2:38:15 PM (9 years ago)
- Location:
- branches/arm/compiler/ARM
- Files:
-
- 3 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/arm/compiler/ARM/arm-asm.lisp
r13968 r13981 1296 1296 (%make-lap-instruction form)))) 1297 1297 1298 (defun emit-lap-instruction-element (insn seg) 1299 (ccl::append-dll-node insn seg) 1300 (let* ((addr (let* ((prev (ccl::dll-node-pred insn))) 1301 (if (eq prev seg) 1302 0 1303 (the fixnum (+ (the fixnum (instruction-element-address prev)) 1304 (the fixnum (instruction-element-size prev)))))))) 1305 (setf (instruction-element-address insn) addr)) 1306 insn) 1307 1298 1308 ;;; FORM is a list and its car isn't a pseudo-op or lapmacro; try to 1299 1309 ;;; generate an instruction. … … 1332 1342 (setf (lap-instruction-opcode insn) 1333 1343 (dpb cond (byte 4 28) (lap-instruction-opcode insn)))) 1334 ( ccl::append-dll-nodeinsn seg))))))1344 (emit-lap-instruction-element insn seg)))))) 1335 1345 1336 1346 ;;; A label can only be emitted once. Once it's been emitted, its pred/succ … … 1379 1389 (error "Label ~s: multiply defined." name)) 1380 1390 (setq lab (make-lap-label name))) 1381 ( ccl::append-dll-nodelab seg)))1391 (emit-lap-instruction-element lab seg))) 1382 1392 1383 1393 (defmacro do-lap-labels ((lab &optional result) &body body) … … 1395 1405 ,result))) 1396 1406 1407 (defun section-size (seg) 1408 (let* ((last (ccl::dll-node-pred seg))) 1409 (if (eq last seg) ;empty 1410 0 1411 (the fixnum 1412 (+ (the fixnum (instruction-element-address last)) 1413 (the fixnum (instruction-element-size last))))))) 1414 1397 1415 (defun set-element-addresses (start seg) 1398 1416 (ccl::do-dll-nodes (element seg start) … … 1400 1418 (incf start (instruction-element-size element)))) 1401 1419 1402 (defun count-element-sizes (seg)1403 (let* ((start 0))1404 (ccl::do-dll-nodes (element seg start)1405 (incf start (instruction-element-size element)))))1406 1407 (defun element-sizes-since (seg first)1408 (let* ((n 0))1409 (do* ((curr (or first (ccl::dll-node-succ seg)) (ccl::dll-node-succ curr)))1410 ((eq curr seg) n)1411 (incf n (instruction-element-size curr)))))1412 1413 1420 1414 1421 ;;; It's better to do this naively than to not do it at all 1415 1422 (defun drain-constant-pool (primary constant-pool) 1416 (let* ((n-constant-bytes ( count-element-sizesconstant-pool)))1423 (let* ((n-constant-bytes (section-size constant-pool))) 1417 1424 (declare (fixnum n-constant-bytes)) 1418 1425 (when (> n-constant-bytes 0) 1419 (when (> (+ n-constant-bytes ( element-sizes-since primary *last-constant-pool-origin*)) 4000) ; some slack here1426 (when (> (+ n-constant-bytes (section-size primary)) 4000) ; some slack here 1420 1427 ;; Jump around an embedded constant pool. We might be following 1421 1428 ;; some flavor of a jump with an unreachable one, or sticking … … 1425 1432 ;; generates jump tables or other span-dependent things, it'll 1426 1433 ;; have to be careful about how it does so. 1427 (multiple-value-bind (first last) (ccl::detach-dll-nodes constant-pool) 1428 (let* ((target-name (gensym)) 1429 (origin (make-lap-instruction nil)) 1430 (offset (make-lap-instruction nil)) 1431 (pool-count (make-lap-instruction nil)) 1432 (offset-label (make-lap-label (gensym)))) 1433 (assemble-instruction primary `(b ,target-name)) 1434 (setf (lap-instruction-opcode origin) 0) 1435 (ccl::append-dll-node origin primary) 1436 (setq *last-constant-pool-origin* origin) 1437 (setf (lap-instruction-opcode offset) 0) 1438 (ccl::append-dll-node offset primary) 1439 (setf (lap-instruction-opcode pool-count) 1440 (ash n-constant-bytes (- arm::word-shift))) 1441 (ccl::append-dll-node pool-count primary) 1442 (ccl::insert-dll-node-after first pool-count last) 1443 (push (cons offset :offset) (lap-label-refs offset-label)) 1444 (emit-lap-label primary (lap-label-name offset-label)) 1445 (emit-lap-label primary target-name))))))) 1434 (let* ((target-name (gensym)) 1435 (origin (make-lap-instruction nil)) 1436 (offset (make-lap-instruction nil)) 1437 (pool-count (make-lap-instruction nil)) 1438 (offset-label (make-lap-label (gensym)))) 1439 (assemble-instruction primary `(b ,target-name)) 1440 (setf (lap-instruction-opcode origin) 0) 1441 (emit-lap-instruction-element origin primary) 1442 (setq *last-constant-pool-origin* origin) 1443 (setf (lap-instruction-opcode offset) 0) 1444 (emit-lap-instruction-element offset primary) 1445 (setf (lap-instruction-opcode pool-count) 1446 (ash n-constant-bytes (- arm::word-shift))) 1447 (emit-lap-instruction-element pool-count primary) 1448 (ccl::do-dll-nodes (datum constant-pool) 1449 (ccl::remove-dll-node datum) 1450 (emit-lap-instruction-element datum primary)) 1451 (push (cons offset :offset) (lap-label-refs offset-label)) 1452 (emit-lap-label primary (lap-label-name offset-label)) 1453 (emit-lap-label primary target-name)))))) 1446 1454 1447 1455 … … 1460 1468 (dolist (lab *called-subprim-jmp-labels*) 1461 1469 (unless (lap-label-emitted-p lab) 1462 ( ccl::append-dll-nodelab primary)1470 (emit-lap-instruction-element lab primary) 1463 1471 (assemble-instruction primary `(ba ,(lap-label-name lab))))) 1464 (let* ((constants-size ( count-element-sizesconstant-pool)))1472 (let* ((constants-size (section-size constant-pool))) 1465 1473 (unless (eql constants-size 0) 1466 1474 (let* ((c0 (make-lap-instruction nil))) -
branches/arm/compiler/ARM/arm-lap.lisp
r13897 r13981 140 140 (:word 141 141 (check-usage :word) 142 (a ppend-dll-node142 (arm::emit-lap-instruction-element 143 143 (let* ((insn (arm::make-lap-instruction nil))) 144 144 (setf (arm::lap-instruction-opcode insn) (logand #xffffffff (eval arg))) -
branches/arm/compiler/ARM/arm2.lisp
r13968 r13981 4897 4897 (setf (arm::lap-instruction-opcode insn) 4898 4898 (parse-operand-form (cadr f))) 4899 (a ppend-dll-nodeinsn current)))4899 (arm::emit-lap-instruction-element insn current))) 4900 4900 (t 4901 4901 (let* ((insn (arm::make-lap-instruction nil)) … … 4907 4907 insn 4908 4908 predicate)) 4909 (dolist (op operands (a ppend-dll-nodeinsn current))4909 (dolist (op operands (arm::emit-lap-instruction-element insn current)) 4910 4910 (let* ((insert-function (svref operand-insert-functions (car op)))) 4911 4911 (funcall insert-function insn (parse-operand-form (cdr op)))))))))
Note: See TracChangeset
for help on using the changeset viewer.