From 68a478fc4eca7978093272ccb1466852ab055eb1 Mon Sep 17 00:00:00 2001 From: Alastair Bridgewater Date: Sun, 4 Nov 2012 13:54:37 -0500 Subject: [PATCH] compiler/arm: Allow COMPUTE-LRA to find LRAs more than 256 octets away. * Altered the "instruction" to support up to three octets worth of displacement (that's eight megabytes either side, which should be sufficient) by using an interior-pointer register to hold the intermediate values. * Updated all usage sites to have and pass an interior-pointer as needed. --- src/compiler/arm/call.lisp | 3 +- src/compiler/arm/insts.lisp | 67 ++++++++++++++++++++++++++++++++++++++------- src/compiler/arm/nlx.lisp | 6 ++-- 3 files changed, 63 insertions(+), 13 deletions(-) diff --git a/src/compiler/arm/call.lisp b/src/compiler/arm/call.lisp index 9dc47f7ac..a0af8d88f 100644 --- a/src/compiler/arm/call.lisp +++ b/src/compiler/arm/call.lisp @@ -649,6 +649,7 @@ ,@(unless (eq return :tail) '((:temporary (:scs (non-descriptor-reg)) temp) + (:temporary (:scs (interior-reg)) lip) (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save))) (:generator ,(+ (if named 5 0) @@ -698,7 +699,7 @@ (:frob-nfp (error "Don't know how to :FROB-NFP for TAIL call"))) `((:comp-lra - (inst compute-lra return-pc-pass lra-label)) + (inst compute-lra return-pc-pass lip lra-label)) (:frob-nfp (store-stack-tn nfp-save cur-nfp)) (:load-fp diff --git a/src/compiler/arm/insts.lisp b/src/compiler/arm/insts.lisp index d925a220b..231c660e0 100644 --- a/src/compiler/arm/insts.lisp +++ b/src/compiler/arm/insts.lisp @@ -793,15 +793,62 @@ ;;; Compute the address of a nearby LRA object by dead reckoning from ;;; the location of the current instruction. -(define-instruction compute-lra (segment dest lra-label) +(define-instruction compute-lra (segment dest lip lra-label) (:vop-var vop) (:emitter - (emit-back-patch - segment 4 - (lambda (segment position) - (assemble (segment vop) - (inst add dest pc-tn (- (+ (label-position lra-label) - other-pointer-lowtag) - ;; The 8 below is the displacement - ;; from reading the program counter. - (+ position 8)))))))) + ;; We can compute the LRA in a single instruction if the overall + ;; offset puts it to within an 8-bit displacement. Otherwise, we + ;; need to load it by parts into LIP until we're down to an 8-bit + ;; displacement, and load the final 8 bits into DEST. We may + ;; safely presume that an overall displacement may be up to 24 bits + ;; wide (the PPC backend has special provision for branches over 15 + ;; bits, which implies that segments can become large, but a 16 + ;; megabyte segment (24 bits of displacement) is ridiculous), so we + ;; need to cover a range of up to three octets of displacement. + (labels ((compute-delta (position &optional magic-value) + (- (+ (label-position lra-label + (when magic-value position) + magic-value) + other-pointer-lowtag) + ;; The 8 below is the displacement + ;; from reading the program counter. + (+ position 8))) + + (three-instruction-emitter (segment position) + (let ((delta (compute-delta position))) + (assemble (segment vop) + (inst add lip pc-tn (ldb (byte 8 16) delta)) + (inst add lip lip (ldb (byte 8 8) delta)) + (inst add dest lip (ldb (byte 8 0) delta))))) + + (two-instruction-emitter (segment position) + (let ((delta (compute-delta position))) + (assemble (segment vop) + (inst add lip pc-tn (ldb (byte 8 8) delta)) + (inst add dest lip (ldb (byte 8 0) delta))))) + + (one-instruction-emitter (segment position) + (let ((delta (compute-delta position))) + (assemble (segment vop) + (inst add dest pc-tn delta)))) + + (two-instruction-maybe-shrink (segment posn magic-value) + (let ((delta (compute-delta posn magic-value))) + (when (<= (integer-length delta) 8) + (emit-back-patch segment 4 + #'one-instruction-emitter) + t))) + + (three-instruction-maybe-shrink (segment posn magic-value) + (let ((delta (compute-delta posn magic-value))) + (when (<= (integer-length delta) 16) + (emit-chooser segment 8 2 + #'two-instruction-maybe-shrink + #'two-instruction-emitter) + t)))) + (emit-chooser + ;; We need to emit up to three instructions, which is 12 octets. + ;; This preserves a mere two bits of alignment. + segment 12 2 + #'three-instruction-maybe-shrink + #'three-instruction-emitter)))) diff --git a/src/compiler/arm/nlx.lisp b/src/compiler/arm/nlx.lisp index de2eeb1a3..57774df9a 100644 --- a/src/compiler/arm/nlx.lisp +++ b/src/compiler/arm/nlx.lisp @@ -76,13 +76,14 @@ (:info entry-label) (:results (block :scs (any-reg))) (:temporary (:scs (descriptor-reg)) temp) + (:temporary (:scs (interior-reg)) lip) (:generator 22 (inst add block fp-tn (* (tn-offset tn) n-word-bytes)) (load-symbol-value temp *current-unwind-protect-block*) (storew temp block unwind-block-current-uwp-slot) (storew fp-tn block unwind-block-current-cont-slot) (storew code-tn block unwind-block-current-code-slot) - (inst compute-lra temp entry-label) + (inst compute-lra temp lip entry-label) (storew temp block catch-block-entry-pc-slot))) ;;; Like Make-Unwind-Block, except that we also store in the specified tag, and @@ -94,13 +95,14 @@ (:results (block :scs (any-reg))) (:temporary (:scs (descriptor-reg)) temp) (:temporary (:scs (descriptor-reg) :target block :to (:result 0)) result) + (:temporary (:scs (interior-reg)) lip) (:generator 44 (inst add result fp-tn (* (tn-offset tn) n-word-bytes)) (load-symbol-value temp *current-unwind-protect-block*) (storew temp result catch-block-current-uwp-slot) (storew fp-tn result catch-block-current-cont-slot) (storew code-tn result catch-block-current-code-slot) - (inst compute-lra temp entry-label) + (inst compute-lra temp lip entry-label) (storew temp result catch-block-entry-pc-slot) (storew tag result catch-block-tag-slot) -- 2.11.4.GIT