Changeset 13981

Timestamp:

Jul 19, 2010, 2:38:15 PM (9 years ago)

Author:

gb

Message:

Use ARM::EMIT-LAP-INSTRUCTION-ELEMENTS (rather than
CCL::APPEND-DLL-NODE) to add lap instructions/labels to the
doubly-linked list. (ARM::EMIT-LAP-INSTRUCTION-ELEMENT incrementally
updates the label/instruction's tentative address, which is hopefully
faster than calculating it on every call to DRAIN-CONSTANT-POOL.)

Location:

branches/arm/compiler/ARM

Files:

• arm-asm.lisp (modified) (7 diffs)
• arm-lap.lisp (modified) (1 diff)
• arm2.lisp (modified) (2 diffs)

branches/arm/compiler/ARM/arm-asm.lisp

@@ -1296 +1296 @@
       (%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 +1342 @@
             (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 +1389 @@
         (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 +1405 @@
       ,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 +1418 @@
     (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 +1432 @@
         ;; 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 +1468 @@
   (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)))

branches/arm/compiler/ARM/arm-lap.lisp

@@ -140 +140 @@
       (: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)))

branches/arm/compiler/ARM/arm2.lisp

@@ -4897 +4897 @@
                     (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 +4907 @@
                                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)))))))))