common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Get rid of LRA on ARM64.

Browse source 
Who ever thought LRA was a good idea? Just pin the whole stack.
Calling an empty function is now 3x faster on a MacBook Air.
This commit is contained in:
Stas Boukarev 2021-05-09 19:48:35 +03:00
parent dd76e5a752
commit 39494bd03f
35 changed files with 557 additions and 498 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

18
contrib/sb-cover/cover.lisp
View file

@ -45,17 +45,17 @@
(when (typep map '(cons (eql sb-c::coverage-map)))
(return-from %find-coverage-map (values (cdr map) code))))))))
#+darwin-jit
#+arm64
(declaim (ftype (sb-int:sfunction (t) (simple-array (unsigned-byte 8) (*))) code-coverage-marks))
;;; Coverage marks are in the raw bytes following the jump tables
;;; preceding any other unboxed constants. This way we don't have to store
;;; a pointer to the coverage marks since their location is implicit.
(defun code-coverage-marks (code)
#-darwin-jit
#-arm64
(let ((insts (sb-kernel:code-instructions code)))
(sb-sys:sap+ insts (ash (sb-kernel:code-jump-table-words code)
sb-vm:word-shift)))
#+darwin-jit
#+arm64
(let* ((words (sb-kernel:code-header-words code))
(last (sb-kernel:code-header-ref code (- words 2))))
(if (vectorp last)
@ -103,13 +103,13 @@ image."
(multiple-value-bind (map code) (%find-coverage-map code)
(when map
(sb-int:collect ((paths))
#-darwin-jit
#-arm64
(sb-sys:with-pinned-objects (code)
(let ((sap (code-coverage-marks code)))
(dotimes (i (length map) (paths))
(when (byte-marked-p (sb-sys:sap-ref-8 sap i))
(paths (svref map i))))))
#+darwin-jit
#+arm64
(let ((marks (code-coverage-marks code)))
(dotimes (i (length map) (paths))
(when (byte-marked-p (aref marks i))
@ -120,13 +120,13 @@ image."
(cond (object ; reset only this object
(multiple-value-bind (map code) (%find-coverage-map object)
(when map
#-darwin-jit
#-arm64
(sb-sys:with-pinned-objects (code)
(let ((sap (code-coverage-marks code)))
(dotimes (i (ceiling (length map) sb-vm:n-word-bytes))
(setf (sb-sys:sap-ref-word sap (ash i sb-vm:n-word-bytes))
(empty-mark-word)))))
#+darwin-jit
#+arm64
(fill (code-coverage-marks code) #xFF))))
(t ; reset everything
(do-instrumented-code (code)
@ -164,7 +164,7 @@ image."
(gethash namestring namestring->path-tables) path-lookup-table)
(dolist (item legacy-coverage-marks)
(setf (gethash (car item) path-lookup-table) item)))
#-darwin-jit
#-arm64
(sb-sys:with-pinned-objects (code)
(let ((sap (code-coverage-marks code)))
(dotimes (i (length map)) ; for each recorded mark
@ -181,7 +181,7 @@ image."
#+nil
(warn "Missing coverage entry for ~S in ~S"
path namestring))))))))
#+darwin-jit
#+arm64
(let ((marks (code-coverage-marks code)))
(dotimes (i (length map)) ; for each recorded mark
(when (byte-marked-p (aref marks i))

35
src/assembly/arm64/assem-rtns.lisp
View file

@ -11,7 +11,7 @@
((:temp nvals any-reg nargs-offset)
(:temp vals any-reg nl1-offset)
(:temp old-fp any-reg nl2-offset)
(:temp lra descriptor-reg r6-offset)
(:temp lra interior-reg lr-offset)
;; These are just needed to facilitate the transfer
(:temp count any-reg nl3-offset)
@ -23,8 +23,7 @@
(:temp r0 descriptor-reg r0-offset)
(:temp r1 descriptor-reg r1-offset)
(:temp r2 descriptor-reg r2-offset)
(:temp r3 descriptor-reg r3-offset)
(:temp lip interior-reg lr-offset))
(:temp r3 descriptor-reg r3-offset))
;; Note, because of the way the return-multiple vop is written, we
;; can assume that we are never called with nvals == 1 (not that it
@ -69,7 +68,7 @@
(inst add csp-tn ocfp-tn (lsl nvals (- word-shift n-fixnum-tag-bits)))
;; Return.
(lisp-return lra lip :multiple-values))
(lisp-return lra :multiple-values))
;;;; tail-call-variable.
@ -133,18 +132,18 @@
(inst b :ne LOOP)
DONE
(loadw lip cfp-tn lra-save-offset)
;; The call frame is all set up, so all that remains is to jump to
;; the new function. We need a boxed register to hold the actual
;; function object (in case of closure functions or funcallable
;; instances)
(inst asr nargs nargs (- word-shift n-fixnum-tag-bits))
(loadw temp lexenv closure-fun-slot fun-pointer-lowtag)
(lisp-jump temp lip))
(lisp-jump temp lr2-tn))
;;;; Non-local exit noise.
(define-assembly-routine (throw
(:return-style :none))
(define-assembly-routine (throw)
((:arg target descriptor-reg r0-offset)
(:arg start any-reg r9-offset)
(:arg count any-reg nargs-offset)
@ -156,7 +155,18 @@
LOOP
(let ((error (generate-error-code nil 'unseen-throw-tag-error target)))
(let ((error (gen-label)))
(assemble (:elsewhere)
(emit-label error)
;; Fake up a stack frame so that backtraces come out right.
(inst mov ocfp-tn cfp-tn)
(inst mov cfp-tn csp-tn)
(inst stp ocfp-tn lr-tn (@ csp-tn 16 :post-index))
(emit-error-break nil error-trap
(error-number-or-lose 'unseen-throw-tag-error)
(list target)))
(inst cbz catch error))
(loadw-pair tmp-tn catch-block-previous-catch-slot tag catch-block-tag-slot catch)
@ -169,14 +179,12 @@
(inst b (make-fixup 'unwind :assembly-routine)))
(define-assembly-routine (unwind
(:return-style :none)
(:translate %unwind)
(:policy :fast-safe))
((:arg block (any-reg descriptor-reg) r0-offset)
(:arg start (any-reg descriptor-reg) r9-offset)
(:arg count (any-reg descriptor-reg) nargs-offset)
(:temp ocfp any-reg ocfp-offset)
(:temp lra descriptor-reg lexenv-offset)
(:temp cur-uwp any-reg nl2-offset)
(:temp lip interior-reg lr-offset)
(:temp next-uwp any-reg nl3-offset)
@ -199,7 +207,8 @@
(unbind-to-here where symbol value tmp-tn)
(store-tl-symbol-value next-uwp *current-unwind-protect-block*)
(loadw-pair cfp-tn unwind-block-cfp-slot code-tn unwind-block-code-slot cur-uwp)
(loadw lip cur-uwp unwind-block-entry-pc-slot)
(loadw cfp-tn cur-uwp unwind-block-cfp-slot)
(loadw next-uwp cur-uwp unwind-block-current-catch-slot)
(store-tl-symbol-value next-uwp *current-catch-block*)
@ -210,5 +219,5 @@
(inst mov (make-random-tn :kind :normal :sc (sc-or-lose 'any-reg) :offset nfp-offset) tmp-tn)
SKIP
(loadw lra cur-uwp unwind-block-entry-pc-slot)
(lisp-return lra lip :known))
(lisp-return lip :known))

2
src/assembly/arm64/support.lisp
View file

@ -19,7 +19,7 @@
`((progn
,@(if (eq style :none)
`((load-inline-constant tmp-tn '(:fixup ,name :assembly-routine))
(inst br tmp-tn))
(inst blr tmp-tn))
`((load-inline-constant lr-tn '(:fixup ,name :assembly-routine))
(inst blr lr-tn)))))
nil))

33
src/assembly/arm64/tramps.lisp
View file

@ -78,8 +78,7 @@
(inst str (32-bit-reg null-tn) (@ nl1))) ; (alien variable is 4 bytes, not 8)
;; Create a new frame
(inst add csp-tn csp-tn (+ 32 80))
(inst stp cfp-tn null-tn (@ csp-tn -112))
(inst stp code-tn lr-tn (@ csp-tn -96))
(inst stp cfp-tn lr-tn (@ csp-tn -112))
(map-pairs stp csp-tn -80 lisp-registers)
(map-pairs stp nsp-tn 0 float-registers :pre-index -512 :delta 32)
@ -90,7 +89,7 @@
(map-pairs ldp nsp-tn 480 float-registers :post-index 512 :delta -32)
(map-pairs ldp csp-tn -16 lisp-registers :delta -16)
(inst ldr lr-tn (@ csp-tn -88))
(inst ldr lr-tn (@ csp-tn -104))
(inst sub csp-tn csp-tn (+ 32 80)) ;; deallocate the frame
#+sb-thread
@ -117,7 +116,7 @@
(undefined-tramp-tagged
(+ xundefined-tramp
fun-pointer-lowtag))))
()
((:temp fun any-reg r9-offset))
HEADER
(inst dword simple-fun-widetag)
(inst dword (make-fixup 'undefined-tramp-tagged
@ -126,13 +125,13 @@
(inst dword nil-value))
UNDEFINED-TRAMP
(inst adr code-tn header fun-pointer-lowtag)
(inst str lr-tn (@ cfp-tn 8))
(emit-error-break nil cerror-trap (error-number-or-lose 'undefined-fun-error)
(list lexenv-tn))
(loadw code-tn lexenv-tn closure-fun-slot fun-pointer-lowtag)
(inst add lr-tn code-tn (- (* simple-fun-insts-offset n-word-bytes) fun-pointer-lowtag))
(loadw fun lexenv-tn closure-fun-slot fun-pointer-lowtag)
(inst add lr2-tn fun (- (* simple-fun-insts-offset n-word-bytes) fun-pointer-lowtag))
(inst br lr-tn))
(inst br lr2-tn))
(define-assembly-routine
(xundefined-alien-tramp (:return-style :none)
@ -150,7 +149,7 @@
(inst dword nil-value))
UNDEFINED-ALIEN-TRAMP
(inst adr code-tn header fun-pointer-lowtag)
(inst str lr-tn (@ cfp-tn 8))
(error-call nil 'undefined-alien-fun-error r9-tn))
(define-assembly-routine
@ -160,7 +159,7 @@
(closure-tramp-tagged
(+ xclosure-tramp
fun-pointer-lowtag))))
()
((:temp fun any-reg r9-offset))
(inst dword simple-fun-widetag)
(inst dword (make-fixup 'closure-tramp-tagged
:assembly-routine))
@ -169,9 +168,9 @@
CLOSURE-TRAMP
(loadw lexenv-tn lexenv-tn fdefn-fun-slot other-pointer-lowtag)
(loadw code-tn lexenv-tn closure-fun-slot fun-pointer-lowtag)
(inst add lr-tn code-tn (- (* simple-fun-insts-offset n-word-bytes) fun-pointer-lowtag))
(inst br lr-tn))
(loadw fun lexenv-tn closure-fun-slot fun-pointer-lowtag)
(inst add lr2-tn fun (- (* simple-fun-insts-offset n-word-bytes) fun-pointer-lowtag))
(inst br lr2-tn))
(define-assembly-routine
(xfuncallable-instance-tramp (:return-style :none)
@ -179,13 +178,13 @@
(:export (funcallable-instance-tramp
(+ xfuncallable-instance-tramp
fun-pointer-lowtag))))
()
((:temp fun any-reg r9-offset))
(inst dword simple-fun-widetag)
(inst dword (make-fixup 'funcallable-instance-tramp :assembly-routine))
(dotimes (i (- simple-fun-insts-offset 2))
(inst dword nil-value))
(loadw lexenv-tn lexenv-tn funcallable-instance-function-slot fun-pointer-lowtag)
(loadw code-tn lexenv-tn closure-fun-slot fun-pointer-lowtag)
(inst add lr-tn code-tn (- (* simple-fun-insts-offset n-word-bytes) fun-pointer-lowtag))
(inst br lr-tn))
(loadw fun lexenv-tn closure-fun-slot fun-pointer-lowtag)
(inst add lr2-tn fun (- (* simple-fun-insts-offset n-word-bytes) fun-pointer-lowtag))
(inst br lr2-tn))

10
src/code/class.lisp
View file

@ -874,7 +874,7 @@ between the ~A definition and the ~A definition"
(declaim (type cons **non-instance-classoid-types**))
(defglobal **non-instance-classoid-types**
'(symbol system-area-pointer weak-pointer code-component
#-(or x86 x86-64) lra
#-(or x86 x86-64 arm64) lra
fdefn random-class))
(defun classoid-non-instance-p (classoid)
@ -956,10 +956,10 @@ between the ~A definition and the ~A definition"
(code-component :codes (,sb-vm:code-header-widetag)
:predicate code-component-p
:prototype-form (fun-code-header #'identity))
#-(or x86 x86-64) (lra :codes (,sb-vm:return-pc-widetag)
:predicate lra-p
;; Make the PROTOTYPE slot unbound.
:prototype-form sb-pcl:+slot-unbound+)
#-(or x86 x86-64 arm64) (lra :codes (,sb-vm:return-pc-widetag)
:predicate lra-p
;; Make the PROTOTYPE slot unbound.
:prototype-form sb-pcl:+slot-unbound+)
(fdefn :codes (,sb-vm:fdefn-widetag)
:predicate fdefn-p
:prototype-form (find-or-create-fdefn 'sb-mop:class-prototype))

92
src/code/debug-int.lisp
View file

@ -856,7 +856,7 @@
;;; Note: Sometimes LRA is actually a fixnum. This happens when lisp
;;; calls into C. In this case, the code object is stored on the stack
;;; after the LRA, and the LRA is the word offset.
#-(or x86 x86-64)
#-(or x86 x86-64 arm64)
(defun compute-calling-frame (caller lra up-frame &optional savedp)
(declare (type system-area-pointer caller)
(ignore savedp))
@ -908,7 +908,42 @@
escaped)
(if up-frame (1+ (frame-number up-frame)) 0)
escaped))))))
#+arm64
(defun compute-calling-frame (caller lra up-frame &optional savedp)
(declare (type system-area-pointer caller)
(ignore savedp))
(when (control-stack-pointer-valid-p caller)
(multiple-value-bind (code pc-offset escaped)
(if lra
(let* ((lr (int-sap (ash lra n-fixnum-tag-bits)))
(code (code-header-from-pc lr)))
(values code
(if code
(sap- lr (code-instructions code))
0)))
(find-escaped-frame caller))
(if (and (code-component-p code)
(eq (%code-debug-info code) :bpt-lra))
(let ((real-lra (code-header-ref code real-lra-slot)))
(compute-calling-frame caller real-lra up-frame))
(let ((d-fun (case code
(:undefined-function
(make-bogus-debug-fun
"undefined function"))
(:foreign-function
(make-bogus-debug-fun
(foreign-function-backtrace-name
(int-sap (get-lisp-obj-address lra)))))
((nil)
(make-bogus-debug-fun
"bogus stack frame"))
(t
(debug-fun-from-pc code pc-offset)))))
(make-compiled-frame caller up-frame d-fun
(code-location-from-pc d-fun pc-offset
escaped)
(if up-frame (1+ (frame-number up-frame)) 0)
escaped))))))
#+(or x86 x86-64)
(defun compute-calling-frame (caller ra up-frame &optional savedp)
(declare (type system-area-pointer caller ra))
@ -1114,12 +1149,12 @@ register."
;;; Find the code object corresponding to the object represented by
;;; bits and return it. We assume bogus functions correspond to the
;;; undefined-function.
#+(or x86 x86-64)
#+(or x86 x86-64 arm64)
(defun code-object-from-context (context)
(declare (type (sb-alien:alien (* os-context-t)) context))
(code-header-from-pc (context-pc context)))
#-(or x86 x86-64)
#-(or x86 x86-64 arm64)
(defun code-object-from-context (context)
(declare (type (sb-alien:alien (* os-context-t)) context))
;; The GC constraint on the program counter on precisely-scavenged
@ -1262,7 +1297,7 @@ register."
(fp (frame-pointer frame)))
(labels ((catch-ref (slot)
(sap-ref-lispobj catch (* slot n-word-bytes)))
#-(or x86 x86-64)
#-(or x86 x86-64 arm64)
(catch-entry-offset ()
(let* ((lra (catch-ref catch-block-entry-pc-slot))
(component (catch-ref catch-block-code-slot))
@ -1272,7 +1307,7 @@ register."
(* (- (1+ (get-header-data lra))
(code-header-words component))
n-word-bytes)))
#+(or x86 x86-64)
#+(or x86 x86-64 arm64)
(catch-entry-offset ()
(let* ((ra (sap-ref-sap
catch (* catch-block-entry-pc-slot
@ -3493,7 +3528,10 @@ register."
;;; state of the program, not merely a return PC location.
;;; (I tried changing this to DEFUN-CACHED, which failed a regression test)
(defun make-bpt-lra (real-lra)
(declare (type #-(or x86 x86-64) lra #+(or x86 x86-64) system-area-pointer real-lra))
(declare (type #-(or x86 x86-64 arm64) lra #+(or x86 x86-64 arm64) system-area-pointer real-lra))
real-lra
#+arm64 (error "Breakpoints do not work on ARM64")
#-arm64
(macrolet ((symbol-addr (name)
`(find-dynamic-foreign-symbol-address ,name))
(trap-offset ()
@ -3504,25 +3542,25 @@ register."
(length (the index (- (symbol-addr "fun_end_breakpoint_end")
src-start)))
(code-object
(sb-c:allocate-code-object
nil 0
;; For non-x86: a single boxed constant holds the true LRA.
;; For x86[-64]: one boxed constant holds the code object to which
;; to return, and one holds the displacement into that object.
;; Ensure required boxed header alignment.
(align-up (+ sb-vm:code-constants-offset 1 #+(or x86-64 x86) 1)
sb-c::code-boxed-words-align)
(+ length
sb-vm:n-word-bytes ; Jump Table prefix word
;; Alignment padding, LRA header
#-(or x86 x86-64) (* 2 sb-vm:n-word-bytes)
;; 2 extra raw bytes represent CODE-N-ENTRIES (which is zero)
2))))
(sb-c:allocate-code-object
nil 0
;; For non-x86: a single boxed constant holds the true LRA.
;; For x86[-64]: one boxed constant holds the code object to which
;; to return, and one holds the displacement into that object.
;; Ensure required boxed header alignment.
(align-up (+ sb-vm:code-constants-offset 1 #+(or x86-64 x86) 1)
sb-c::code-boxed-words-align)
(+ length
sb-vm:n-word-bytes ; Jump Table prefix word
;; Alignment padding, LRA header
#-(or x86 x86-64) (* 2 sb-vm:n-word-bytes)
;; 2 extra raw bytes represent CODE-N-ENTRIES (which is zero)
2))))
(setf (%code-debug-info code-object) :bpt-lra)
(with-pinned-objects (code-object)
#+(or x86 x86-64)
(let ((instructions ; Don't touch the jump table prefix word
(sap+ (code-instructions code-object) sb-vm:n-word-bytes)))
#+(or x86 x86-64 arm64)
(let ((instructions ; Don't touch the jump table prefix word
(sap+ (code-instructions code-object) sb-vm:n-word-bytes)))
(multiple-value-bind (offset code) (compute-lra-data-from-pc real-lra)
(setf (code-header-ref code-object real-lra-slot) code
(code-header-ref code-object (1+ real-lra-slot)) offset)
@ -3533,10 +3571,10 @@ register."
;; TRAP-OFFSET is the distance from CODE-INSTRUCTIONS to the trapping
;; opcode, for which we have to account for the jump table prefix word.
(values instructions code-object (+ (trap-offset) sb-vm:n-word-bytes))))
#-(or x86 x86-64)
#-(or x86 x86-64 arm64)
(let* ((lra-header-addr
;; Skip over the jump table prefix, and align properly for LRA header
(sap+ (code-instructions code-object) (* 2 sb-vm:n-word-bytes)))
;; Skip over the jump table prefix, and align properly for LRA header
(sap+ (code-instructions code-object) (* 2 sb-vm:n-word-bytes)))
;; Compute the LRA->code backpointer in words
(delta (ash (sap- lra-header-addr
(int-sap (logandc2 (get-lisp-obj-address code-object)

2
src/code/pred.lisp
View file

@ -106,7 +106,7 @@
(def-type-predicate-wrapper integerp)
(def-type-predicate-wrapper listp)
(def-type-predicate-wrapper long-float-p)
#-(or x86 x86-64) (def-type-predicate-wrapper lra-p)
#-(or x86 x86-64 arm64) (def-type-predicate-wrapper lra-p)
(def-type-predicate-wrapper null)
(def-type-predicate-wrapper numberp)
(def-type-predicate-wrapper rationalp)

2
src/code/print.lisp
View file

@ -1712,7 +1712,7 @@ variable: an unreadable object representing the error is printed instead.")
(write-string ", " stream)
(output-object (sb-c::debug-info-name dinfo) stream)))))))))
#-(or x86 x86-64)
#-(or x86 x86-64 arm64)
(defmethod print-object ((lra lra) stream)
(print-unreadable-object (lra stream :identity t)
(write-string "return PC object" stream)))

363
src/compiler/arm64/call.lisp
View file

@ -122,7 +122,7 @@
;; Allocate function header.
(inst simple-fun-header-word)
(inst .skip (* (1- simple-fun-insts-offset) n-word-bytes))
(inst compute-code code-tn lip start-lab)))
(inst str lip (@ cfp-tn (* lra-save-offset n-word-bytes)))))
(define-vop (xep-setup-sp)
(:vop-var vop)
@ -190,14 +190,13 @@
;;; -- Reset SP. This must be done whenever other than 1 value is returned,
;;; regardless of the number of values desired.
(defun default-unknown-values (vop values nvals move-temp lip lra-label)
(defun default-unknown-values (vop values nvals move-temp)
(declare (type (or tn-ref null) values)
(type unsigned-byte nvals) (type tn move-temp))
(let ((expecting-values-on-stack (> nvals register-arg-count)))
(note-this-location vop (if (<= nvals 1)
:single-value-return
:unknown-return))
(inst compute-code code-tn lip lra-label)
;; Pick off the single-value case first.
(sb-assem:without-scheduling ()
@ -276,10 +275,9 @@
;;; Args and Nargs are TNs wired to the named locations. We must
;;; explicitly allocate these TNs, since their lifetimes overlap with the
;;; results Start and Count (also, it's nice to be able to target them).
(defun receive-unknown-values (args nargs start count lra-label lip)
(defun receive-unknown-values (args nargs start count)
(declare (type tn args nargs start count))
(assemble ()
(inst compute-code code-tn lip lra-label)
(inst b :eq MULTIPLE)
(move start csp-tn)
(inst add csp-tn csp-tn n-word-bytes)
@ -312,9 +310,12 @@
;;; points, local-call entry points, and tail-call entry points. The default
;;; does nothing.
(defun emit-block-header (start-label trampoline-label fall-thru-p alignp)
(declare (ignore fall-thru-p alignp))
(declare (ignore alignp))
(when (and fall-thru-p trampoline-label)
(inst b start-label))
(when trampoline-label
(emit-label trampoline-label))
(emit-label trampoline-label)
(inst str lr-tn (@ cfp-tn (* lra-save-offset n-word-bytes))))
(emit-label start-label))
@ -636,23 +637,18 @@
(:temporary (:scs (descriptor-reg) :from (:eval 0)) move-temp)
(:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
(:temporary (:sc any-reg :offset ocfp-offset :from (:eval 0)) ocfp)
(:temporary (:scs (interior-reg)) lip)
(:ignore arg-locs args ocfp)
(:generator 5
(let ((label (gen-label))
(cur-nfp (current-nfp-tn vop)))
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
(store-stack-tn nfp-save cur-nfp))
(let ((callee-nfp (callee-nfp-tn callee)))
(when callee-nfp
(maybe-load-stack-tn callee-nfp nfp)))
(maybe-load-stack-tn cfp-tn fp)
(inst compute-lra lip lip label)
(store-stack-tn (callee-return-pc-tn callee) lip)
(note-this-location vop :call-site)
(inst b target)
(emit-return-pc label)
(default-unknown-values vop values nvals move-temp lip label)
(inst bl target)
(default-unknown-values vop values nvals move-temp)
(when cur-nfp
(load-stack-tn cur-nfp nfp-save)))))
@ -674,10 +670,8 @@
(:ignore args save r0-temp)
(:vop-var vop)
(:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
(:temporary (:scs (interior-reg)) lip)
(:generator 20
(let ((label (gen-label))
(cur-nfp (current-nfp-tn vop)))
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
(store-stack-tn nfp-save cur-nfp))
(let ((callee-nfp (callee-nfp-tn callee)))
@ -685,13 +679,10 @@
(when callee-nfp
(maybe-load-stack-tn callee-nfp nfp)))
(maybe-load-stack-tn cfp-tn fp)
(inst compute-lra lip lip label)
(store-stack-tn (callee-return-pc-tn callee) lip)
(note-this-location vop :call-site)
(inst b target)
(emit-return-pc label)
(inst bl target)
(note-this-location vop :unknown-return)
(receive-unknown-values values-start nvals start count label lip)
(receive-unknown-values values-start nvals start count)
(when cur-nfp
(load-stack-tn cur-nfp nfp-save)))))
@ -714,21 +705,16 @@
(:ignore args res save)
(:vop-var vop)
(:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
(:temporary (:scs (interior-reg)) lip)
(:generator 5
(let ((label (gen-label))
(cur-nfp (current-nfp-tn vop)))
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
(store-stack-tn nfp-save cur-nfp))
(let ((callee-nfp (callee-nfp-tn callee)))
(when callee-nfp
(maybe-load-stack-tn callee-nfp nfp)))
(maybe-load-stack-tn cfp-tn fp)
(inst compute-lra lip lip label)
(store-stack-tn (callee-return-pc-tn callee) lip)
(note-this-location vop :call-site)
(inst b target)
(emit-return-pc label)
(inst bl target)
(note-this-location vop :known-return)
(when cur-nfp
(load-stack-tn cur-nfp nfp-save)))))
@ -742,25 +728,24 @@
;;; MAYBE-LOAD-STACK-TN.
(define-vop (known-return)
(:args (old-fp :target old-fp-temp)
(return-pc :target return-pc-temp)
(return-pc)
(vals :more t))
(:temporary (:sc any-reg :from (:argument 0)) old-fp-temp)
(:temporary (:sc descriptor-reg :from (:argument 1)) return-pc-temp)
(:temporary (:scs (interior-reg)) lip)
(:move-args :known-return)
(:info val-locs)
(:ignore val-locs vals)
(:vop-var vop)
(:generator 6
(maybe-load-stack-tn old-fp-temp old-fp)
(maybe-load-stack-tn return-pc-temp return-pc)
(move csp-tn cfp-tn)
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
(inst add nsp-tn cur-nfp (add-sub-immediate
(bytes-needed-for-non-descriptor-stack-frame)))))
(move cfp-tn old-fp-temp)
(lisp-return return-pc-temp lip :known)))
(maybe-load-stack-tn old-fp-temp old-fp)
(maybe-load-stack-tn lip return-pc)
(move csp-tn cfp-tn)
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
(inst add nsp-tn cur-nfp (add-sub-immediate
(bytes-needed-for-non-descriptor-stack-frame)))))
(move cfp-tn old-fp-temp)
(lisp-return lip :known)))
;;;; Full call:
;;;
@ -801,6 +786,7 @@
;;; In tail call with fixed arguments, the passing locations are passed as a
;;; more arg, but there is no new-FP, since the arguments have been set up in
;;; the current frame.
(defmacro define-full-call (name named return variable)
(aver (not (and variable (eq return :tail))))
`(define-vop (,name
@ -811,11 +797,11 @@
'((new-fp :scs (any-reg) :to :eval)))
,@(case named
((nil)
'((arg-fun :target lexenv)))
(:direct)
(t
'((name :target name-pass))))
((nil)
'((arg-fun :target lexenv)))
(:direct)
(t
'((name :target name-pass))))
,@(when (eq return :tail)
'((old-fp)
@ -850,8 +836,10 @@
`((:temporary (:sc descriptor-reg :offset lexenv-offset
:from (:argument ,(if (eq return :tail) 0 1))
:to :eval)
,(if named 'name-pass 'lexenv))
(:temporary (:scs (descriptor-reg) :to :eval)
,(if named 'name-pass 'lexenv))))
,@(unless named
`((:temporary (:scs (descriptor-reg) :to :eval)
function)))
(:temporary (:sc any-reg :offset nargs-offset :to
@ -865,7 +853,7 @@
`(:temporary (:sc descriptor-reg
:offset ,offset
:to :result)
,name))
,name))
*register-arg-names* *register-arg-offsets*))
,@(when (eq return :fixed)
'((:temporary (:scs (descriptor-reg) :from :eval) move-temp)
@ -881,143 +869,130 @@
(if (eq return :tail) 0 10)
15
(if (eq return :unknown) 25 0))
(let* ((cur-nfp (current-nfp-tn vop))
,@(unless (eq return :tail)
'((lra-label (gen-label))))
(filler
(remove nil
(list ,@(if (eq return :tail)
'(:load-nargs
(unless (location= return-pc
(make-random-tn :kind :normal
:sc (sc-or-lose 'control-stack)
:offset lra-save-offset))
:load-return-pc)
(when cur-nfp
:frob-nfp))
'(:load-nargs
:comp-lra
(when cur-nfp
:frob-nfp)
:load-fp))))))
(flet ((do-next-filler ()
(let* ((next (pop filler))
(what (if (consp next) (car next) next)))
(ecase what
(:load-nargs
,@(if variable
`((move nargs-pass csp-tn)
;; The variable args are on the stack
;; and become the frame, but there may
;; be <4 args and 2 stack slots are
;; assumed allocate on the call. So
;; need to ensure there are at least 2
;; slots. This just adds 2 more.
(inst add csp-tn nargs-pass (* 2 n-word-bytes))
(inst sub nargs-pass nargs-pass new-fp)
(inst asr nargs-pass nargs-pass (- word-shift n-fixnum-tag-bits))
,@(do ((arg *register-arg-names* (cddr arg))
(i 0 (+ i 2))
(insts))
((null arg) (nreverse insts))
#.(assert (evenp register-arg-count))
(push `(inst ldp ,(first arg) ,(second arg)
(@ new-fp ,(* i n-word-bytes)))
insts))
(storew cfp-tn new-fp ocfp-save-offset))
'((load-immediate-word nargs-pass (fixnumize nargs)))))
,@(if (eq return :tail)
'((:load-return-pc
(error "RETURN-PC not in its passing location"))
(:frob-nfp
(inst add nsp-tn cur-nfp (add-sub-immediate
(bytes-needed-for-non-descriptor-stack-frame)))))
`((:comp-lra
(inst compute-lra lip lip lra-label)
(inst str lip (@ new-fp (* lra-save-offset
n-word-bytes))))
(:frob-nfp
(store-stack-tn nfp-save cur-nfp))
(:load-fp
(move cfp-tn new-fp))))
((nil)))))
(insert-step-instrumenting ()
;; Conditionally insert a conditional trap:
(when step-instrumenting
(assemble ()
#-sb-thread
(load-symbol-value tmp-tn sb-impl::*stepping*)
#+sb-thread
(loadw tmp-tn thread-tn thread-stepping-slot)
(inst cbz tmp-tn step-done-label)
;; CONTEXT-PC will be pointing here when the
;; interrupt is handled, not after the
;; DEBUG-TRAP.
(note-this-location vop :internal-error)
(inst brk single-step-around-trap)
STEP-DONE-LABEL))))
(declare (ignorable #'insert-step-instrumenting))
,@(case named
((t)
`((sc-case name
(descriptor-reg (move name-pass name))
(control-stack
(load-stack-tn name-pass name)
(do-next-filler))
(constant
(load-constant vop name name-pass)
(do-next-filler)))
(do-next-filler)
(insert-step-instrumenting)))
((nil)
`((sc-case arg-fun
(descriptor-reg (move lexenv arg-fun))
(control-stack
(load-stack-tn lexenv arg-fun)
(do-next-filler))
(constant
(load-constant vop arg-fun lexenv)
(do-next-filler)))
(insert-step-instrumenting)
(loadw function lexenv closure-fun-slot
fun-pointer-lowtag)
(do-next-filler))))
(loop
(if filler
(do-next-filler)
(return)))
,@(ecase named
;; raw-addr is an untagged pointer to the function,
;; need to pair it up with the tagged pointer for the GC to see
((t)
`((loadw function name-pass fdefn-fun-slot
other-pointer-lowtag)
(loadw lip name-pass fdefn-raw-addr-slot
other-pointer-lowtag)))
(:direct
`((inst ldr lip (@ null-tn (load-store-offset (static-fun-offset fun))))))
((nil)
`((inst add lip function
(- (ash simple-fun-insts-offset word-shift)
fun-pointer-lowtag)))))
(let* ((cur-nfp (current-nfp-tn vop))
(filler
(remove nil
(list ,@(if (eq return :tail)
'(:load-nargs
:load-return-pc
(when cur-nfp
:frob-nfp))
'(:load-nargs
(when cur-nfp
:frob-nfp)
:load-fp))))))
(flet ((do-next-filler ()
(let* ((next (pop filler))
(what (if (consp next) (car next) next)))
(ecase what
(:load-nargs
,@(if variable
`((move nargs-pass csp-tn)
;; The variable args are on the stack
;; and become the frame, but there may
;; be <4 args and 2 stack slots are
;; assumed allocate on the call. So
;; need to ensure there are at least 2
;; slots. This just adds 2 more.
(inst add csp-tn nargs-pass (* 2 n-word-bytes))
(inst sub nargs-pass nargs-pass new-fp)
(inst asr nargs-pass nargs-pass (- word-shift n-fixnum-tag-bits))
,@(do ((arg *register-arg-names* (cddr arg))
(i 0 (+ i 2))
(insts))
((null arg) (nreverse insts))
#.(assert (evenp register-arg-count))
(push `(inst ldp ,(first arg) ,(second arg)
(@ new-fp ,(* i n-word-bytes)))
insts))
(storew cfp-tn new-fp ocfp-save-offset))
'((load-immediate-word nargs-pass (fixnumize nargs)))))
,@(if (eq return :tail)
'((:load-return-pc
(maybe-load-stack-tn lip return-pc))
(:frob-nfp
(inst add nsp-tn cur-nfp (add-sub-immediate
(bytes-needed-for-non-descriptor-stack-frame)))))
`((:frob-nfp
(store-stack-tn nfp-save cur-nfp))
(:load-fp
(move cfp-tn new-fp))))
((nil)))))
(insert-step-instrumenting ()
;; Conditionally insert a conditional trap:
(when step-instrumenting
(assemble ()
#-sb-thread
(load-symbol-value tmp-tn sb-impl::*stepping*)
#+sb-thread
(loadw tmp-tn thread-tn thread-stepping-slot)
(inst cbz tmp-tn step-done-label)
;; CONTEXT-PC will be pointing here when the
;; interrupt is handled, not after the
;; DEBUG-TRAP.
(note-this-location vop :internal-error)
(inst brk single-step-around-trap)
STEP-DONE-LABEL))))
(declare (ignorable #'insert-step-instrumenting))
,@(case named
((t)
`((sc-case name
(descriptor-reg (move name-pass name))
(control-stack
(load-stack-tn name-pass name)
(do-next-filler))
(constant
(load-constant vop name name-pass)
(do-next-filler)))
(do-next-filler)
(insert-step-instrumenting)))
((nil)
`((sc-case arg-fun
(descriptor-reg (move lexenv arg-fun))
(control-stack
(load-stack-tn lexenv arg-fun)
(do-next-filler))
(constant
(load-constant vop arg-fun lexenv)
(do-next-filler)))
(insert-step-instrumenting)
(loadw function lexenv closure-fun-slot
fun-pointer-lowtag)
(do-next-filler))))
(loop
(if filler
(do-next-filler)
(return)))
(let ((lip ,(if (eq return :tail)
'lr2-tn
'lip)))
,@(ecase named
((t)
`((loadw lip name-pass fdefn-raw-addr-slot other-pointer-lowtag)))
(:direct
`((inst ldr lip (@ null-tn (load-store-offset (static-fun-offset fun))))))
((nil)
`((inst add lip function
(- (ash simple-fun-insts-offset word-shift)
fun-pointer-lowtag)))))
(note-this-location vop :call-site)
(inst br lip))
(note-this-location vop :call-site)
,@(ecase return
(:fixed
'((emit-return-pc lra-label)
(default-unknown-values vop values nvals move-temp lip lra-label)
(when cur-nfp
(load-stack-tn cur-nfp nfp-save))))
(:unknown
'((emit-return-pc lra-label)
(note-this-location vop :unknown-return)
(receive-unknown-values values-start nvals start count
lra-label lip)
(when cur-nfp
(load-stack-tn cur-nfp nfp-save))))
(:tail))))))
,(if (eq return :tail)
`(inst br lip)
`(inst blr lip))))
,@(ecase return
(:fixed
'((default-unknown-values vop values nvals move-temp)
(when cur-nfp
(load-stack-tn cur-nfp nfp-save))))
(:unknown
'((note-this-location vop :unknown-return)
(receive-unknown-values values-start nvals start count)
(when cur-nfp
(load-stack-tn cur-nfp nfp-save))))
(:tail))))))
(define-full-call call nil :fixed nil)
(define-full-call call-named t :fixed nil)
@ -1062,7 +1037,7 @@
;;; Return a single value using the unknown-values convention.
(define-vop (return-single)
(:args (old-fp :scs (any-reg) :to :eval)
(return-pc :scs (descriptor-reg))
(return-pc)
(value))
(:temporary (:scs (interior-reg)) lip)
(:ignore value)
@ -1073,12 +1048,14 @@
(when cur-nfp
(inst add nsp-tn cur-nfp (add-sub-immediate
(bytes-needed-for-non-descriptor-stack-frame)))))
(maybe-load-stack-tn lip return-pc)
;; Clear the control stack, and restore the frame pointer.
(move csp-tn cfp-tn)
(move cfp-tn old-fp)
;; Out of here.
(lisp-return return-pc lip :single-value)))
(lisp-return lip :single-value)))
;;; Do unknown-values return of a fixed number of values. The Values are
;;; required to be set up in the standard passing locations. Nvals is the
@ -1095,7 +1072,7 @@
(define-vop (return)
(:args
(old-fp :scs (any-reg))
(return-pc :scs (descriptor-reg) :to (:eval 1))
(return-pc)
(values :more t))
(:ignore values)
(:info nvals)
@ -1113,12 +1090,13 @@
(when cur-nfp
(inst add nsp-tn cur-nfp (add-sub-immediate
(bytes-needed-for-non-descriptor-stack-frame)))))
(maybe-load-stack-tn lip return-pc)
(cond ((= nvals 1)
;; Clear the control stack, and restore the frame pointer.
(move csp-tn cfp-tn)
(move cfp-tn old-fp)
;; Out of here.
(lisp-return return-pc lip :single-value))
(lisp-return lip :single-value))
(t
;; Establish the values pointer.
(move val-ptr cfp-tn)
@ -1133,7 +1111,7 @@
(dolist (reg (subseq (list r0 r1 r2 r3) nvals))
(move reg null-tn)))
;; And away we go.
(lisp-return return-pc lip :multiple-values)))))
(lisp-return lip :multiple-values)))))
;;; Do unknown-values return of an arbitrary number of values (passed
;;; on the stack.) We check for the common case of a single return
@ -1143,18 +1121,17 @@
(define-vop (return-multiple)
(:args
(old-fp-arg :scs (any-reg) :to (:eval 1))
(lra-arg :scs (descriptor-reg) :to (:eval 1))
(lra-arg)
(vals-arg :scs (any-reg) :target vals)
(nvals-arg :scs (any-reg) :target nvals))
(:temporary (:sc any-reg :offset nl2-offset :from (:argument 0)) old-fp)
(:temporary (:sc descriptor-reg :offset r6-offset :from (:argument 1)) lra)
(:temporary (:sc any-reg :offset nl1-offset :from (:argument 2)) vals)
(:temporary (:sc any-reg :offset nargs-offset :from (:argument 3)) nvals)
(:temporary (:sc descriptor-reg :offset r0-offset) r0)
(:temporary (:sc interior-reg) lip)
(:vop-var vop)
(:generator 13
(move lra lra-arg)
(maybe-load-stack-tn lip lra-arg)
;; Clear the number stack.
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
@ -1169,7 +1146,7 @@
(inst ldr r0 (@ vals-arg))
(move csp-tn cfp-tn)
(move cfp-tn old-fp-arg)
(lisp-return lra lip :single-value)
(lisp-return lip :single-value)
NOT-SINGLE
(move old-fp old-fp-arg)

4
src/compiler/arm64/debug.lisp
View file

@ -72,10 +72,6 @@
(inst sub code thing temp)
DONE))
(define-vop (code-from-lra code-from-mumble)
(:translate sb-di::lra-code-header)
(:variant other-pointer-lowtag))
(define-vop (code-from-fun code-from-mumble)
(:translate sb-di::fun-code-header)
(:variant fun-pointer-lowtag))

180
src/compiler/arm64/insts.lisp
View file

@ -165,24 +165,18 @@
(integer
(emit-dword segment word)))))
(defun emit-header-data (segment type)
(emit-back-patch segment
8
(lambda (segment posn)
(emit-dword segment
(logior type
(ash (+ posn
(component-header-length))
(- n-widetag-bits
word-shift)))))))
(define-instruction simple-fun-header-word (segment)
(:emitter
(emit-header-data segment simple-fun-widetag)))
(emit-back-patch segment
8
(lambda (segment posn)
(emit-dword segment
(logior simple-fun-widetag
(ash (+ posn
(component-header-length))
(- n-widetag-bits
word-shift))))))))
(define-instruction lra-header-word (segment)
(:emitter
(emit-header-data segment return-pc-widetag)))
;;;; Addressing mode 1 support
@ -1749,7 +1743,7 @@
(not label))
(note-fixup segment :uncond-branch cond-or-label)
(emit-uncond-branch segment 0 0))
((and (fixup-p label))
((fixup-p label)
(note-fixup segment :cond-branch cond-or-label)
(emit-cond-branch segment 0 (conditional-opcode cond-or-label)))
(t
@ -1770,7 +1764,7 @@
(define-instruction bl (segment label)
(:printer uncond-branch ((op 1)))
(:emitter
(ecase label
(etypecase label
(fixup
(note-fixup segment :uncond-branch label)
(emit-uncond-branch segment 1 0))
@ -2388,70 +2382,6 @@
#b111)
(tn-offset rn) (tn-offset rd)))))))
;;;; Boxed-object computation instructions (for LRA and CODE)
;;; Compute the address of a CODE object by parsing the header of a
;;; nearby LRA or SIMPLE-FUN.
(defun emit-compute (segment vop dest lip compute-delta)
(labels ((multi-instruction-emitter (segment position)
(let* ((delta (funcall compute-delta position))
(negative (minusp delta))
(delta (abs delta))
(low (* (if negative -1 1)
(ldb (byte 19 0) delta)))
(high (ldb (byte 16 19) delta)))
;; ADR
(emit-pc-relative segment 0
(ldb (byte 2 0) low)
(ldb (byte 19 2) low)
(tn-offset lip))
(assemble (segment vop)
(inst movz dest high 16)
(if negative
(inst sub dest lip (lsl dest 3))
(inst add dest lip (lsl dest 3))))))
(one-instruction-emitter (segment position)
(let ((delta (funcall compute-delta position)))
;; ADR
(emit-pc-relative segment 0
(ldb (byte 2 0) delta)
(ldb (byte 19 2) delta)
(tn-offset dest))))
(multi-instruction-maybe-shrink (segment chooser posn magic-value)
(declare (ignore chooser))
(when (typep (funcall compute-delta posn magic-value)
'(signed-byte 21))
(emit-back-patch segment 4
#'one-instruction-emitter)
t)))
(emit-chooser
segment 12 2
#'multi-instruction-maybe-shrink
#'multi-instruction-emitter)))
(define-instruction compute-code (segment code lip object-label)
(:vop-var vop)
(:declare (ignore object-label))
(:emitter
(emit-compute segment vop code lip
(lambda (position &optional magic-value)
(declare (ignore magic-value))
(- other-pointer-lowtag
position
(component-header-length))))))
(define-instruction compute-lra (segment dest lip lra-label)
(:vop-var vop)
(:emitter
(emit-compute segment vop dest lip
(lambda (position &optional magic-value)
(- (+ (label-position lra-label
(when magic-value position)
magic-value)
other-pointer-lowtag)
position)))))
(define-instruction load-from-label (segment dest label &optional lip)
(:vop-var vop)
(:emitter
@ -2497,9 +2427,56 @@
#'multi-instruction-emitter)
(emit-back-patch segment 4 #'one-instruction-emitter)))))
(define-instruction load-constant (segment dest index &optional lip)
(:vop-var vop)
(:emitter
(labels ((compute-delta (position &optional magic-value)
(+ (- (label-position (segment-origin segment)
(when magic-value position)
magic-value)
(component-header-length)
position)
index))
(multi-instruction-emitter (segment position)
(let* ((delta (compute-delta position))
(negative (minusp delta))
(low (ldb (byte 19 0) delta))
(high (ldb (byte 16 19) delta)))
;; ADR
(emit-pc-relative segment 0
(ldb (byte 2 0) low)
(ldb (byte 19 2) low)
(tn-offset lip))
(assemble (segment vop)
(inst movz dest high 16)
(inst ldr dest (@ lip (extend dest (if negative
:sxtw
:lsl)
3))))))
(one-instruction-emitter (segment position)
(emit-ldr-literal segment
#b01
0
(ldb (byte 19 0)
(ash (compute-delta position) -2))
(tn-offset dest)))
(multi-instruction-maybe-shrink (segment chooser posn magic-value)
(declare (ignore chooser))
(let ((delta (compute-delta posn magic-value)))
(when (typep delta '(signed-byte 21))
(emit-back-patch segment 4
#'one-instruction-emitter)
t))))
(if lip
(emit-chooser
segment 12 2
#'multi-instruction-maybe-shrink
#'multi-instruction-emitter)
(emit-back-patch segment 4 #'one-instruction-emitter)))))
;;; SIMD
(def-emitter simd-three-diff
(#b0 1 31)
(#b0 1 31)
(q 1 30)
(u 1 29)
(#b01110 5 24)
@ -2877,10 +2854,15 @@
(ash (- value (+ (sap-int sap) offset)) -2)))))
nil)
(define-instruction store-coverage-mark (segment path-index temp #+darwin-jit vector)
;;; Even though non darwin-jit arm64 targets can store directly in the
;;; code object, having two codepaths is cumbersome and, now that
;;; there's no reg-code, STRB needs to load a literal first, which
;;; isn't clearly a win compared to using a vector.
(define-instruction store-coverage-mark (segment path-index temp vector)
(:emitter
;; No backpatch is needed to compute the offset into the code header
;; because COMPONENT-HEADER-LENGTH is known at this point.
segment path-index temp vector
(flet ((encode-index (offset &optional word)
(cond
((if word
@ -2896,28 +2878,14 @@
temp)
(t
(error "Bad offset ~a" offset)))))
#-darwin-jit
(let* ((offset (+ (component-header-length)
n-word-bytes ; skip over jump table word
path-index
(- other-pointer-lowtag)))
(addr
(@ sb-vm::code-tn (encode-index offset))))
(inst* segment 'strb sb-vm::null-tn addr))
#+darwin-jit
(let* ((vector-offset (-
(* n-word-bytes
(let* ((vector-offset (* n-word-bytes
(- (length (ir2-component-constants
(component-info *component-being-compiled*)))
2))
other-pointer-lowtag))
(vector-addr
(@ sb-vm::code-tn
(encode-index vector-offset t)))
(offset (+ (* sb-vm:vector-data-offset n-word-bytes)
path-index
(- other-pointer-lowtag)))
(addr
(@ vector (encode-index offset))))
(inst* segment 'ldr vector vector-addr)
(inst* segment 'strb sb-vm::null-tn addr)))))
2)))
(offset (+ (* sb-vm:vector-data-offset n-word-bytes)
path-index
(- other-pointer-lowtag)))
(addr
(@ vector (encode-index offset))))
(inst* segment 'load-constant vector vector-offset)
(inst* segment 'strb sb-vm::null-tn addr)))))

16
src/compiler/arm64/macros.lisp
View file

@ -106,26 +106,16 @@
fun-pointer-lowtag))
(inst br lip)))
(defmacro lisp-return (function lip return-style)
(defmacro lisp-return (lip return-style)
"Return to RETURN-PC."
`(let* ((function ,function)
(lip ,lip))
`(let* ((lip ,lip))
(aver (sc-is lip interior-reg))
;; Indicate a single-valued return by clearing the Z flag
,@(ecase return-style
(:single-value '((inst cmp null-tn 0)))
(:multiple-values '((inst cmp zr-tn zr-tn)))
(:known))
(inst sub lip function (- other-pointer-lowtag 8))
(inst ret lip)))
(defmacro emit-return-pc (label)
"Emit a return-pc header word. LABEL is the label to use for this return-pc."
`(progn
(emit-alignment n-lowtag-bits)
(emit-label ,label)
(inst lra-header-word)))
;;;; Stack TN's
@ -156,7 +146,7 @@
(once-only ((n-reg reg)
(n-stack reg-or-stack))
`(sc-case ,n-reg
((any-reg descriptor-reg)
((any-reg descriptor-reg interior-reg)
(sc-case ,n-stack
((any-reg descriptor-reg)
(move ,n-reg ,n-stack))

8
src/compiler/arm64/move.lisp
View file

@ -90,13 +90,7 @@
(define-move-fun (load-constant 5) (vop x y)
((constant) (descriptor-reg))
(let ((offset (- (tn-byte-offset x) other-pointer-lowtag)))
(cond
((ldr-str-offset-encodable offset)
(inst ldr y (@ code-tn offset)))
(t
(load-immediate-word tmp-tn offset)
(inst ldr y (@ code-tn tmp-tn))))))
(inst load-constant y (tn-byte-offset x)))
(define-move-fun (load-stack 5) (vop x y)
((control-stack) (any-reg descriptor-reg))

29
src/compiler/arm64/nlx.lisp
View file

@ -48,14 +48,13 @@
(:info entry-label)
(:results (block :scs (any-reg)))
(:temporary (:scs (descriptor-reg)) temp)
(:temporary (:scs (interior-reg)) lip)
(:vop-var vop)
(:generator 22
(inst add block cfp-tn (add-sub-immediate (tn-byte-offset tn)))
(load-tl-symbol-value temp *current-unwind-protect-block*)
(storew-pair temp unwind-block-uwp-slot cfp-tn unwind-block-cfp-slot block)
(inst compute-lra temp lip entry-label)
(storew-pair code-tn unwind-block-code-slot temp unwind-block-entry-pc-slot block)
(inst adr temp entry-label)
(storew temp block unwind-block-entry-pc-slot)
#+sb-thread
(loadw-pair
temp (/ (info :variable :wired-tls '*binding-stack-pointer*) n-word-bytes)
@ -79,14 +78,13 @@
(:info entry-label)
(:results (block :scs (any-reg)))
(:temporary (:scs (descriptor-reg)) temp)
(:temporary (:scs (interior-reg)) lip)
(:vop-var vop)
(:generator 44
(inst add block cfp-tn (add-sub-immediate (tn-byte-offset tn)))
(load-tl-symbol-value temp *current-unwind-protect-block*)
(storew-pair temp catch-block-uwp-slot cfp-tn catch-block-cfp-slot block)
(inst compute-lra temp lip entry-label)
(storew-pair code-tn catch-block-code-slot temp catch-block-entry-pc-slot block)
(inst adr temp entry-label)
(storew temp block catch-block-entry-pc-slot)
#+sb-thread
(loadw-pair
@ -145,7 +143,7 @@
(:save-p :force-to-stack)
(:vop-var vop)
(:generator 30
(emit-return-pc label)
(emit-label label)
(note-this-location vop :non-local-entry)
(cond ((zerop nvals))
((= nvals 1)
@ -191,7 +189,7 @@
(:save-p :force-to-stack)
(:vop-var vop)
(:generator 30
(emit-return-pc label)
(emit-label label)
(note-this-location vop :non-local-entry)
;; Setup results, and test for the zero value case.
@ -227,10 +225,9 @@
(:ignore block start count)
(:vop-var vop)
(:generator 0
(emit-return-pc label)
(emit-label label)
(note-this-location vop :non-local-entry)))
;;; Doesn't handle NSP and is disabled.
#+unwind-to-frame-and-call-vop
(define-vop (unwind-to-frame-and-call)
(:args (ofp :scs (descriptor-reg))
@ -269,21 +266,21 @@
(storew nsp block unwind-block-nsp-slot)
(storew zr-tn block unwind-block-nfp-slot)
(storew catch-block block unwind-block-current-catch-slot)
;; Don't need to save code at unwind-block-code-slot since
;; it's not going to be used and will be overwritten after the
;; function call
(inst compute-lra temp lip entry-label)
(inst adr temp entry-label)
(storew temp block catch-block-entry-pc-slot)
;; Run any required UWPs.
(load-inline-constant tmp-tn '(:fixup unwind :assembly-routine) lip)
(inst br tmp-tn)
(emit-return-pc ENTRY-LABEL)
(emit-label ENTRY-LABEL)
(inst mov nargs 0)
(move lexenv saved-function)
(loadw lip cfp-tn lra-save-offset)
(loadw saved-function lexenv closure-fun-slot fun-pointer-lowtag)
(lisp-jump saved-function lip))))
(lisp-jump saved-function lr2-tn))))

3
src/compiler/arm64/system.lisp
View file

@ -332,9 +332,8 @@
(define-vop (sb-c::mark-covered)
(:info index)
(:temporary (:sc unsigned-reg) tmp)
#+darwin-jit
(:temporary (:sc descriptor-reg) vector)
(:generator 4
;; Can't compute code-tn-relative index until the boxed header length
;; is known. Some vops emit new boxed words via EMIT-CONSTANT.
(inst store-coverage-mark index tmp #+darwin-jit vector)))
(inst store-coverage-mark index tmp vector)))

15
src/compiler/arm64/target-insts.lisp
View file

@ -315,8 +315,6 @@
(defun annotate-ldr-str (register offset dstate)
(case register
(#.sb-vm::code-offset
(note-code-constant offset dstate))
(#.sb-vm::null-offset
(let ((offset (+ sb-vm:nil-value offset)))
(maybe-note-static-symbol (logior offset other-pointer-lowtag)
@ -365,9 +363,16 @@
(defun annotate-ldr-literal (value stream dstate)
(declare (ignore stream))
(let* ((addr (+ (dstate-cur-addr dstate) (* value 4))))
(let ((value (sap-ref-word (int-sap addr) 0)))
(maybe-note-assembler-routine value nil dstate))))
(let* ((value (* 4 value))
(seg (dstate-segment dstate))
(code (seg-code seg)))
(or (and code
(note-code-constant (sb-disassem::segment-offs-to-code-offs
(+ (dstate-cur-offs dstate) value) seg)
dstate))
(let* ((addr (+ (dstate-cur-addr dstate) value))
(value (sap-ref-word (int-sap addr) 0)))
(maybe-note-assembler-routine value nil dstate)))))
;;;; special magic to support decoding internal-error and related traps
(defun snarf-error-junk (sap offset trap-number &optional length-only)

13
src/compiler/arm64/vm.lisp
View file

@ -69,23 +69,23 @@
(defreg csp 26)
(defreg tmp 27)
(defreg null 28)
(defreg code 29)
(defreg lr2 29)
(defreg lr 30)
(defreg nsp 31)
(defreg zr 31)
(defregset system-regs
null cfp nsp lr code)
null cfp nsp lr lr2)
(defregset descriptor-regs
r0 r1 r2 r3 r4 r5 r6 r7 #-darwin r8 r9 #-sb-thread r10 lexenv)
r0 r1 r2 r3 r4 r5 r6 #+nil r7 #-darwin r8 r9 #-sb-thread r10 lexenv)
(defregset non-descriptor-regs
nl0 nl1 nl2 nl3 nl4 nl5 nl6 nl7 nl8 nl9 nargs nfp ocfp)
(defregset boxed-regs
r0 r1 r2 r3 r4 r5 r6
r7 #-darwin r8 r9 #-sb-thread r10 #+sb-thread thread lexenv code)
r7 #-darwin r8 r9 #-sb-thread r10 #+sb-thread thread lexenv)
;; registers used to pass arguments
;;
@ -188,7 +188,8 @@
;; Pointers to the interior of objects. Used only as a temporary.
(interior-reg registers
:locations (#.lr-offset))
:locations (#.lr-offset ;; #.r7-offset
))
;; **** Things that can go in the floating point registers.
@ -233,7 +234,6 @@
(defregtn null descriptor-reg)
(defregtn lexenv descriptor-reg)
(defregtn code descriptor-reg)
(defregtn tmp any-reg)
(defregtn nargs any-reg)
@ -243,6 +243,7 @@
(defregtn cfp any-reg)
(defregtn csp any-reg)
(defregtn lr interior-reg)
(defregtn lr2 interior-reg)
#+sb-thread
(defregtn thread interior-reg))

4
src/compiler/codegen.lisp
View file

@ -372,7 +372,7 @@
#+(or x86 x86-64) (coverage-mark-lowering-pass component asmstream)
#-(or x86 x86-64)
(when coverage-map
#+darwin-jit
#+arm64
(vector-push-extend (make-constant (make-array (length coverage-map)
:element-type '(unsigned-byte 8)
:initial-element #xFF))
@ -381,7 +381,7 @@
(ir2-component-constants ir2-component))
;; The mark vop can store the low byte from either ZERO-TN or NULLL-TN
;; to avoid loading a constant. Either one won't match #xff.
#-darwin-jit
#-arm64
(emit (asmstream-data-section asmstream)
`(.skip ,(length coverage-map) #xff)))

4
src/compiler/generic/early-objdef.lisp
View file

@ -226,8 +226,8 @@
funcallable-instance-widetag ; 36 3D 36 3D
;; x86[-64] does not have objects with this widetag,
#-(or x86 x86-64) return-pc-widetag ; 3A 41 3A 41
#+(or x86 x86-64) lra-widetag-notused
#-(or x86 x86-64 arm64) return-pc-widetag ; 3A 41 3A 41
#+(or x86 x86-64 arm64) lra-widetag-notused
value-cell-widetag ; 3E 45 3E 45
character-widetag ; 42 49 42 49

2
src/compiler/generic/late-objdef.lisp
View file

@ -64,7 +64,7 @@
;; Like closure, but these can also have a layout pointer in the high header bytes.
(funcallable-instance "funinstance" "lose" "short_boxed")
;; These have a scav and trans function, but no size function.
#-(or x86 x86-64) (return-pc "return_pc_header" "return_pc_header" "lose")
#-(or x86 x86-64 arm64) (return-pc "return_pc_header" "return_pc_header" "lose")
(value-cell "boxed")
(symbol "tiny_boxed")

6
src/compiler/generic/objdef.lisp
View file

@ -259,7 +259,7 @@ during backtrace.
(defconstant simple-fun-source-slot 2) ; form and/or docstring
(defconstant simple-fun-info-slot 3) ; type and possibly xref
#-(or x86 x86-64)
#-(or x86 x86-64 arm64)
(define-primitive-object (return-pc :lowtag other-pointer-lowtag :widetag t)
(return-point :c-type "unsigned char" :rest-p t))
@ -328,7 +328,7 @@ during backtrace.
(define-primitive-object (unwind-block)
(uwp :c-type "struct unwind_block *")
(cfp :c-type "lispobj *")
#-(or x86 x86-64) code
#-(or x86 x86-64 arm64) code
entry-pc
#+(and win32 x86) next-seh-frame
#+(and win32 x86) seh-frame-handler
@ -340,7 +340,7 @@ during backtrace.
(define-primitive-object (catch-block)
(uwp :c-type "struct unwind_block *")
(cfp :c-type "lispobj *")
#-(or x86 x86-64) code
#-(or x86 x86-64 arm64) code
entry-pc
#+(and win32 x86) next-seh-frame
#+(and win32 x86) seh-frame-handler

2
src/compiler/generic/type-vops.lisp
View file

@ -319,7 +319,7 @@
(define-type-vop code-component-p (code-header-widetag))
#-(or x86 x86-64) (define-type-vop lra-p (return-pc-widetag))
#-(or x86 x86-64 arm64) (define-type-vop lra-p (return-pc-widetag))
(define-type-vop fdefn-p (fdefn-widetag))

8
src/compiler/target-disassem.lisp
View file

@ -360,7 +360,7 @@
(type alignment size))
(zerop (logand (1- size) address)))
#-(or x86 x86-64)
#-(or x86 x86-64 arm64)
(progn
(defconstant lra-size (words-to-bytes 1))
(defun lra-hook (chunk stream dstate)
@ -1401,7 +1401,7 @@
(format stream "#X~2,'0x" (sap-ref-8 sap (+ offs start-offs))))))
(defvar *default-dstate-hooks*
(list* #-(or x86 x86-64) #'lra-hook nil))
(list* #-(or x86 x86-64 arm64) #'lra-hook nil))
;;; Make a disassembler-state object.
(defun make-dstate (&optional (fun-hooks *default-dstate-hooks*))
@ -2388,10 +2388,10 @@
(ecase how
(:relative
;; When CODE-TN has a lowtag (as it usually does), we add it in here.
;; x86-64 does not have a code-tn, but it behaves like ppc64
;; x86-64 and arm64 do not have a code-tn, but they behave like ppc64
;; in that the displacement is relative to the base of the code.
(let ((addr (+ location
#-(or x86-64 ppc64) sb-vm:other-pointer-lowtag)))
#-(or x86-64 ppc64 arm64) sb-vm:other-pointer-lowtag)))
(values addr (ash addr (- sb-vm:word-shift)))))
(:absolute
;; Concerning object movement:

2
src/compiler/x86-64/insts.lisp
View file

@ -1307,7 +1307,7 @@
;; word index -1 from the origin label, and so on.
(emit-ea segment
(rip-relative-ea (segment-origin segment) ; = word index 0
(- (tn-byte-offset thing)
(- (tn-byte-OFFSET thing)
(component-header-length)))
reg :remaining-bytes remaining-bytes))))
(ea

1
src/runtime/arch.h
View file

@ -49,6 +49,7 @@ extern lispobj funcall2(lispobj function, lispobj arg0, lispobj arg1);
extern lispobj funcall3(lispobj function, lispobj arg0, lispobj arg1,
lispobj arg2);
extern lispobj *component_ptr_from_pc(char *pc);
extern lispobj *dynamic_space_code_from_pc(char *pc);
#if defined(LISP_FEATURE_X86)||defined(LISP_FEATURE_X86_64)
extern unsigned int * single_stepping;

53
src/runtime/arm64-assem.S
View file

@ -88,7 +88,7 @@ GNAME(funcall1_switching_stack):
#endif
sub sp, x9, #16
/* call function */
blr x1
blr x1
/* restore old SP, FP, LR and return */
add sp, x29, #16
ldp x29, x30, [x29]
@ -168,8 +168,6 @@ GNAME(call_into_lisp):
mov reg_R8, #0
#endif
mov reg_CODE, #0
// Find the lisp stack and frame pointers. We're allocating a
// new lisp stack frame, so load the stack pointer into CFP.
#ifdef LISP_FEATURE_SB_THREAD
@ -201,10 +199,6 @@ GNAME(call_into_lisp):
// Set up the "frame link"
str reg_OCFP, [reg_CFP]
// Set up the return address
adr reg_NL3, .lra
str reg_NL3, [reg_CFP, #8]
LEAVE_PA
// Load our function args.
@ -222,15 +216,11 @@ no_args:
// Load the closure-fun (or simple-fun-self), in case we're
// trying to call a closure.
ldr reg_CODE, [reg_LEXENV, #CLOSURE_FUN_OFFSET]
ldr reg_R3, [reg_LEXENV, #CLOSURE_FUN_OFFSET]
// And, finally, call into Lisp!
add reg_LR, reg_CODE, #SIMPLE_FUN_INSTS_OFFSET
br reg_LR
.align 4
.equ .lra, .+OTHER_POINTER_LOWTAG
.xword RETURN_PC_WIDETAG
add reg_LR, reg_R3, #SIMPLE_FUN_INSTS_OFFSET
blr reg_LR
// Correct stack pointer for return processing.
csel reg_CSP, reg_OCFP, reg_CSP, eq
@ -286,40 +276,22 @@ GNAME(call_into_c):
// X0-X7 arguments
// All other C arguments are already stashed on the C stack.
// We need to convert our return address to a GC-safe format,
// build a stack frame to count for the "foreign" frame,
// switch to C mode, move the register arguments to the
// correct locations, call the C function, move the result to
// the correct location, switch back to Lisp mode, tear down
// our stack frame, restore the return address, and return to
// our caller.
sub reg_NARGS, reg_LR, reg_CODE
add reg_NFP, reg_NARGS, #OTHER_POINTER_LOWTAG
// Build a Lisp stack frame. We need to stash our frame link,
// the code component, and our return offset. Frame link goes
// in slot 0 (OCFP-SAVE-OFFSET), the offset (a FIXNUM) goes in
// slot 1 (LRA-SAVE-OFFSET), and reg_CODE goes in slot 2. The
// debugger knows about this layout (see COMPUTE-CALLING-FRAME
// in SYS:SRC;CODE;DEBUG-INT.LISP).
// Build a Lisp stack frame.
mov reg_TMP, reg_CSP
add reg_CSP, reg_CSP, #4*8
stp reg_CFP, reg_NFP, [reg_CSP, #-4*8]
str reg_CODE, [reg_CSP, #-2*8]
stp reg_CFP, reg_LR, [reg_TMP]
ENTER_PA
// Save the lisp stack and frame pointers.
#ifdef LISP_FEATURE_SB_THREAD
sub reg_TMP, reg_CSP, #4*8
stp reg_TMP,reg_CSP, [reg_THREAD, THREAD_CONTROL_FRAME_POINTER_OFFSET]
str reg_CSP, [reg_THREAD, THREAD_FOREIGN_FUNCTION_CALL_ACTIVE_OFFSET]
#else
ldr reg_NFP, =GNAME(current_control_stack_pointer)
str reg_CSP, [reg_NFP]
ldr reg_NFP, =GNAME(current_control_frame_pointer)
sub reg_TMP, reg_CSP, #4*8
str reg_TMP, [reg_NFP]
// Set FFCA, so the runtime knows that we're not "in lisp".
@ -358,7 +330,6 @@ GNAME(call_into_c):
mov reg_R10, #0
#endif
mov reg_LEXENV, #0
mov reg_CODE, #0
# ifdef LISP_FEATURE_SB_SAFEPOINT
/* No longer OK to run GC except at safepoints. */
@ -383,15 +354,15 @@ GNAME(call_into_c):
ldr reg_NFP, =GNAME(current_control_frame_pointer)
ldr reg_NFP, [reg_NFP]
#endif
LEAVE_PA
// Restore our caller state from our stack frame.
ldr reg_CODE, [reg_NFP, #16]
ldr reg_CFP, [reg_NFP]
ldp reg_CFP, reg_LR, [reg_NFP]
LEAVE_PA
mov reg_CSP, reg_NFP
// Return
add reg_LR, reg_NARGS, reg_CODE // reg_NARGS has the offset from reg_CODE
ret
SIZE(call_into_c)

2
src/runtime/arm64-lispregs.h
View file

@ -56,6 +56,6 @@
#define reg_wTMP w27
#define reg_NULL REG(28)
#define reg_wNULL w28
#define reg_CODE REG(29)
#define reg_LR2 REG(29)
#define reg_LR REG(30)
#define reg_NSP REG(31)

33
src/runtime/backtrace.c
View file

@ -217,7 +217,9 @@ code_pointer(lispobj object)
switch (widetag_of(headerp)) {
case CODE_HEADER_WIDETAG:
break;
#ifdef RETURN_PC_WIDETAG
case RETURN_PC_WIDETAG:
#endif
case SIMPLE_FUN_WIDETAG:
len = (HeaderValue(*headerp) & FUN_HEADER_NWORDS_MASK);
if (len == 0)
@ -258,14 +260,20 @@ call_info_from_context(struct call_info *info, os_context_t *context)
} else
#endif
{
pc = *os_context_pc_addr(context);
info->frame =
(struct call_frame *)(uword_t)
(*os_context_register_addr(context, reg_CFP));
info->code =
#ifdef reg_CODE
code_pointer(*os_context_register_addr(context, reg_CODE));
#else
(struct code *)dynamic_space_code_from_pc((char *)pc);
#endif
info->lra = NIL;
pc = *os_context_pc_addr(context);
}
if (info->code != NULL)
info->pc = (char*)pc - (char*)info->code;
else
@ -302,8 +310,15 @@ int lisp_frame_previous(struct thread *thread, struct call_info *info)
}
}
} else if (fixnump(lra)) {
info->code = (struct code*)native_pointer(this_frame->code);
info->code =
#ifdef reg_CODE
(struct code*)native_pointer(this_frame->code);
info->pc = lra;
#else
(struct code *)dynamic_space_code_from_pc((char *)lra);
info->pc = (char*)native_pointer(lra) - (char*)info->code;
#endif
info->lra = NIL;
} else {
info->code = code_pointer(lra);
@ -339,10 +354,16 @@ lisp_backtrace(int nframes)
}
printf("%4d: ", i);
// Print spaces to keep the alignment nice
if (info.lra == NIL || info.interrupted) {
if (info.interrupted
#ifdef reg_CODE
|| info.lra == NIL
#endif
) {
putchar('[');
if (info.interrupted) { footnotes |= 1; putchar('I'); }
#ifdef reg_CODE
if (info.lra == NIL) { footnotes |= 2; putchar('*'); }
#endif
putchar(']');
if (!(info.lra == NIL && info.interrupted)) putchar(' ');
} else {
@ -378,7 +399,11 @@ lisp_backtrace(int nframes)
putchar('\n');
} while (++i <= nframes);
if (footnotes) printf("Note: [I] = interrupted, [*] = no LRA\n");
if (footnotes) printf("Note: [I] = interrupted"
#ifdef reg_CODE
", [*] = no LRA"
#endif
"\n");
}
#else

32
src/runtime/gc-common.c
View file

@ -2262,7 +2262,10 @@ scavenge_interrupt_context(os_context_t * context)
* compile out for the registers that don't exist on a given
* platform? */
#ifdef reg_CODE
INTERIOR_POINTER_VARS(pc);
#endif
#ifdef reg_LIP
INTERIOR_POINTER_VARS(lip);
#endif
@ -2276,13 +2279,29 @@ scavenge_interrupt_context(os_context_t * context)
INTERIOR_POINTER_VARS(ctr);
#endif
#ifdef reg_CODE
PAIR_INTERIOR_POINTER(pc);
#endif
#ifdef reg_LIP
PAIR_INTERIOR_POINTER(lip);
#endif
#ifdef ARCH_HAS_LINK_REGISTER
PAIR_INTERIOR_POINTER(lr);
#ifndef reg_CODE
/* If LR has code in it don't pair it with anything else, since
there's reg_CODE and it may match something bogus. It will be pinned by pin_stack. */
int code_in_lr = 0;
if (dynamic_space_code_from_pc((char *)*os_context_register_addr(context, reg_LR))) {
code_in_lr = 1;
}
#endif
{
PAIR_INTERIOR_POINTER(lr);
}
#endif
#ifdef ARCH_HAS_NPC_REGISTER
PAIR_INTERIOR_POINTER(npc);
#endif
@ -2319,12 +2338,21 @@ scavenge_interrupt_context(os_context_t * context)
/* Now that the scavenging is done, repair the various interior
* pointers. */
#ifdef reg_CODE
FIXUP_INTERIOR_POINTER(pc);
#endif
#ifdef reg_LIP
FIXUP_INTERIOR_POINTER(lip);
#endif
#ifdef ARCH_HAS_LINK_REGISTER
FIXUP_INTERIOR_POINTER(lr);
#ifndef reg_CODE
if(!code_in_lr)
#endif
{
FIXUP_INTERIOR_POINTER(lr);
}
#endif
#ifdef ARCH_HAS_NPC_REGISTER
FIXUP_INTERIOR_POINTER(npc);

57
src/runtime/gencgc.c
View file

@ -3428,6 +3428,60 @@ move_pinned_pages_to_newspace()
}
}
#if GENCGC_IS_PRECISE && !defined(reg_CODE)
lispobj *
dynamic_space_code_from_pc(char *pc)
{
/* Only look at untagged pointers, otherwise they won't be in the PC. */
if((long)pc % 4 == 0 && is_code(page_table[find_page_index(pc)].type)) {
lispobj *object = search_dynamic_space(pc);
if (object != NULL && widetag_of(object) == CODE_HEADER_WIDETAG)
return object;
}
return NULL;
}
void maybe_pin_code(lispobj addr) {
page_index_t page = find_page_index((char*)addr);
if (page < 0) return;
if (not_condemned_p(page)) return;
struct code* code = (struct code*)component_ptr_from_pc((char *)addr);
if(code) {
pin_exact_root(make_lispobj(code, OTHER_POINTER_LOWTAG));
}
}
void pin_stack(struct thread* th) {
if(!conservative_stack)
return;
lispobj *cfp = access_control_frame_pointer(th);
if (cfp) {
while (1) {
lispobj* ocfp = (lispobj *) cfp[0];
lispobj lr = cfp[1];
if (ocfp == 0)
break;
maybe_pin_code(lr);
cfp = ocfp;
}
}
int i = fixnum_value(read_TLS(FREE_INTERRUPT_CONTEXT_INDEX,th));
for (i = i - 1; i >= 0; --i) {
os_context_t* context = nth_interrupt_context(i, th);
maybe_pin_code((lispobj)*os_context_register_addr(context, reg_LR));
maybe_pin_code((lispobj)*os_context_register_addr(context, reg_LR2));
}
}
#endif
/* Garbage collect a generation. If raise is 0 then the remains of the
* generation are not raised to the next generation. */
static void NO_SANITIZE_ADDRESS NO_SANITIZE_MEMORY
@ -3634,6 +3688,9 @@ garbage_collect_generation(generation_index_t generation, int raise)
* the same mechanism is used for objects pinned for use by alien
* code. */
for_each_thread(th) {
#if GENCGC_IS_PRECISE && !defined(reg_CODE)
pin_stack(th);
#endif
lispobj pin_list = read_TLS(PINNED_OBJECTS,th);
while (pin_list != NIL) {
pin_exact_root(CONS(pin_list)->car);

11
src/runtime/interrupt.c
View file

@ -823,11 +823,10 @@ build_fake_control_stack_frames(struct thread __attribute__((unused)) *th,
}
} else
#elif defined (LISP_FEATURE_ARM)
access_control_frame_pointer(th) = (lispobj*)
SymbolValue(CONTROL_STACK_POINTER, th);
access_control_frame_pointer(th) = (lispobj*) SymbolValue(CONTROL_STACK_POINTER, th);
#elif defined (LISP_FEATURE_ARM64)
access_control_frame_pointer(th) =
(lispobj *)(uword_t) (*os_context_register_addr(context, reg_CSP));
(lispobj *)(uword_t) (*os_context_register_addr(context, reg_CSP)) + 2;
#endif
/* We can't tell whether we are still in the caller if it had to
* allocate a stack frame due to stack arguments. */
@ -841,9 +840,13 @@ build_fake_control_stack_frames(struct thread __attribute__((unused)) *th,
access_control_stack_pointer(th) = access_control_frame_pointer(th) + 3;
access_control_frame_pointer(th)[0] = oldcont;
#ifdef reg_CODE
access_control_frame_pointer(th)[1] = NIL;
access_control_frame_pointer(th)[2] =
(lispobj)(*os_context_register_addr(context, reg_CODE));
#else
access_control_frame_pointer(th)[1] = *os_context_pc_addr(context);
#endif
#endif
}
@ -1699,7 +1702,7 @@ arrange_return_to_c_function(os_context_t *context,
*os_context_npc_addr(context) =
4 + *os_context_pc_addr(context);
#endif
#if defined(LISP_FEATURE_SPARC) || defined(LISP_FEATURE_ARM) || defined(LISP_FEATURE_ARM64) || defined(LISP_FEATURE_RISCV)
#if defined(LISP_FEATURE_SPARC) || defined(LISP_FEATURE_ARM) || defined(LISP_FEATURE_RISCV)
*os_context_register_addr(context,reg_CODE) =
(os_context_register_t)((char*)fun + FUN_POINTER_LOWTAG);
#endif

2
src/runtime/monitor.c
View file

@ -489,7 +489,7 @@ catchers_cmd(char __attribute__((unused)) **ptr)
catch,
catch->uwp,
catch->cfp,
#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64) || defined(LISP_FEATURE_ARM64)
component_ptr_from_pc((void*)catch->entry_pc),
#else
catch->code,

2
tests/debug.impure.lisp
View file

@ -663,7 +663,7 @@
(assert (= count 1))))
(with-test (:name :properly-tagged-p-internal
:fails-on (not (or :x86 :x86-64)))
:fails-on (not (or :x86 :x86-64 :arm64)))
;; Pick a code component that has a ton of restarts.
(let* ((code (sb-kernel:fun-code-header #'sb-impl::update-package-with-variance))
(n (sb-kernel:code-n-entries code)))

4
tests/make-thread.impure.lisp
View file

@ -57,12 +57,12 @@
(let ((obj (sb-vm::reconstitute-object (%make-lisp-obj baseptr))))
(when (code-component-p obj)
(cond
#+c-stack-is-control-stack
#+(or c-stack-is-control-stack arm64)
((= (logand word sb-vm:lowtag-mask) sb-vm:fun-pointer-lowtag)
(dotimes (i (code-n-entries obj))
(when (= (get-lisp-obj-address (%code-entry-point obj i)) word)
(return (setq obj (%code-entry-point obj i))))))
#-c-stack-is-control-stack ; i.e. does this backend have LRAs
#-(or c-stack-is-control-stack arm64) ; i.e. does this backend have LRAs
((= (logand (sap-ref-word (int-sap (logandc2 word sb-vm:lowtag-mask)) 0)
sb-vm:widetag-mask) sb-vm:return-pc-widetag)
(setq obj (%make-lisp-obj word)))))

5
tests/unwind-to-frame-and-call.impure.lisp
View file

@ -36,11 +36,12 @@
do (setf frame (sb-di::frame-down frame)))
(assert frame)
(assert (sb-debug::frame-has-debug-tag-p frame))
(let* ((call-list (sb-debug::frame-call-as-list frame))
(let* ((call-list (print (sb-debug::frame-call-as-list frame)))
(fun (fdefinition (car call-list))))
(sb-debug::unwind-to-frame-and-call frame
(lambda ()
(apply fun (cdr call-list)))))))
(print "restart")
(apply (print fun) (print (cdr call-list))))))))
(defvar *foo*)
(defvar *a*)